sicp-2-5-2-the-generic-arithmetic-program

#lang racket

;;;;;;;;;;;
;; NOTES ;;
;;;;;;;;;;;

;; The generic arithmetic program through exercise 2.86, using type coercion, type
;; simplification, and generic components for complex numbers.

;; Note that integers are represented as un-tagged Racket exact integers like 1,
;; and reals are represented as un-tagged Racket inexact numbers like 1.0.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OP, RAISE, AND PROJECT TABLES ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define op-table (make-hash))
(define (put op tag-list procedure) (hash-set! op-table (list op tag-list) procedure))
(define (can-apply? op tag-list) (member (list op tag-list) (hash-keys op-table)))
(define (get op tag-list) (hash-ref op-table (list op tag-list)))

(define project-table (make-hash))
(define (put-project type procedure) (hash-set! project-table type procedure))
(define (can-project? arg) (member (type-tag arg) (hash-keys project-table)))
(define (project arg) ((hash-ref project-table (type-tag arg)) arg))

(define raise-table (make-hash))
(define (put-raise type procedure) (hash-set! raise-table type procedure))
(define (can-raise? arg) (member (type-tag arg) (hash-keys raise-table)))
(define (raise arg) ((hash-ref raise-table (type-tag arg)) arg))

;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERIC OPERATIONS ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(define (attach-tag type-tag contents)
  (cond [(exact-integer? contents) contents]
        [(inexact-real? contents) contents]
        [else (list type-tag contents)]))

(define (type-tag datum)
  (cond [(exact-integer? datum) 'integer]
        [(inexact-real? datum) 'real]
        [(pair? datum) (first datum)]
        [else (error "bad tagged-datum -- TYPE-TAG" datum)]))

(define (contents datum)
  (cond [(exact-integer? datum) datum]
        [(inexact-real? datum) datum]
        [(pair? datum) (second datum)]
        [else (error "bad tagged datum -- CONTENTS" datum)]))

(define (simplify arg)
  (cond [(can-project? arg)
         (define projected-arg (project arg))
         (if (equ? arg (raise projected-arg))
           (simplify projected-arg)
           arg)]
        [else arg]))

(define (highest-type tag-list)
  ;; Raise 0 through all the types.  Keep the highest type found in tag-list.
  (define (loop type arg)
    (cond [(can-raise? arg)
           (define new-arg (raise arg))
           (define new-type (type-tag new-arg))
           (if (member new-type tag-list)
             (loop new-type new-arg)
             (loop type new-arg))]
          [else type]))
  (loop 'integer 0))

(define (coerce args target-type)
  (define (coerce-one arg)
    (if (eq? (type-tag arg) target-type)
      arg
      (coerce-one (raise arg))))
  (map coerce-one args))

(define (all-same? symbols)
  (or (< (length symbols) 2)
      (andmap (lambda (s) (eq? s (first symbols)))
              (rest symbols))))

(define (apply-generic op . args)
  (define type-tags (map type-tag args))
  (cond [(can-apply? op type-tags)
         (apply (get op type-tags) (map contents args))]
        [(not (all-same? type-tags))
         (define new-args (coerce args (highest-type type-tags)))
         (apply apply-generic (cons op new-args))]
        [else (error "no method for this op -- APPLY-GENERIC" op)]))

;; Only simplify the numerical operations and the complex selectors.
;; Do not simplify predicates or constructors.

;; arithmetic
(define (add x y) (simplify (apply-generic 'add x y)))
(define (sub x y) (simplify (apply-generic 'sub x y)))
(define (mul x y) (simplify (apply-generic 'mul x y)))
(define (div x y) (simplify (apply-generic 'div x y)))
;; predicates
(define (=zero? x) (apply-generic '=zero? x))
(define (equ? x y) (apply-generic 'equ? x y))
;; complex number selectors
(define (re-part z) (simplify (apply-generic 're-part z)))
(define (im-part z) (simplify (apply-generic 'im-part z)))
(define (mag-part z) (simplify (apply-generic 'mag-part z)))
(define (ang-part z) (simplify (apply-generic 'ang-part z)))
;; numerical operations needed for generic complex number components
(define (absolute x) (apply-generic 'absolute x))
(define (expo x y) (simplify (apply-generic 'expo x y)))
(define (arctan y x) (simplify (apply-generic 'arctan y x)))
(define (cosine x) (simplify (apply-generic 'cosine x)))
(define (sine x) (simplify (apply-generic 'sine x)))
(define (square x) (simplify (apply-generic 'square x)))
(define (square-root x) (simplify (apply-generic 'square-root x)))
;; constructors
(define (make-integer a) ((get 'make 'integer) a))
(define (make-rational n d) ((get 'make 'rational) n d))
(define (make-real x) ((get 'make 'real) x))
(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))

;; Note that we cannot simply define make-integer as (get 'make 'integer)
;; because that procedure has not been stored in the op-table yet.

;;;;;;;;;;;;;;
;; INTEGERS ;;
;;;;;;;;;;;;;;

(define (install-integer-package)
  ;; internal procedures
  (define (make-integer a)
    (define flr (floor a))
    (if (exact? flr) flr (inexact->exact flr)))
  (define (arctan-int b a) (make-real (atan b a)))
  (define (cosine-int a) (make-real (cos a)))
  (define (sine-int a) (make-real (sin a)))
  (define (square-root-int a) (make-real (sqrt a)))
  (define (raise-int datum)
    (define a (contents datum))
    (make-rational a 1))
  ;; interface to the rest of the system
  (put '=zero? '(integer) zero?)
  (put 'absolute '(integer) abs)
  (put 'add '(integer integer) +)
  (put 'arctan '(integer integer) arctan-int)
  (put 'cosine '(integer) cosine-int)
  (put 'div '(integer integer) make-rational)
  (put 'equ? '(integer integer) =)
  (put 'expo '(integer integer) expt)
  (put 'make 'integer make-integer)
  (put 'mul '(integer integer) *)
  (put 'sine '(integer) sine-int)
  (put 'square-root '(integer) square-root-int)
  (put 'square '(integer) sqr)
  (put 'sub '(integer integer) -)
  (put-raise 'integer raise-int)
  'done-installing-integers)
(install-integer-package)

;;;;;;;;;;;;;;;;;;;;;;
;; RATIONAL NUMBERS ;;
;;;;;;;;;;;;;;;;;;;;;;

(define (install-rational-package)
  ;; internal procedures
  (define (make-rat n d)
    (let ([g (gcd n d)])
      (list (make-integer (/ n g)) (make-integer (/ d g)))))
  (define (numer x) (first x))
  (define (denom x) (second x))
  (define (=zero-rat? x) (zero? (numer x)))
  (define (equ-rat? x y)
    (= (* (numer x) (denom y))
       (* (denom x) (numer y))))
  (define (absolute-rat x) (make-real (abs (/ (numer x) (denom x)))))
  (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 (expo-rat x y) (make-real (expt (/ (* (numer x) 1.0) (denom x))
                                          (/ (* (numer y) 1.0) (denom y)))))
  (define (arctan-rat y x) (make-real (atan (/ (numer y) (denom y))
                                            (/ (numer x) (denom x)))))
  (define (cosine-rat x) (make-real (cos (/ (numer x) (denom x)))))
  (define (sine-rat x) (make-real (sin (/ (numer x) (denom x)))))
  (define (square-root-rat x) (make-real (sqrt (/ (numer x) (denom x)))))
  (define (square-rat x) (make-rat (sqr (numer x)) (sqr (denom x))))
  (define (project-rat datum)
    (define x (contents datum))
    (make-integer (floor (/ (numer x) (denom x)))))
  (define (raise-rat datum)
    (define x (contents datum))
    (make-real (/ (numer x) (denom x))))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'make 'rational (compose tag make-rat))
  (put '=zero? '(rational) =zero-rat?)
  (put 'equ? '(rational rational) equ-rat?)
  (put 'absolute '(rational) absolute-rat)
  (put 'add '(rational rational) (compose tag add-rat))
  (put 'sub '(rational rational) (compose tag sub-rat))
  (put 'mul '(rational rational) (compose tag mul-rat))
  (put 'div '(rational rational) (compose tag div-rat))
  (put 'expo '(rational rational) expo-rat)
  (put 'arctan '(rational rational) arctan-rat)
  (put 'cosine '(rational) cosine-rat)
  (put 'sine '(rational) sine-rat)
  (put 'square-root '(rational) square-root-rat)
  (put 'square '(rational) (compose tag square-rat))
  (put-project 'rational project-rat)
  (put-raise 'rational raise-rat)
  'done-installing-rationals)
(install-rational-package)

;;;;;;;;;;;;;;;;;;
;; REAL NUMBERS ;;
;;;;;;;;;;;;;;;;;;

(define (install-real-package)
  ;; internal procedures
  (define (make-real x) (if (inexact? x) x (exact->inexact x)))
  (define (project-real datum)
    (define x (contents datum))
    (make-rational (floor (* x 1000000)) 1000000))
  (define (raise-real datum)
    (define x (contents datum))
    (make-complex-from-real-imag x 0))
  ;; interface to the rest of the system
  (put '=zero? '(real) zero?)
  (put 'absolute '(real) abs)
  (put 'add '(real real) +)
  (put 'arctan '(real real) atan)
  (put 'cosine '(real) cos)
  (put 'div '(real real) /)
  (put 'equ? '(real real) =)
  (put 'expo '(real real) expt)
  (put 'make 'real make-real)
  (put 'mul '(real real) *)
  (put 'sine '(real) sin)
  (put 'square-root '(real) sqrt)
  (put 'square '(real) sqr)
  (put 'sub '(real real) -)
  (put-project 'real project-real)
  (put-raise 'real raise-real)
  'done-installing-reals)
(install-real-package)

;;;;;;;;;;;;;;;;;;;;;
;; COMPLEX NUMBERS ;;
;;;;;;;;;;;;;;;;;;;;;

(define (install-complex-package)

  ;;; rectangular complex numbers
  (define (install-rectangular-package)
    ;; internal procedures
    (define (make-from-real-imag-rect x y) (list x y))
    (define (re-part-rect z) (first z))
    (define (im-part-rect z) (second z))
    (define (make-from-mag-ang-rect r a)
      (list (mul r (cosine a))
            (mul r (sine a))))
    (define (mag-part-rect z)
      (square-root (add (square (re-part-rect z))
                        (square (im-part-rect z)))))
    (define (ang-part-rect z)
      (arctan (im-part-rect z) (re-part-rect z)))
    ;; interface to the rest of the system
    (define (tag z) (attach-tag 'rectangular z))
    (put 're-part '(rectangular) re-part-rect)
    (put 'im-part '(rectangular) im-part-rect)
    (put 'mag-part '(rectangular) mag-part-rect)
    (put 'ang-part '(rectangular) ang-part-rect)
    (put 'make-from-real-imag 'rectangular (compose tag make-from-real-imag-rect))
    (put 'make-from-mag-ang 'rectangular (compose tag make-from-mag-ang-rect))
    'done)
  (install-rectangular-package)

  ;;; polar complex numbers
  (define (install-polar-package)
    ;; internal procedures
    (define (make-from-mag-ang-polar r a) (list r a))
    (define (mag-part-polar z) (first z))
    (define (ang-part-polar z) (second z))
    (define (make-from-real-imag-polar x y)
      (list (square-root (add (square x) (square y)))
            (arctan y x)))
    (define (re-part-polar z)
      (mul (mag-part-polar z) (cosine (ang-part-polar z))))
    (define (im-part-polar z)
      (mul (mag-part-polar z) (sine (ang-part-polar z))))
    ;; interface to the rest of the system
    (define (tag x) (attach-tag 'polar x))
    (put 're-part '(polar) re-part-polar)
    (put 'im-part '(polar) im-part-polar)
    (put 'mag-part '(polar) mag-part-polar)
    (put 'ang-part '(polar) ang-part-polar)
    (put 'make-from-real-imag 'polar (compose tag make-from-real-imag-polar))
    (put 'make-from-mag-ang 'polar (compose tag make-from-mag-ang-polar))
    'done)
  (install-polar-package)

  ;;; generic complex numbers
  ;; internal procedures
  ; constructors
  (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))
  ; predicates
  (define (equ-complex? z1 z2)
    (and (< (absolute (sub (re-part z1) (re-part z2))) 0.000001)
         (< (absolute (sub (im-part z1) (im-part z2))) 0.000001)))
  (define (=zero-complex? z)
    (or (=zero? (mag-part z))
        (and (< (absolute (re-part z)) 0.000001)
             (< (absolute (im-part z)) 0.000001))))
  ; arithmetic
  (define (add-complex z1 z2)
    (make-from-real-imag (add (re-part z1) (re-part z2))
                         (add (im-part z1) (im-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (re-part z1) (re-part z2))
                         (sub (im-part z1) (im-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (mag-part z1) (mag-part z2))
                       (add (ang-part z1) (ang-part z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (mag-part z1) (mag-part z2))
                       (sub (ang-part z1) (ang-part z2))))
  (define (expo-complex z1 z2)
    (define w (expt (+ (make-real (re-part z1))
                       (* (make-real (im-part z1)) 0+i))
                    (+ (make-real (re-part z2))
                       (* (make-real (im-part z2)) 0+i))))
    (make-from-real-imag (real-part w) (imag-part w)))
  (define (project-complex datum)
    (define z (contents datum))
    (make-real (re-part z)))
  ;; interface to the rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'make-from-real-imag 'complex (compose tag make-from-real-imag))
  (put 'make-from-mag-ang 'complex (compose tag make-from-mag-ang))
  (put '=zero? '(complex) =zero-complex?)
  (put 'equ? '(complex complex) equ-complex?)
  (put 're-part '(complex) re-part)
  (put 'im-part '(complex) im-part)
  (put 'mag-part '(complex) mag-part)
  (put 'ang-part '(complex) ang-part)
  (put 'add '(complex complex) (compose tag add-complex))
  (put 'sub '(complex complex) (compose tag sub-complex))
  (put 'mul '(complex complex) (compose tag mul-complex))
  (put 'div '(complex complex) (compose tag div-complex))
  (put 'expo '(complex complex) (compose tag expo-complex))
  (put-project 'complex project-complex)
  'done-installing-complex-numbers)
(install-complex-package)

;;;;;;;;;;;
;; TESTS ;;
;;;;;;;;;;;

(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 4)))
(sub z1 z2)
;; '(complex (rectangular (4 4)))
(mul z1 z2)
;; '(complex (polar (5 4.068887871591405)))
(div z1 z2)
;; '(complex (polar (5 -2.214297435588181)))

(define w (make-complex-from-real-imag 0.5 (make-rational 3 4)))
(re-part w)
;; '(rational (1 2))
(im-part w)
;; '(rational (3 4))
(=zero? (sub w (make-complex-from-real-imag (make-rational 1 2) 0.75)))
;; #t