sicp: section 2.4

sicp/2/4/1.scm

+(define (t)
+  (let ((x (make-from-real-imag 3 4))
+        (y (make-from-mag-ang 3 4)))
+    (display x)
+    (newline)
+    (display (magnitude x))
+    (newline)
+    (display y)
+    (newline)
+    (display (magnitude y))
+    (newline)))
+
+(define (add-complex z1 z2)
+  (make-from-real-imag (+ (real-part z1) (real-part z2))
+                       (+ (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))))
+(define (mul-complex z1 z2)
+  (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+                     (+ (angle z1) (angle z2))))
+(define (div-complex z1 z2)
+  (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+                     (- (angle z1) (angle z2))))
+
+(define (real-part z) (car z))
+(define (imag-part z) (cdr z))
+(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-real-imag x y) (cons x y))
+(define (make-from-mag-ang r a)
+  (cons (* r (cos a)) (* r (sin a))))
+
+(t)
+
+(define (real-part z)
+  (* (magnitude z) (cos (angle z))))
+(define (imag-part z)
+  (* (magnitude z) (sin (angle z))))
+(define (magnitude z) (car z))
+(define (angle z) (cdr z))
+(define (make-from-real-imag x y)
+  (cons (sqrt (+ (square x) (square y)))
+        (atan y x)))
+(define (make-from-mag-ang r a) (cons r a))
+
+(t)

sicp/2/4/2.scm

+(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)))
+
+(define (rectangular? z)
+  (eq? (type-tag z) 'rectangular))
+(define (polar? z)
+  (eq? (type-tag z) 'polar))
+
+(define (real-part-rectangular z) (car z))
+(define (imag-part-rectangular z) (cdr z))
+(define (magnitude-rectangular z)
+  (sqrt (+ (square (real-part-rectangular z))
+           (square (imag-part-rectangular z)))))
+(define (angle-rectangular z)
+  (atan (imag-part-rectangular z)
+        (real-part-rectangular z)))
+(define (make-from-real-imag-rectangular x y)
+  (attach-tag 'rectangular (cons x y)))
+(define (make-from-mag-ang-rectangular r a)
+  (attach-tag 'rectangular
+              (cons (* r (cos a)) (* r (sin a)))))
+
+(define (real-part-polar z)
+  (* (magnitude-polar z) (cos (angle-polar z))))
+(define (imag-part-polar z)
+  (* (magnitude-polar z) (sin (angle-polar z))))
+(define (magnitude-polar z) (car z))
+(define (angle-polar z) (cdr z))
+(define (make-from-real-imag-polar x y)
+  (attach-tag 'polar
+              (cons (sqrt (+ (square x) (square y)))
+                    (atan y x))))
+(define (make-from-mag-ang-polar r a)
+  (attach-tag 'polar
+              (cons r a)))
+
+(define (real-part z)
+  (cond ((rectangular? z)
+         (real-part-rectangular (contents z)))
+        ((polar? z)
+         (real-part-polar (contents z)))
+        (else (error "Unknown type -- REAL-PART" z))))
+(define (imag-part z)
+  (cond ((rectangular? z)
+         (imag-part-rectangular (contents z)))
+        ((polar? z)
+         (imag-part-polar (contents z)))
+        (else (error "Unknown type -- IMAG-PART" z))))
+(define (magnitude z)
+  (cond ((rectangular? z)
+         (magnitude-rectangular (contents z)))
+        ((polar? z)
+         (magnitude-polar (contents z)))
+        (else (error "Unknown type -- MAGNITUDE" z))))
+(define (angle z)
+  (cond ((rectangular? z)
+         (angle-rectangular (contents z)))
+        ((polar? z)
+         (angle-polar (contents z)))
+        (else (error "Unknown type -- ANGLE" z))))
+
+(define (add-complex z1 z2)
+  (make-from-real-imag (+ (real-part z1) (real-part z2))
+                       (+ (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))))
+(define (mul-complex z1 z2)
+  (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+                     (+ (angle z1) (angle z2))))
+(define (div-complex z1 z2)
+  (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+                     (- (angle z1) (angle z2))))
+
+(define (make-from-real-imag x y)
+  (make-from-real-imag-rectangular x y))
+(define (make-from-mag-ang r a)
+  (make-from-mag-ang-polar r a))
+
+(let ((x (make-from-real-imag 3 4))
+      (y (make-from-mag-ang 3 4)))
+  (display x)
+  (newline)
+  (display (magnitude x))
+  (newline)
+  (display y)
+  (newline)
+  (display (magnitude y))
+  (newline))

sicp/2/4/3.scm

+(define (list-eq? x y)
+  (cond
+    ((null? x) (null? y))
+    ((null? y) (null? x))
+    ((not (eq? (car x) (car y))) #f)
+    (else (list-eq? (cdr x) (cdr y)))))
+
+(define (get dispatch-table op type-tags)
+  (if (null? dispatch-table)
+    #f
+    (let ((x (car dispatch-table)))
+      (if (and
+            (eq? (car x) op)
+            (if (pair? type-tags)
+              (list-eq? (cadr x) type-tags)
+              (eq? (cadr x) type-tags)))
+        (caddr x)
+        (get (cdr dispatch-table) 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)))
+
+(define (install-rectangular-package dispatch-table)
+  ;; 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))
+  (append
+    dispatch-table
+    (list
+      (list 'real-part '(rectangular) real-part)
+      (list 'imag-part '(rectangular) imag-part)
+      (list 'magnitude '(rectangular) magnitude)
+      (list 'angle '(rectangular) angle)
+      (list 'make-from-real-imag 'rectangular
+           (lambda (x y) (tag (make-from-real-imag x y))))
+      (list 'make-from-mag-ang 'rectangular
+           (lambda (r a) (tag (make-from-mag-ang r a)))))))
+
+(define (install-polar-package dispatch-table)
+  ;; 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 x y)))
+  ;; interface to the rest of the system
+  (define (tag x) (attach-tag 'polar x))
+  (append
+    dispatch-table
+    (list
+      (list 'real-part '(polar) real-part)
+      (list 'imag-part '(polar) imag-part)
+      (list 'magnitude '(polar) magnitude)
+      (list 'angle '(polar) angle)
+      (list 'make-from-real-imag 'polar
+           (lambda (x y) (tag (make-from-real-imag x y))))
+      (list 'make-from-mag-ang 'polar
+           (lambda (r a) (tag (make-from-mag-ang r a)))))))
+
+(define (apply-generic dispatch-table op . args)
+  (let ((type-tags (map type-tag args)))
+    (let ((proc (get dispatch-table op type-tags)))
+      (if proc
+        (apply proc (map contents args))
+        (error
+          "No method for these types -- APPLY-GENERIC"
+          (list op type-tags))))))
+
+(define (real-part dispatch-table z)
+  (apply-generic dispatch-table 'real-part z))
+(define (imag-part dispatch-table z)
+  (apply-generic dispatch-table 'imag-part z))
+(define (magnitude dispatch-table z)
+  (apply-generic dispatch-table 'magnitude z))
+(define (angle dispatch-table z)
+  (apply-generic dispatch-table 'angle z))
+
+(define (make-from-real-imag dispatch-table x y)
+  ((get dispatch-table 'make-from-real-imag 'rectangular) x y))
+(define (make-from-mag-ang dispatch-table r a)
+  ((get dispatch-table 'make-from-mag-ang 'polar) r a))
+
+(define (t dispatch-table)
+  (let ((x (make-from-real-imag dispatch-table 3 4))
+        (y (make-from-mag-ang dispatch-table 3 4)))
+    (display x)
+    (newline)
+    (display (real-part dispatch-table x))
+    (newline)
+    (display (magnitude dispatch-table x))
+    (newline)
+    (display y)
+    (newline)
+    (display (real-part dispatch-table y))
+    (newline)
+    (display (magnitude dispatch-table y))
+    (newline)))
+
+(let
+  ((dispatch-table (install-rectangular-package '())))
+  (let ((dispatch-table (install-polar-package dispatch-table)))
+    (t dispatch-table)))
+
+(define (make-from-real-imag x y)
+  (define (dispatch op)
+    (cond
+      ((eq? op 'real-part) x)
+      ((eq? op 'imag-part) y)
+      ((eq? op 'magnitude)
+       (sqrt (+ (square x) (square y))))
+      ((eq? op 'angle) (atan y x))
+      (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+  dispatch)
+(define (apply-generic op arg) (arg op))
+(define (real-part z) (apply-generic 'real-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+
+(newline)
+(let ((x (make-from-real-imag 3 4)))
+  (display x)
+  (newline)
+  (display (real-part x))
+  (newline)
+  (display (magnitude x))
+  (newline))

sicp/2/4/ex_73.scm

+(define (variable? e) (symbol? e))
+(define (same-variable? v1 v2)
+  (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (addend e) (cadr e))
+(define (augend e) (caddr e))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (multiplier e) (cadr e))
+(define (multiplicand e) (caddr e))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (base e) (cadr e))
+(define (exponent e) (caddr e))
+(define (make-exponentiation b e) (list '** b e))
+
+(define (get dispatch-table op type-tags)
+  (if (null? dispatch-table)
+    #f
+    (let ((x (car dispatch-table)))
+      (if (and
+            (eq? (car x) op)
+            (eq? (cadr x) type-tags))
+        (caddr x)
+        (get (cdr dispatch-table) op type-tags)))))
+
+(define (deriv-sum dispatch-table exp var)
+  (make-sum (deriv dispatch-table (addend exp) var)
+            (deriv dispatch-table (augend exp) var)))
+(define (deriv-product dispatch-table exp var)
+  (make-sum
+    (make-product (multiplier exp)
+                  (deriv dispatch-table (multiplicand exp) var))
+    (make-product (deriv dispatch-table (multiplier exp) var)
+                  (multiplicand exp))))
+(define (deriv-exponentiation dispatch-table exp var)
+  (make-product
+    (make-product
+      (exponent exp)
+      (make-exponentiation
+        (base exp)
+        (make-sum (exponent exp) '-1)))
+    (deriv dispatch-table (base exp) var)))
+
+(define (install-deriv-package dispatch-table)
+  (append
+    dispatch-table
+    (list
+      (list 'deriv '+ deriv-sum)
+      (list 'deriv '* deriv-product)
+      (list 'deriv '** deriv-exponentiation))))
+
+(define (deriv dispatch-table exp var)
+  (cond
+    ((number? exp) 0)
+    ((variable? exp) (if (same-variable? exp var) 1 0))
+    (else
+      (let ((proc (get dispatch-table 'deriv (operator exp))))
+        (if proc
+          (proc dispatch-table exp var)
+          (error "No method for these types -- DERIV" exp var))))))
+
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+(define (t dispatch-table)
+  (define (deriv2 exp args) (deriv dispatch-table exp args))
+  (display (deriv2 '(+ x 3) 'x))
+  (newline)
+  (display (deriv2 '(* x y) 'x))
+  (newline)
+  (display (deriv2 '(* (* x y) (+ x 3)) 'x))
+  (newline)
+  (display (deriv2 '(** (+ x 2) 3) 'x))
+  (newline))
+
+(define dispatch-table (install-deriv-package '()))
+(t dispatch-table)
+
+(define (make-sum a1 a2)
+  (cond ((=number? a1 0) a2)
+        ((=number? a1 0) a1)
+        ((and (number? a1) (number? a1)) (+ a1 a2))
+        (else (list '+ a1 a2))))
+
+(define (make-product m1 m2)
+  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+        ((=number? m1 1) m2)
+        ((=number? m2 1) m1)
+        ((and (number? m1) (number? m2)) (* m1 m2))
+        (else (list '* m1 m2))))
+
+(define (make-exponentiation b e)
+  (cond ((=number? e 0) 1)
+        ((and (number? b) (number? e)) (expt b e))
+        (else (list '** b e))))
+
+(define (=number? exp num)
+  (and (number? exp) (= exp num)))
+
+(newline)
+(t dispatch-table)
+
+(define (deriv dispatch-table exp var)
+  (cond
+    ((number? exp) 0)
+    ((variable? exp) (if (same-variable? exp var) 1 0))
+    (else
+      (let ((proc (get dispatch-table (operator exp) 'deriv)))
+        (if proc
+          (proc dispatch-table exp var)
+          (error "No method for these types -- DERIV" exp var))))))
+
+(define (install-deriv-package dispatch-table)
+  (append
+    dispatch-table
+    (list
+      (list '+ 'deriv deriv-sum)
+      (list '* 'deriv deriv-product)
+      (list '** 'deriv deriv-exponentiation))))
+
+(newline)
+(t (install-deriv-package '()))

sicp/2/4/ex_74.scm

+(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)))
+(define (get dispatch-table op type-tags)
+  (if (null? dispatch-table)
+    #f
+    (let ((x (car dispatch-table)))
+      (if (and
+            (eq? (car x) op)
+            (eq? (cadr x) type-tags))
+        (caddr x)
+        (get (cdr dispatch-table) op type-tags)))))
+
+(define (get-record file division name)
+  (if (null? file)
+    #f
+    (let ((x (car file)))
+      (if (equal? name (car x))
+        (attach-tag division x)
+        (get-record (cdr file) division name)))))
+
+; name age occupation salary
+(define file-a
+  (list
+    (list "Bob" 25 "programmer" 20)))
+
+; name occupation_code 100-salary birth_timestamp
+(define file-b
+  (list
+    (list "Jennifer" 5 60 94668401)
+    (list "Billy" 1 78 946684800)))
+
+(display (get-record file-a 'division-a "Billy"))
+(newline)
+(display (get-record file-a 'division-a "Bob"))
+(newline)
+(display (get-record file-b 'division-b "Billy"))
+(newline)
+(display (get-record file-b 'division-b "Bob"))
+(newline)
+
+(define (get-salary dispatch-table record)
+  ((get dispatch-table 'get-salary (type-tag record)) (contents record)))
+
+(define (install-insatiable-package dispatch-table)
+  (define (get-salary-division-a record) (cadddr record))
+  (define (get-salary-division-b record) (- 100 (caddr record)))
+  (append
+    dispatch-table
+    (list
+      (list 'get-salary 'division-a get-salary-division-a)
+      (list 'get-salary 'division-b get-salary-division-b))))
+
+(define dispatch-table (install-insatiable-package '()))
+
+(newline)
+(display (get-salary dispatch-table (get-record file-a 'division-a "Bob")))
+(newline)
+(display (get-salary dispatch-table (get-record file-b 'division-b "Billy")))
+(newline)
+
+(define (find-employee-record files name)
+  (if (null? files)
+    #f
+    (let ((division (caar files))
+          (records (cadar files)))
+      (let ((record (get-record records division name)))
+        (if record
+          record
+          (find-employee-record (cdr files) name))))))
+
+(define files
+  (list
+    (list 'division-a file-a)
+    (list 'division-b file-b)))
+
+(newline)
+(display (get-salary dispatch-table (find-employee-record files "Bob")))
+(newline)
+(display (get-salary dispatch-table (find-employee-record files "Billy")))
+(newline))

sicp/2/4/ex_75.scm

+(define (make-from-mag-ang r a)
+  (define (dispatch op)
+    (cond
+      ((eq? op 'real-part) (* r (cos a)))
+      ((eq? op 'imag-part) (* r (sin a)))
+      ((eq? op 'magnitude) r)
+      ((eq? op 'angle) a)
+      (else (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
+  dispatch)
+(define (apply-generic op arg) (arg op))
+(define (real-part z) (apply-generic 'real-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+
+
+(newline)
+(let ((x (make-from-mag-ang 3 4)))
+  (display x)
+  (newline)
+  (display (real-part x))
+  (newline)
+  (display (magnitude x))
+  (newline))