Implement till 2.86

ex-2_77-97.scm

@@ -34,6 +34,12 @@
     ((pair? datum) (car datum))
     (else (error "Bad tagged datum -- TYPE-TAG" datum))))
 
+(define (has-tag? datum)
+  (cond
+    ((number? datum) #t)
+    ((pair? datum) #t)
+    (else #f)))
+
 (define (contents datum)
   (cond
     ((number? datum) datum)
@@ -49,33 +55,31 @@
             "No method for these types -- APPLY-GENERIC"
             (list op type-tags))))))
 
-(define (install-integer-package)
-  (define (make-integer x)
-    (if (integer? x)
-      (tag x)
-      (error "Not an integer -- MAKE-INTEGER " x)))
-  (define (integer->rational x)
+(define (install-scheme-number-package)
+  (define (tag x) x)
+  (define (scheme->rational x)
     (make-rational x 1))
-  (define (tag x)
-    (attach-tag 'integer x))
-  (put 'add '(integer integer)
+  (put 'add '(scheme-number scheme-number)
        (lambda (x y) (tag (+ x y))))
-  (put 'sub '(integer integer)
+  (put 'sub '(scheme-number scheme-number)
        (lambda (x y) (tag (- x y))))
-  (put 'mul '(integer integer)
+  (put 'mul '(scheme-number scheme-number)
        (lambda (x y) (tag (* x y))))
-  (put 'div '(integer integer)
+  (put 'div '(scheme-number scheme-number)
        (lambda (x y) (tag (/ x y))))
-  (put 'equ? '(integer integer)
+  (put 'equ? '(scheme-number scheme-number)
        (lambda (x y) (= x y)))
-  (put 'exp '(integer integer)
-       (lambda (x y) (tag (expt x y)))) ; using primitive expt
-  (put '=zero? '(integer)
+  (put 'exp '(scheme-number scheme-number)
+       (lambda (x y) (tag (expt x y))))
+  (put '=zero? '(scheme-number)
        (lambda (x) (= x 0)))
-  (put 'make 'integer
-       (lambda (x) (make-integer x)))
-  (put 'raise '(integer) integer->rational)
-  (display "[install-integer-package]\n")
+  (put 'make 'scheme-number
+       (lambda (x) (tag x)))
+  (put 'arctan '(scheme-number scheme-number)
+       (lambda (x y) (atan x y)))
+  (put 'square-root '(scheme-number) sqrt)
+  (put 'raise 'scheme-number scheme->rational)
+  (display "[install-scheme-number-package]\n")
   'done)
 
 (define (install-rational-package)
@@ -83,8 +87,10 @@
   (define (numer x) (car x))
   (define (denom x) (cdr x))
   (define (make-rat n d)
-    (let ((g (gcd n d)))
-      (cons (/ n g) (/ d g))))
+    (if (and (integer? n) (integer? d))
+      (let ((g (gcd n d)))
+        (cons (/ n g) (/ d g)))
+      (cons n d)))
   (define (add-rat x y)
     (make-rat (+ (* (numer x) (denom y))
                  (* (numer y) (denom x)))
@@ -105,7 +111,9 @@
     (= (* (numer x) (denom y))
        (* (numer y) (denom x))))
   (define (rational->real x)
-    (make-scheme-number (/ (numer x) (denom x))))
+    (make-real (/ (numer x) (denom x))))
+  (define (rational->scheme x)
+    (make-scheme-number (inexact->exact (round (/ (numer x) (denom x))))))
   ;; interface to rest of the system
   (define (tag x) (attach-tag 'rational x))
   (put 'add '(rational rational)
@@ -121,51 +129,63 @@
   (put 'equ? '(rational rational) equ?)
   (put '=zero? '(rational)
        (lambda (x) (= (numer x) 0)))
+  (define (arctan-rational x y)
+    (atan (/ (numer x) (denom x))
+          (/ (numer y) (denom y))))
+  (put 'arctan '(rational rational) arctan-rational)
+  (put 'square-root '(rational)
+       (lambda (x) (sqrt (/ (numer x) (denom x)))))
   (put 'make 'rational
        (lambda (n d) (tag (make-rat n d))))
-  (put 'raise '(rational) rational->real)
+  (put 'raise 'rational rational->real)
+  (put 'project 'rational rational->scheme)
   (display "[install-rational-package]\n")
   'done)
 
-(define (install-scheme-number-package)
-  (define (tag x)
-    (attach-tag 'scheme-number x))
+(define (install-real-package)
+  (define (make-real x) (tag x))
+  (define (real->rational x)
+    (make-rational x 1))
   (define (real->complex x)
     (make-complex-from-real-imag x 0))
-  (put 'add '(scheme-number scheme-number)
+  (define (tag x)
+    (attach-tag 'real x))
+  (put 'add '(real real)
        (lambda (x y) (tag (+ x y))))
-  (put 'sub '(scheme-number scheme-number)
+  (put 'sub '(real real)
        (lambda (x y) (tag (- x y))))
-  (put 'mul '(scheme-number scheme-number)
+  (put 'mul '(real real)
        (lambda (x y) (tag (* x y))))
-  (put 'div '(scheme-number scheme-number)
+  (put 'div '(real real)
        (lambda (x y) (tag (/ x y))))
-  (put 'equ? '(scheme-number scheme-number)
+  (put 'equ? '(real real)
        (lambda (x y) (= x y)))
-  (put 'exp '(scheme-number scheme-number)
-       (lambda (x y) (tag (expt x y)))) ; using primitive expt
-  (put '=zero? '(scheme-number)
+  (put 'exp '(real real)
+       (lambda (x y) (tag (expt x y))))
+  (put '=zero? '(real)
        (lambda (x) (= x 0)))
-  (put 'make 'scheme-number
-       (lambda (x) (tag x)))
-  (put 'raise '(scheme-number) real->complex)
-  (display "[install-scheme-number-package]\n")
+  (put 'make 'real
+       (lambda (x) (make-real x)))
+  (put 'raise 'real real->complex)
+  (put 'project 'real real->rational)
+  (display "[install-real-package]\n")
   'done)
 
 (define (install-rectangular-package)
   (define (real-part z) (car z))
   (define (imag-part z) (cdr z))
+  (define (square x) (mul x x))
   (define (magnitude z)
-    (sqrt (+ (square (real-part z))
-             (square (imag-part z)))))
+    (square-root (add (square (real-part z))
+                      (square (imag-part z)))))
   (define (angle z)
-    (atan (imag-part z)
-          (real-part z)))
+    (arctan (imag-part z)
+            (real-part z)))
   (define (tag z) (attach-tag 'rectangular z))
   (define (make-from-real-imag x y)
     (tag (cons x y)))
   (define (make-from-mag-ang r a)
-    (tag (cons (* r (cos a)) (* r (sin a)))))
+    (tag (cons (mul r (cos a)) (mul r (sin a)))))
   ; interface to the rest of the system
   (put 'real-part '(rectangular) real-part)
   (put 'imag-part '(rectangular) imag-part)
@@ -179,14 +199,15 @@
 
 (define (install-polar-package)
   (define (real-part z)
-    (* (magnitude z) (cos (angle z))))
+    (mul (magnitude z) (cos (angle z))))
   (define (imag-part z)
-    (* (magnitude z) (sin (angle z))))
+    (mul (magnitude z) (sin (angle z))))
   (define (magnitude z) (car z))
   (define (angle z) (cdr z))
+  (define (sqrt x) (mul x x))
   (define (tag z) (attach-tag 'polar z))
   (define (make-from-real-imag x y)
-    (tag (cons (sqrt (+ (square x) (square y)))
+    (tag (cons (sqrt (add (square x) (square y)))
                (atan y x))))
   (define (make-from-mag-ang r a) (tag (cons r a)))
   ; interface to rest of the system
@@ -213,20 +234,22 @@
   (define (angle z) (apply-generic 'angle z))
   ;; internal procedures
   (define (add-complex z1 z2)
-    (make-from-real-imag (+ (real-part z1) (real-part z2))
-                         (+ (imag-part z1) (imag-part z2))))
+    (make-from-real-imag (add (real-part z1) (real-part z2))
+                         (add (imag-part z1) (imag-part z2))))
   (define (sub-complex z1 z2)
-    (make-from-real-imag (- (real-part z1) (real-part z2))
-                         (- (imag-part z1) (imag-part z2))))
+    (make-from-real-imag (sub (real-part z1) (real-part z2))
+                         (sub (imag-part z1) (imag-part z2))))
   (define (mul-complex z1 z2)
-    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
-                       (+ (angle z1) (angle z2))))
+    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
+                       (add (angle z1) (angle z2))))
   (define (div-complex z1 z2)
-    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
-                       (- (angle z1) (angle z2))))
-  (define (equ? z1 z2)
-    (and (= (magnitude z1) (magnitude z2))
-         (= (angle z1) (angle z2))))
+    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
+                       (sub (angle z1) (angle z2))))
+  (define (equ?-complex z1 z2)
+    (and (equ? (magnitude z1) (magnitude z2))
+         (equ? (angle z1) (angle z2))))
+  (define (complex->real x)
+    (make-real (real-part x)))
   ;; interface to rest of the system
   (put 'real-part '(complex) real-part)
   (put 'imag-part '(complex) imag-part)
@@ -245,20 +268,21 @@
        (lambda (x y) (tag (make-from-real-imag x y))))
   (put 'make-from-mag-ang 'complex
        (lambda (r a) (tag (make-from-mag-ang r a))))
-  (put 'equ? '(complex complex) equ?)
+  (put 'equ? '(complex complex) equ?-complex)
   (put '=zero? '(complex) =zero?)
+  (put 'project 'complex complex->real)
   (display "[install-complex-package]\n")
   'done)
 
 ;; constructors
-(define (make-integer n)
-  ((get 'make 'integer) n))
+(define (make-scheme-number n)
+  ((get 'make 'scheme-number) n))
 
 (define (make-rational n d)
   ((get 'make 'rational) n d))
 
-(define (make-scheme-number n)
-  ((get 'make 'scheme-number) n))
+(define (make-real n)
+  ((get 'make 'real) n))
 
 (define (make-complex-from-real-imag x y)
   ((get 'make-from-real-imag 'complex) x y))
@@ -280,11 +304,12 @@
 (define (equ? x y) (apply-generic 'equ? x y))
 (define (=zero? x) (apply-generic '=zero? x))
 (define (exp x y) (apply-generic 'exp x y))
-(define (raise x) (apply-generic 'raise x))
+(define (arctan x y) (apply-generic 'arctan x y))
+(define (square-root x) (apply-generic 'square-root x))
 
-(install-integer-package)
-(install-rational-package)
 (install-scheme-number-package)
+(install-rational-package)
+(install-real-package)
 (install-rectangular-package)
 (install-polar-package)
 (install-complex-package)
@@ -411,15 +436,18 @@
 
 (display (coerce-args 'rational (list (make-rational 1 3) 2 3))) (newline)
 
-(newline) (display "ex-2.83") (newline)
+(newline) (display "ex-2.83 - raise") (newline)
 
 ; Our scheme-number package supports real numbers so we use that as our
 ; real-number package without further changes. Additionally, we create an
 ; integer package that only accepts integers in the constructor.
 
-(assert (sub (make-integer 3) (make-integer 1)) (make-integer 2))
+(define (raise x)
+  ((get 'raise (type-tag x)) (contents x)))
 
-(define i (make-integer 3))
+(assert (sub (make-scheme-number 3) (make-scheme-number 1)) (make-scheme-number 2))
+
+(define i (make-scheme-number 3))
 (display i) (newline)
 (display (raise i)) (newline)
 (display (raise (raise i))) (newline)
@@ -433,24 +461,90 @@
   (define (coerce-arg arg)
     (if (eq? (type-tag arg) target-type)
       arg
-      (let ((proc (get 'raise (list (type-tag arg)))))
-         (if (procedure? proc)
-           (proc (contents arg))
+      (let ((raise (get 'raise (type-tag arg))))
+         (if (procedure? raise)
+           (raise (contents arg))
            arg))))
   (let ((coerced-args (map coerce-arg args)))
     (if (equal? args coerced-args)
       coerced-args ; no more raising possible
       (coerce-args target-type coerced-args))))
 
-(assert (equ? (make-integer 3) (make-complex-from-real-imag 3 0)) #t)
-(assert (equ? (make-integer 3) (make-complex-from-real-imag 3 1)) #f)
-(assert (equ? (make-integer 3) (make-rational 3 1)) #t)
-(assert (add3 (make-rational 1 3) (make-integer 2) (make-rational 3 9)) (make-rational 8 3))
-;(display (coerce-args 'scheme-number (list (make-rational 1 3) 2 (make-rational 3 9))))
+(assert (equ? (make-scheme-number 3) (make-complex-from-real-imag 3 0)) #t)
+(assert (equ? (make-scheme-number 3) (make-complex-from-real-imag 3 1)) #f)
+(assert (equ? (make-scheme-number 3) (make-rational 3 1)) #t)
+(assert (add3 (make-rational 1 3) (make-scheme-number 2) (make-rational 3 9)) (make-rational 8 3))
 
-(newline) (display "ex-2.85 - drop it") (newline)
-
-
-(newline) (display "ex-2.86") (newline)
+(newline) (display "ex-2.85 - project and drop") (newline)
+
+; Do not implement project in terms of apply-generic as that will result in an
+; endless loop when trying to drop values later automatically within the
+; context of apply-generic.
+(define (project x)
+  ((get 'project (type-tag x)) (contents x)))
+
+(define c (make-complex-from-real-imag 4.2 1))
+(display c) (newline)
+(display (project c)) (newline)
+(display (project (project c))) (newline)
+(display (project (project (project c)))) (newline)
+
+; Implement drop to transform number to lowest possible representation
+(define (drop x)
+  ;(display "---------\ndrop  ") (display x) (newline)
+  (if (has-tag? x)
+    (let ((project (get 'project (type-tag x))))
+      (if (procedure? project)
+        (let ((projected (project (contents x))))
+          (if (equ? projected x)
+            (drop projected)
+            x))
+        x))
+    x))
+
+;(assert (drop 3) (make-scheme-number 3))
+;(assert (drop (make-complex-from-real-imag 3.2 0)) (drop (make-real (/ 16 5.))))
+;(assert (drop (make-complex-from-real-imag 3 0)) (make-scheme-number 3))
+
+(define (apply-generic op . args)
+  ;(display "-----\napply-generic ") (display op) (display " ") (display args) (newline)
+  (define (try-args args-list)
+    (if (null? args-list)
+      (error "No method for these types" (list op (map type-tag args)))
+      (let ((proc (get op (map type-tag (car args-list))))
+            (args-contents (map contents (car args-list))))
+        (if (procedure? proc)
+          (drop (apply proc args-contents))
+          (try-args (cdr args-list))))))
+  (define (coerce-to-arg arg)
+    (coerce-args (type-tag arg) args))
+  (try-args (cons args (map coerce-to-arg args))))
+
+(assert (equ? (add (make-rational 1 3)
+             (make-complex-from-real-imag 3 0))
+        (make-rational 10 3)) #t)
+(assert (add (make-rational 6 3)
+             (make-complex-from-real-imag 3 0))
+        (make-scheme-number 5))
+(assert (add (make-rational 6 3)
+             (make-complex-from-real-imag 3 0))
+        5)
+
+(display "\nex-2.86 - generic complex numbers\n")
+
+; All the procedures that are used by the complex packages would also have to
+; use the generic procedures. For example, we cannot use *, -, /, +, and have
+; to replace them with their generic counter-part. We then also have to
+; implement sine and cosine. I have skipped sin and cos, but handle atan and
+; sqrt, so the following works.
+
+(define cr (make-complex-from-real-imag (make-rational 1 2)
+                                        (make-rational 1 2)))
+(display (add cr cr)) (newline)
+(display (mul cr cr)) (newline)
+
+(display "\n\nexample - symbolic algebra\n")
+
+(display "\nex-2.87\n")