Added ex 2.77

scheme/week09/ex2_77.scm

@@ -0,0 +1,275 @@
+;; SICP 2.77
+
+;; Exercise 2.77.  Louis Reasoner tries to evaluate the expression
+;; (magnitude z) where z is the object shown in figure 2.24. To his
+;; surprise, instead of the answer 5 he gets an error message from
+;; apply-generic, saying there is no method for the operation
+;; magnitude on the types (complex). He shows this interaction to
+;; Alyssa P. Hacker, who says ``The problem is that the complex-number
+;; selectors were never defined for complex numbers, just for polar
+;; and rectangular numbers. All you have to do to make this work is
+;; add the following to the complex package:''
+
+;; (put 'real-part '(complex) real-part)
+;; (put 'imag-part '(complex) imag-part)
+;; (put 'magnitude '(complex) magnitude)
+;; (put 'angle '(complex) angle)
+
+;; Describe in detail why this works. As an example, trace through all
+;; the procedures called in evaluating the expression (magnitude z)
+;; where z is the object shown in figure 2.24. In particular, how many
+;; times is apply-generic invoked? What procedure is dispatched to in
+;; each case?
+
+;; ANSWER ------------------------------------------------------------
+
+;; In order for (magnitude z) to work, there must [1] be a defintion
+;; of magnitude that invokes apply-generic (I don't think that was
+;; given in the book), and [2] the type of z in question must contain
+;; a handler for 'magnitude.
+;;
+;; Here is the sequence.
+;;
+;; [1] (magnitude c)      -- Call generic magnitude on a complex/rectangular number
+;; [2] (magnitude r)      -- Call generic magnitude on a rectangular number
+;; [3] (magnitude raw)    -- Call rectangular specific magnitude
+;;                        -- on raw rectangular implementation
+
+;; CODE --------------------------------------------------------------
+
+;; TABLE operators
+
+(define *table* ())
+
+(define (clear-table)
+  (set! *table* ()) 'ok)
+(clear-table)
+
+(define (put operator type value)
+  (let ((key (list operator type)))
+    (set! *table* (del-assoc key *table*))
+    (set! *table* (cons (cons key value) *table*))))
+
+(define (get operator type)
+  (let* ((key (list operator type))
+         (pair (assoc key *table*))) 
+    (if (pair? pair) (cdr pair) false)))
+
+
+;; Tagged data and generic application
+
+(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))
+          (error
+            "No method for these types -- APPLY-GENERIC"
+            (list op type-tags))))))
+
+(define (attach-tag type-tag contents)
+  (cons type-tag contents))
+(define (type-tag datum)
+  (if (pair? datum)
+      (car datum)
+      (error "Bad tagged datum -- TYPE-TAG" datum)))
+(define (contents datum)
+  (if (pair? datum)
+      (cdr datum)
+      (error "Bad tagged datum -- CONTENTS" datum)))
+
+;; Generic functions
+
+(define (add x y) (apply-generic 'add x y))
+(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 (numer r) (apply-generic 'numer r))
+(define (denom r) (apply-generic 'denom r))
+
+;; Added for this exercise
+(define (real-part c) (apply-generic 'real-part c))
+(define (imag-part c) (apply-generic 'imag-part c))
+(define (magnitude c) (apply-generic 'magnitude c))
+(define (angle c)     (apply-generic 'angle     c))
+
+;; Scheme number package
+
+(define (install-scheme-number-package)
+  (define (tag x)
+    (attach-tag 'scheme-number x))    
+  (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 'make 'scheme-number
+       (lambda (x) (tag x)))
+  'done)
+
+(define (make-scheme-number n)
+  ((get 'make 'scheme-number) n))
+
+(install-scheme-number-package)
+
+;; Rational Number Package
+
+(define (install-rational-package)
+  ;; internal procedures
+  (define (numer x) (car x))
+  (define (denom x) (cdr x))
+  (define (make n d)
+    (let ((g (gcd n d)))
+      (cons (/ n g) (/ d g))))
+  (define (add x y)
+    (make (+ (* (numer x) (denom y))
+                 (* (numer y) (denom x)))
+              (* (denom x) (denom y))))
+  (define (sub x y)
+    (make (- (* (numer x) (denom y))
+                 (* (numer y) (denom x)))
+              (* (denom x) (denom y))))
+  (define (mul x y)
+    (make (* (numer x) (numer y))
+              (* (denom x) (denom y))))
+  (define (div x y)
+    (make (* (numer x) (denom y))
+              (* (denom x) (numer y))))
+  ;; interface to rest of the system
+  (define (tag x) (attach-tag 'rational x))
+  (put 'numer '(rational)
+       (lambda (x) (make-scheme-number (numer x))))
+  (put 'denom '(rational)
+       (lambda (x) (make-scheme-number (denom x))))
+  (put 'add '(rational rational)
+       (lambda (x y) (tag (add x y))))
+  (put 'sub '(rational rational)
+       (lambda (x y) (tag (sub x y))))
+  (put 'mul '(rational rational)
+       (lambda (x y) (tag (mul x y))))
+  (put 'div '(rational rational)
+       (lambda (x y) (tag (div x y))))
+
+  (put 'make 'rational
+       (lambda (n d) (tag (make n d))))
+  'done)
+
+(define (make-rational n d)
+  ((get 'make 'rational) n d))
+
+(install-rational-package)
+
+;; Rectangular Complex number package
+
+(define (install-rectangular-package)
+  ;; internal procedures 
+  (define (real-part z) (car z))
+  (define (imag-part z) (cdr z))
+  (define (make-from-real-imag x y) (cons x y))
+  (define (magnitude z)
+    (sqrt (+ (square (real-part z))
+             (square (imag-part z)))))
+  (define (angle z)
+    (atan (imag-part z) (real-part z)))
+  (define (make-from-mag-ang r a) 
+    (cons (* r (cos a)) (* r (sin a))))
+  ;; interface to the rest of the system
+  (define (tag x) (attach-tag 'rectangular x))
+  (put 'real-part '(rectangular) real-part)
+  (put 'imag-part '(rectangular) imag-part)
+  (put 'magnitude '(rectangular) magnitude)
+  (put 'angle     '(rectangular) angle)
+  (put 'make-from-real-imag 'rectangular 
+       (lambda (x y) (tag (make-from-real-imag x y))))
+  (put 'make-from-mag-ang 'rectangular 
+       (lambda (r a) (tag (make-from-mag-ang r a))))
+  'done)
+
+(define (make-from-real-imag x y)
+  ((get 'make-from-real-imag 'rectangular) x y))
+
+(install-rectangular-package)
+
+;; Polar Complex Package
+
+(define (install-polar-package)
+  ;; internal procedures
+  (define (magnitude z) (car z))
+  (define (angle z) (cdr z))
+  (define (make-from-mag-ang r a) (cons r a))
+  (define (real-part z)
+    (* (magnitude z) (cos (angle z))))
+  (define (imag-part z)
+    (* (magnitude z) (sin (angle z))))
+  (define (make-from-real-imag x y) 
+    (cons (sqrt (+ (square x) (square y)))
+          (atan y x)))
+  ;; interface to the rest of the system
+  (define (tag x) (attach-tag 'polar x))
+  (put 'real-part '(polar) real-part)
+  (put 'imag-part '(polar) imag-part)
+  (put 'magnitude '(polar) magnitude)
+  (put 'angle '(polar) angle)
+  (put 'make-from-real-imag 'polar
+       (lambda (x y) (tag (make-from-real-imag x y))))
+  (put 'make-from-mag-ang 'polar 
+       (lambda (r a) (tag (make-from-mag-ang r a))))
+  'done)
+
+(define (make-from-mag-ang r a)
+  ((get 'make-from-mag-ang 'polar) r a))
+
+(install-polar-package)
+
+;; Complex number package
+
+(define (install-complex-package)
+  ;; imported procedures from rectangular and polar packages
+  (define (make-from-real-imag x y)
+    ((get 'make-from-real-imag 'rectangular) x y))
+  (define (make-from-mag-ang r a)
+    ((get 'make-from-mag-ang 'polar) r a))
+  ;; internal procedures
+  (define (add z1 z2)
+    (make-from-real-imag (+ (real-part z1) (real-part z2))
+                         (+ (imag-part z1) (imag-part z2))))
+  (define (sub z1 z2)
+    (make-from-real-imag (- (real-part z1) (real-part z2))
+                         (- (imag-part z1) (imag-part z2))))
+  (define (mul z1 z2)
+    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+                       (+ (angle z1) (angle z2))))
+  (define (div z1 z2)
+    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+                       (- (angle z1) (angle z2))))
+  ;; interface to rest of the system
+  (define (tag z) (attach-tag 'complex z))
+  (put 'add '(complex complex)
+       (lambda (z1 z2) (tag (add z1 z2))))
+  (put 'sub '(complex complex)
+       (lambda (z1 z2) (tag (sub z1 z2))))
+  (put 'mul '(complex complex)
+       (lambda (z1 z2) (tag (mul z1 z2))))
+  (put 'div '(complex complex)
+       (lambda (z1 z2) (tag (div z1 z2))))
+  (put 'make-from-real-imag 'complex
+       (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))))
+  ;; Added for this exercise
+  (put 'real-part '(complex) real-part)
+  (put 'imag-part '(complex) imag-part)
+  (put 'magnitude '(complex) magnitude)
+  (put 'angle '(complex) angle)
+  'done)
+
+(define (make-complex-from-real-imag x y)
+  ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+  ((get 'make-from-mag-ang 'complex) r a))
+
+(install-complex-package)

scheme/week09/ex2_77_test.scm

@@ -0,0 +1,69 @@
+;; SICP Tests 2.77 -- put/get
+
+(test-case "Ex 2.77 -- put/get"
+           (put 'op '(t1 t2) 'value)
+           (assert-equal 'value (get 'op '(t1 t2) ))
+           (assert-false (get 'op '(tx) )))
+
+(test-case "Ex 2.77 -- Tagging"
+           (let ((data (attach-tag 'the-tag 'the-value)))
+             (assert-equal 'the-tag (type-tag data))
+             (assert-equal 'the-value (contents data))))
+
+(test-case "Ex 2.77 -- apply-generic"
+           (define (op v) (+ 1 v))
+           (put 'add1 '(t1) op)
+           (let ((ten (attach-tag 't1 10)))
+             (assert-equal 11 (apply-generic 'add1 ten))))
+
+(test-case "Ex 2.77 -- Scheme number package"
+           (let ((ten (make-scheme-number 10))
+                 (eleven (make-scheme-number 11)))
+             (assert-equal (make-scheme-number 21) (add ten eleven))))
+
+(test-case "Ex 2.77 -- Rational Numbers"
+           (let ((half (make-rational 1 2))
+                 (third (make-rational 1 3)))
+             (assert-equal (make-scheme-number 1) (numer half))
+             (assert-equal (make-scheme-number 2) (denom half))
+             (assert-equal (make-rational 5 6) (add half third))))
+
+(test-case "Ex 2.77 -- Rectangular Numbers"
+           (let ((x (make-from-real-imag 3 4)))
+             (assert-equal 3 (real-part x))
+             (assert-equal 4 (imag-part x))
+             (assert-equal 5 (magnitude x))
+             (assert-in-delta 0.927 (angle x) 0.01)))
+
+(test-case "Ex 2.77 -- Polar Numbers"
+           (let ((x (make-from-mag-ang 5 0.927)))
+             (assert-in-delta 3 (real-part x) 0.01)
+             (assert-in-delta 4 (imag-part x) 0.01)
+             (assert-in-delta 5 (magnitude x) 0.01)
+             (assert-in-delta 0.927 (angle x) 0.01)))
+
+(test-case "Ex 2.77 -- Complex/rectangular Numbers"
+           (let ((x (make-complex-from-real-imag 3 4)))
+             (assert-in-delta 3 (real-part x) 0.01)
+             (assert-in-delta 4 (imag-part x) 0.01)
+             (assert-in-delta 5 (magnitude x) 0.01)
+             (assert-in-delta 0.927 (angle x) 0.01)))
+
+(test-case "Ex 2.77 -- Complex/polar Numbers"
+           (let ((x (make-complex-from-mag-ang 5 0.927)))
+             (assert-in-delta 3 (real-part x) 0.01)
+             (assert-in-delta 4 (imag-part x) 0.01)
+             (assert-in-delta 5 (magnitude x) 0.01)
+             (assert-in-delta 0.927 (angle x) 0.01)))
+
+(test-case "Ex 2.77 -- Complex Number arithmetic 1"
+           (let ((x (make-complex-from-real-imag 3 4))
+                 (y (make-complex-from-real-imag 9 12)))
+             (assert-equal (make-complex-from-real-imag 12 16) (add x y))))
+
+(test-case "Ex 2.77 -- Complex Number arithmetic 2"
+           (let* ((x (make-complex-from-mag-ang 3 1))
+                  (y (make-complex-from-mag-ang 4 1))
+                  (result (add x y)))
+             (assert-in-delta 7 (magnitude result) 0.01)
+             (assert-in-delta 1 (angle result) 0.01)))