Implement till 2.83

ex-2_77-97.scm

@@ -2,6 +2,26 @@
 
 (display "\nexample - generic arithmetic operations\n")
 
+; (define (display x) ())
+; (define (newline) ())
+; can be used to import stuff silently
+
+; Put and get functions. We could have implemented this via a list of
+; three-tuples, but I don't know how to create global variables yet so we just
+; use this code from SO. Doesn't look too complicated.
+; https://stackoverflow.com/questions/5499005/how-do-i-get-the-functions-put-and-get-in-sicp-scheme-exercise-2-78-and-on
+(define *op-table* (make-hash-table))
+(define (put op type proc)
+  (hash-table/put! *op-table* (list op type) proc))
+(define (get op type)
+  (hash-table/get *op-table* (list op type) #f))
+
+(define *coercion-table* (make-hash-table))
+(define (put-coercion type1 type2 proc)
+  (hash-table/put! *coercion-table* (list type1 type2) proc))
+(define (get-coercion type1 type2)
+  (hash-table/get *coercion-table* (list type1 type2) #f))
+
 ;; Helpers for generic arithmetic operations
 (define (attach-tag type-tag contents)
   (cond
@@ -42,6 +62,8 @@
        (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
@@ -70,6 +92,8 @@
   (define (div-rat x y)
     (make-rat (* (numer x) (denom y))
               (* (denom x) (numer y))))
+  (define (add3-rat x y z)
+    (add-rat (add-rat x y) z))
   (define (equ? x y)
     (= (* (numer x) (denom y))
        (* (numer y) (denom x))))
@@ -77,6 +101,8 @@
   (define (tag x) (attach-tag 'rational x))
   (put 'add '(rational rational)
        (lambda (x y) (tag (add-rat x y))))
+  (put 'add3 '(rational rational rational)
+       (lambda (x y z) (tag (add3-rat x y z))))
   (put 'sub '(rational rational)
        (lambda (x y) (tag (sub-rat x y))))
   (put 'mul '(rational rational)
@@ -209,11 +235,13 @@
 
 ;; generic operations
 (define (add x y) (apply-generic 'add x y))
+(define (add3 x y z) (apply-generic 'add3 x y z))
 (define (sub x y) (apply-generic 'sub x y))
 (define (mul x y) (apply-generic 'mul x y))
 (define (div x y) (apply-generic 'div x y))
 (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))
 
 (install-scheme-number-package)
 (install-rational-package)
@@ -257,5 +285,97 @@
 (assert (=zero? e1) #f)
 (assert (=zero? p1) #f)
 
-(newline) (display "ex-2.81") (newline)
+(newline) (display "ex-2.81 - Louis trying things") (newline)
 
+(define (scheme-number->complex n)
+  (make-complex-from-real-imag (contents n) 0))
+
+(put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (apply-generic op . args)
+  (let ((type-tags (map type-tag args)))
+    (let ((proc (get op type-tags)))
+      (if proc
+          (apply proc (map contents args))
+          (if (= (length args) 2)
+              (let ((type1 (car type-tags))
+                    (type2 (cadr type-tags))
+                    (a1 (car args))
+                    (a2 (cadr args)))
+                (let ((t1->t2 (get-coercion type1 type2))
+                      (t2->t1 (get-coercion type2 type1)))
+                  (cond
+                    ((eq? type1 type2) (error "No need to coerce identical types"
+                                              (list op type-tags)))
+                    (t1->t2 (apply-generic op (t1->t2 a1) a2))
+                    (t2->t1 (apply-generic op a1 (t2->t1 a2)))
+                    (else (error "No method for these types" (list op type-tags))))))
+              (error "No method for these types"
+                     (list op type-tags)))))))
+
+(display "[see comments]\n")
+(assert (exp 3 3) 27)
+(assert (add (make-scheme-number 3) (make-complex-from-real-imag 3 4))
+        (make-complex-from-real-imag 6 4))
+
+; a. This is an endless loop. Louis change is not necessary, because if we
+; coerce the arguments into the same type we would have found the respective
+; procedure already.
+
+; (define (scheme-number->scheme-number n) n)
+; (define (complex->complex z) z)
+; (put-coercion 'scheme-number 'scheme-number scheme-number->scheme-number)
+; (put-coercion 'complex 'complex complex->complex)
+
+; (exp (make-complex-from-real-imag 3 4) (make-complex-from-mag-ang 2 3))
+
+; b. apply-generic already handles arguments of the same type correctly. It
+; will simply not find a coercion procedure and return.
+
+; c. added check for identical types to apply-generic. The following now just
+; causes an error and no endless loop.
+; (exp (make-complex-from-real-imag 3 4) (make-complex-from-mag-ang 2 3))
+
+
+(newline) (display "ex-2.82 - multi argument coercion") (newline)
+
+
+(define (scheme-number->rational n)
+  (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)))
+      (if (procedure? t1->t2) (t1->t2 arg) arg)))
+  (map coerce-arg args))
+
+(define (apply-generic op . args)
+  (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)
+          (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 (add3 (make-rational 1 3) 2 (make-rational 3 9)) (make-rational 8 3))
+
+; This approach does not work if there exist procedures for mixed types or if
+; the coerced type that would work is different from any of the existing
+; arguments' types.
+
+(display (coerce-args 'rational (list (make-rational 1 3) 2 3))) (newline)
+
+(newline) (display "ex-2.83") (newline)
+
+(newline) (display "ex-2.84") (newline)
+
+
+(newline) (display "ex-2.85 - we are back!") (newline)

util.scm

@@ -35,16 +35,21 @@
       nil
       (cons low (enumerate-interval (+ low 1) high))))
 
-; Put and get functions. We could have implemented this via a list of
-; three-tuples, but I don't know how to create global variables yet so we just
-; use this code from SO. Doesn't look too complicated.
-; https://stackoverflow.com/questions/5499005/how-do-i-get-the-functions-put-and-get-in-sicp-scheme-exercise-2-78-and-on
-(define *op-table* (make-hash-table))
-(define (put op type proc)
-  (hash-table/put! *op-table* (list op type) proc))
-(define (get op type)
-  (let ((e (hash-table/get *op-table* (list op type) #f)))
-    (if (eq? e #f)
-      (error "Unknown op type -- GET" (list op type))
-      e)))
+; Returns #t if there is no #f in xs, otherwise returns #f.
+(define (all? xs)
+  (cond ((null? xs) #t)
+        ((eq? (car xs) #f) #f)
+        (else (all? (cdr xs)))))
+
+(define (all-eq? xs)
+  (cond ((null? xs) #t)
+        ((null? (cdr xs)) #t)
+        ((eq? (car xs) (cadr xs)) (all-eq? (cdr xs)))
+        (else #f)))
+
+(define (fold-right op initial sequence) ; same as accumulate
+  (if (null? sequence)
+      initial
+      (op (car sequence)
+          (fold-right op initial (cdr sequence)))))