sicp-2-5-1-generic-arithmetic-operations

#lang racket

;;; op table

(define op-table (make-hash))
(define (put op type item)
  (hash-set! op-table (list op type) item))
(define (get op type)
  (hash-ref op-table (list op type)))

;; I'm going to use lists instead of dotted pairs.

;;; generic operations

(define (attach-tag type-tag contents)
  (list type-tag contents))
(define (type-tag datum)
  (if (list? datum)
    (first datum)
    (error "bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
  (if (list? datum)
    (second datum)
    (error "bad tagged datum -- CONTENTS" datum)))
(define (apply-generic op . args)
  (define type-tags (map type-tag args))
  (define 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 (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 (equ? x y) (apply-generic 'equ x y))
(define (=zero? x) (apply-generic '=zero x))
(define (re-part z) (apply-generic 're-part z))
(define (im-part z) (apply-generic 'im-part z))
(define (mag-part z) (apply-generic 'mag-part z))
(define (ang-part z) (apply-generic 'ang-part z))

;;; constructors

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))
(define (make-rational n d)
  ((get 'make 'rational) n d))
(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))

;;; scheme numbers

(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)))
  (put 'equ '(scheme-number scheme-number)
       =)
  (put '=zero '(scheme-number)
       zero?)
  'done)
(install-scheme-number-package)

;;; rational numbers

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (first x))
  (define (denom x) (second x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (list (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  (define (equ? x y)
    (= (* (numer x) (denom y))
       (* (denom x) (numer y))))
  (define (=zero? x) (= (numer x) 0))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'equ '(rational rational)
       (lambda (x y) (equ? x y)))
  (put '=zero '(rational)
       (lambda (x) (=zero? x)))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)
(install-rational-package)

;;; complex rectangular numbers

(define (install-rectangular-package)
  ;; internal procedures
  (define (re-part z) (first z))
  (define (im-part z) (second z))
  (define (make-from-real-imag x y) (list x y))
  (define (mag-part z)
    (sqrt (+ (sqr (re-part z))
             (sqr (im-part z)))))
  (define (ang-part z)
    (atan (im-part z) (re-part z)))
  (define (make-from-mag-ang r a)
    (list (* r (cos a)) (* r (sin a))))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'rectangular x))
  (put 're-part '(rectangular) re-part)
  (put 'im-part '(rectangular) im-part)
  (put 'mag-part '(rectangular) mag-part)
  (put 'ang-part '(rectangular) ang-part)
  (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)
(install-rectangular-package)

;;; complex polar numbers

(define (install-polar-package)
  ;; internal procedures
  (define (mag-part z) (first z))
  (define (ang-part z) (second z))
  (define (make-from-mag-ang r a) (list r a))
  (define (re-part z)
    (* (mag-part z) (cos (ang-part z))))
  (define (im-part z)
    (* (mag-part z) (sin (ang-part z))))
  (define (make-from-real-imag x y)
    (list (sqrt (+ (sqr x) (sqr y)))
          (atan y x)))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'polar x))
  (put 're-part '(polar) re-part)
  (put 'im-part '(polar) im-part)
  (put 'mag-part '(polar) mag-part)
  (put 'ang-part '(polar) ang-part)
  (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)
(install-polar-package)

;;; generic complex numbers

(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-complex z1 z2)
    (make-from-real-imag (+ (re-part z1) (re-part z2))
                         (+ (im-part z1) (im-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (re-part z1) (re-part z2))
                         (- (im-part z1) (im-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (mag-part z1) (mag-part z2))
                       (+ (ang-part z1) (ang-part z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (mag-part z1) (mag-part z2))
                       (- (ang-part z1) (ang-part z2))))
  (define (equ? z1 z2)
    ; account for round-off error
    (and
      (< (abs (- (re-part z1) (re-part z2))) 0.0001)
      (< (abs (- (im-part z1) (im-part z2))) 0.0001)))
  (define (=zero? z)
    (or (= (mag-part z) 0)
        ; account for round-off error
        (and (< (abs (re-part z)) 0.0001)
             (< (abs (im-part z)) 0.0001))))
  ;; interface to the rest of the system
  (put 're-part '(complex) re-part)
  (put 'im-part '(complex) im-part)
  (put 'mag-part '(complex) mag-part)
  (put 'ang-part '(complex) ang-part)
  (define (tag z) (attach-tag 'complex z))
  (put 'equ '(complex complex)
       (lambda (z1 z2) (equ? z1 z2)))
  (put '=zero '(complex)
       (lambda (z) (=zero? z)))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex 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))))
  'done)
(install-complex-package)

(define q1 (make-rational 1 2))
(define q2 (make-rational 3 4))
(add q1 q2)
;; '(rational (5 4))
(sub q1 q2)
;; '(rational (-1 4))
(mul q1 q2)
;; '(rational (3 8))
(div q1 q2)
;; '(rational (2 3))

(define z1 (make-complex-from-real-imag 3 4))
(define z2 (make-complex-from-mag-ang 1 pi))
(add z1 z2)
;; '(complex (rectangular (2.0 4.0)))
(sub z1 z2)
;; '(complex (rectangular (4.0 4.0)))
(mul z1 z2)
;; '(complex (polar (5 4.068887871591405)))
(div z1 z2)
;; '(complex (polar (5 -2.214297435588181)))

;;;;;;;;;;
;; 2.77 ;;
;;;;;;;;;;

;; I'm using mag-part for magnitude so as not to conflict with the built-in racket
;; magnitude function.  To be consistent I'll also use ang-part instead of angle.

(define z '(complex (rectangular (3 4))))

;; without the added lines

;; (mag-part z)
;; ;; hash-ref: no value found for key
  ;; ;; key: '(mag-part (complex))

;; with the added lines

(mag-part z)
;; 5

;; In evaluating (mag-part z), apply-generic is called twice.  The first call
;; strips off the 'complex tag and dispatches to the generic mag-part again.  This
;; is because of the lines we added to the complex package.  The second call
;; strips off the 'rectangular tag and dispatches the mag-part procedure defined
;; in the rectangular package.

;; the manual trace

;; recall that (apply-generic op . args)
;; is (apply proc (map contents args))
;; where proc is (get op (map type-tag args))

;; (mag-part z)
;; (mag-part '(complex (rectangular (3 4))))
;; (apply-generic 'mag-part '(complex (rectangular (3 4))))
;; ;; this first call to apply-generic strips off the 'complex tag
;; (apply (get 'mag-part 'complex) '(rectangular (3 4)))
;; ;; the lines we added to the complex package say to use
;; ;; the generic mag-part again for (get 'mag-part 'complex)
;; (mag-part '(rectangular (3 4)))
;; (apply-generic 'mag-part '(rectangular (3 4)))
;; ;; this second call to apply-generic strips off the 'rectangular tag
;; ;; and uses the mag-part function defined in the complex rectangular package
;; (apply (get 'mag-part 'rectangular) '(3 4))
;; (apply (lambda (z) (sqrt (+ (sqr (re-part z)) (sqr (im-part z))))) '(3 4))
;; (sqrt (+ (sqr 3) (sqr 4)))
;; 5

;;;;;;;;;;
;; 2.78 ;;
;;;;;;;;;;

;; (define (attach-tag type-tag contents)
  ;; (if (number? contents)
    ;; contents
    ;; (list type-tag contents)))

;; (define (type-tag datum)
  ;; (cond [(number? datum) 'scheme-number]
        ;; [(list? datum) (first datum)]
        ;; [else (error "bad tagged datum -- TYPE-TAG" datum)]))

;; (define (contents datum)
  ;; (cond [(number? datum) datum]
        ;; [(list? datum) (second datum)]
        ;; [else (error "bad tagged datum -- CONTENTS" datum)]))

;;;;;;;;;;
;; 2.79 ;;
;;;;;;;;;;

;; Here is the code that was added above to implement equ?:

;; (define (equ? x y) (apply-generic 'equ x y))
;; ;; inside the scheme number package
;; (put 'equ '(scheme-number scheme-number)
     ;; =)
;; ;; inside the rational number package
;; (define (equ? x y)
  ;; (= (* (numer x) (denom y))
     ;; (* (denom x) (numer y))))
;; (put 'equ '(rational rational)
     ;; (lambda (x y) (equ? x y)))
;; ;; inside the generic complex number package
;; (define (equ? z1 z2)
  ;; ; account for round-off error
  ;; (and
    ;; (< (abs (- (re-part z1) (re-part z2))) 0.0001)
    ;; (< (abs (- (im-part z1) (im-part z2))) 0.0001)))
;; (put 'equ '(complex complex)
     ;; (lambda (z1 z2) (equ? z1 z2)))

(equ? (make-scheme-number 1)
      (make-scheme-number 1))
;; #t
(equ? (make-scheme-number 2)
      (make-scheme-number 3))
;; #f
(equ? (make-rational 1 2) (make-rational 3 6))
;; #t
(equ? (make-rational 1 2) (make-rational 2 3))
;; #f
(equ? (make-complex-from-real-imag -1 0)
      (make-complex-from-mag-ang 1 pi))
;; #t
(equ? (make-complex-from-real-imag 3 4)
      (make-complex-from-mag-ang 3 4))
;; #f

;;;;;;;;;;
;; 2.80 ;;
;;;;;;;;;;

;; Here is the code that was added above to implement =zero?:

;; (define (=zero? x) (apply-generic '=zero x))
;; ;; inside the scheme number package
;; (put '=zero '(scheme-number)
     ;; zero?)
;; ;; inside the rational number package
;; (define (=zero? x) (= (numer x) 0))
;; (put '=zero '(rational)
     ;; (lambda (x) (=zero? x)))
;; ;; inside the generic complex numbers package
;; (define (=zero? z)
  ;; (or (= (mag-part z) 0)
      ;; ; account for round-off error
      ;; (and (< (abs (re-part z)) 0.0001)
           ;; (< (abs (im-part z)) 0.0001))))
;; (put '=zero '(complex)
     ;; (lambda (z) (=zero? z)))

(=zero? (make-scheme-number 0))
;; #t
(=zero? (make-scheme-number 2))
;; #f
(=zero? (sub (make-rational 1 2)
             (make-rational 5 10)))
;; #t
(=zero? (sub (make-complex-from-real-imag 1 0)
             (make-complex-from-mag-ang 1 pi)))
;; #f
(=zero? (sub (make-complex-from-real-imag -1 0)
             (make-complex-from-mag-ang 1 pi)))
;; #t