Implement till 2.84

ex-2_77-97.scm

@@ -49,26 +49,33 @@
             "No method for these types -- APPLY-GENERIC"
             (list op type-tags))))))
 
-(define (install-scheme-number-package)
+(define (install-integer-package)
+  (define (make-integer x)
+    (if (integer? x)
+      (tag x)
+      (error "Not an integer -- MAKE-INTEGER " x)))
+  (define (integer->rational x)
+    (make-rational x 1))
   (define (tag x)
-    (attach-tag 'scheme-number x))
+    (attach-tag 'integer x))
-  (put 'add '(scheme-number scheme-number)
+  (put 'add '(integer integer)
        (lambda (x y) (tag (+ x y))))
-  (put 'sub '(scheme-number scheme-number)
+  (put 'sub '(integer integer)
        (lambda (x y) (tag (- x y))))
-  (put 'mul '(scheme-number scheme-number)
+  (put 'mul '(integer integer)
        (lambda (x y) (tag (* x y))))
-  (put 'div '(scheme-number scheme-number)
+  (put 'div '(integer integer)
        (lambda (x y) (tag (/ x y))))
-  (put 'equ? '(scheme-number scheme-number)
+  (put 'equ? '(integer integer)
        (lambda (x y) (= x y)))
-  (put 'exp '(scheme-number scheme-number)
+  (put 'exp '(integer integer)
        (lambda (x y) (tag (expt x y)))) ; using primitive expt
-  (put '=zero? '(scheme-number)
+  (put '=zero? '(integer)
        (lambda (x) (= x 0)))
-  (put 'make 'scheme-number
+  (put 'make 'integer
-       (lambda (x) (tag x)))
+       (lambda (x) (make-integer x)))
-  (display "[install-scheme-number-package]\n")
+  (put 'raise '(integer) integer->rational)
+  (display "[install-integer-package]\n")
   'done)
 
 (define (install-rational-package)
@@ -97,6 +104,8 @@
   (define (equ? x y)
     (= (* (numer x) (denom y))
        (* (numer y) (denom x))))
+  (define (rational->real x)
+    (make-scheme-number (/ (numer x) (denom x))))
   ;; interface to rest of the system
   (define (tag x) (attach-tag 'rational x))
   (put 'add '(rational rational)
@@ -114,9 +123,35 @@
        (lambda (x) (= (numer x) 0)))
   (put 'make 'rational
        (lambda (n d) (tag (make-rat n d))))
+  (put 'raise '(rational) rational->real)
   (display "[install-rational-package]\n")
   'done)
 
+(define (install-scheme-number-package)
+  (define (tag x)
+    (attach-tag 'scheme-number x))
+  (define (real->complex x)
+    (make-complex-from-real-imag x 0))
+  (put 'add '(scheme-number scheme-number)
+       (lambda (x y) (tag (+ x y))))
+  (put 'sub '(scheme-number scheme-number)
+       (lambda (x y) (tag (- x y))))
+  (put 'mul '(scheme-number scheme-number)
+       (lambda (x y) (tag (* x y))))
+  (put 'div '(scheme-number scheme-number)
+       (lambda (x y) (tag (/ x y))))
+  (put 'equ? '(scheme-number scheme-number)
+       (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)
+       (lambda (x) (= x 0)))
+  (put 'make 'scheme-number
+       (lambda (x) (tag x)))
+  (put 'raise '(scheme-number) real->complex)
+  (display "[install-scheme-number-package]\n")
+  'done)
+
 (define (install-rectangular-package)
   (define (real-part z) (car z))
   (define (imag-part z) (cdr z))
@@ -216,12 +251,15 @@
   'done)
 
 ;; constructors
-(define (make-scheme-number n)
+(define (make-integer n)
-  ((get 'make 'scheme-number) n))
+  ((get 'make 'integer) n))
 
 (define (make-rational n d)
   ((get 'make 'rational) n d))
 
+(define (make-scheme-number n)
+  ((get 'make 'scheme-number) n))
+
 (define (make-complex-from-real-imag x y)
   ((get 'make-from-real-imag 'complex) x y))
 
@@ -242,9 +280,11 @@
 (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))
 
-(install-scheme-number-package)
+(install-integer-package)
 (install-rational-package)
+(install-scheme-number-package)
 (install-rectangular-package)
 (install-polar-package)
 (install-complex-package)
@@ -344,8 +384,6 @@
   (make-rational (contents n) 1))
 (put-coercion 'scheme-number 'rational scheme-number->rational)
 
-; Try to coerce all args into target-type. Returns list if successful and empty
-; list otherwise.
 (define (coerce-args target-type args)
   (define (coerce-arg arg)
     (let ((t1->t2 (get-coercion (type-tag arg) target-type)))
@@ -375,7 +413,44 @@
 
 (newline) (display "ex-2.83") (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 i (make-integer 3))
+(display i) (newline)
+(display (raise i)) (newline)
+(display (raise (raise i))) (newline)
+(display (raise (raise (raise i)))) (newline)
+
 (newline) (display "ex-2.84") (newline)
 
+; All we have to do is update coerce-args to do consecutive raises
+; to reach the target type.
+(define (coerce-args target-type args)
+  (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))
+           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))))
+
+(newline) (display "ex-2.85 - drop it") (newline)
+
+
+(newline) (display "ex-2.86") (newline)
+
 
-(newline) (display "ex-2.85 - we are back!") (newline)