my attempt to do the exercises in sicp.

Monday, August 17, 2009

sicp exercise 2.87 2.88 2.89 2.90 2.91




;; Exercise 2.87.  Install =zero? for polynomials in the generic arithmetic package. This will allow adjoin-term to work for polynomials with coefficients that are themselves polynomials.



(define (square x) (mul x x))
(define *op-table* (make-hash-table 10))
(define (put op type proc)
  (hash-set! *op-table* (list op type) proc))
(define (get op type)
  (hash-ref *op-table* (list op type) '()))

(define (get-highest-type args)
  (define (higher-type? num1-raised num2 num1)
    (let ((type1 (type num1-raised))
          (type2 (type num2)))
      (if (eq? type1 type2)
          num2
          (let ((raise-proc (get 'raise (list type1))))
            (if (null? raise-proc)
                num1
                (higher-type? (raise-proc (contents num1-raised)) num2 num1))))))
  (define (iter num rest-num)
    (cond ((null? rest-num) num)
          (else (iter (higher-type? num (car rest-num) num)
                      (cdr rest-num)))))
  (cond ((null? args) (error "ERROR"))
        ((null? (cdr args)) (car args))
        (else (type (iter (car args) (cdr args))))))

(define (raise-args highest-type args)
  (define (raise-to-type num)
    (if (eq? (type num) highest-type)
        num
        (raise-to-type (raise num))))
  (map raise-to-type args))

(define (apply-generic op . param)
  (define (apply-generic-raised)
    (let ((highest-type (get-highest-type param)))
      (let ((highest-type-args (map (lambda(x) highest-type) param)))
        (let ((proc (get op highest-type-args)))
          (if (null? proc) (error "no matching operation" op  "for types"
                                   highest-type-args)
              (apply proc (map contents (raise-args highest-type param))))))))
  (let ((type-tags (map type param)))
    (let ((proc (get op type-tags)))
      (if (not (null? proc)) (apply proc (map contents param))
          (apply-generic-raised)))))


(define (drop num)
  (let ((project-proc (get 'project (list (type num)))))
    (if (null? project-proc) num
        (let ((projected-num (project-proc (contents num))))
          (if (equ? (raise projected-num) num)
              (drop projected-num)
              num)))))


;;
;;  number-system
;;

(define (is_integer? x)
  (and (integer? x) (exact? x)))

(define (is_real? x)
  (and (real? x) (inexact? x)))

(define (attach-tag tag oper)
  (cond ((is_integer? oper) oper)
        ((is_real? oper) oper)
        (else (list tag oper))))

(define (type data)
  (cond ((is_integer? data) 'integer)
        ((is_real? data) 'real-number)
        (else (car data))))

(define (contents data)
  (cond ((is_integer? data) data)
        ((is_real? data) data)
        (else (cadr data))))

(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 (raise x) (apply-generic 'raise x))
(define (project x) (apply-generic 'project x))
(define (sqrt* x) (apply-generic 'sqrt x))
(define (sin* x) (apply-generic 'sin x))
(define (cos* x) (apply-generic 'cos x))
(define (atan* x y) (apply-generic 'atan x y))


(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))  
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  (put 'equ? '(integer integer)
       (lambda(x y)(= x y)))
  (put '=zero? '(integer)
       (lambda(x)(= x 0)))
  (put 'raise '(integer)
       (lambda(x)(make-rational x 1)))
  (put 'sqrt '(integer) sqrt)
  (put 'sin '(integer) sin)
  (put 'cos '(integer) cos)
  (put 'atan '(integer integer) atan)
  'done)

(define (make-integer n)
  ((get 'make 'integer) (drop n)))

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ 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 (eq? x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  (define (=zero? x)
    (= (numer x) 0))
  (define (raise x)
    (make-real-number (exact->inexact (/ (numer x) (denom x)))))
  (define (project x)
    (numer x))

  ;; interface to rest of the system
  (define (tag x)
    (attach-tag 'rational 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 'equ? '(rational rational) eq?)
  (put '=zero? '(rational) =zero?)
  (put 'raise  '(rational) raise)
  (put 'project  '(rational) project)
  (put 'sqrt '(rational) (lambda(x)(sqrt (raise x))))
  (put 'sin '(rational) (lambda(x)(sin (raise x))))
  (put 'cos '(rational) (lambda(x)(cos (raise x))))
  (put 'atan '(rational rational) (lambda(x y)(atan (raise x) (raise y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) (drop n) (drop d)))

(define (install-real-number-package)
  (define (tag x)
    (attach-tag 'real-number x))   
  (put 'add '(real-number real-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real-number real-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real-number real-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real-number real-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real-number
       (lambda (x) (tag (* 1.0 x))))
  (put 'equ? '(real-number real-number)
       (lambda(x y)(= x y)))
  (put '=zero? '(real-number)
       (lambda(x)(= x 0)))
  (put 'raise '(real-number)
       (lambda(x)(make-complex-from-real-imag x 0)))
  (put 'project '(real-number)
       (lambda(x)(make-rational (numerator (rationalize (inexact->exact x) 1/100))
                                (denominator (rationalize (inexact->exact x) 1/100)))))
  (put 'sqrt '(real-number) sqrt)
  (put 'sin '(real-number) sin)
  (put 'cos '(real-number) cos)
  (put 'atan '(real-number real-number) atan)
  'done)

(define (make-real-number n)
  ((get 'make 'real-number) n))


(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* (add (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 (mul r (cos* a)) (mul r (sin* a))))
  (define (eq? z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part z2))))
  (define (=zero? z)
    (and (equ? (real-part z) 0)
         (equ? (imag-part z) 0)))
  ;; 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))))
  (put 'equ?    '(rectangular rectangular) eq?)
  (put 'equ?    '(rectangular polar) eq?)
  (put '=zero? '(rectangular) =zero?)
  'done)

(define (real-part z)
  (apply-generic 'real-part z))
(define (imag-part z)
  (apply-generic 'imag-part z))

(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)
    (mul (magnitude z) (cos* (angle z))))
  (define (imag-part z)
    (mul (magnitude z) (sin* (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt* (add (square x) (square y)))
          (atan* y x)))
  (define (eq? z1 z2)
    (and (equ? (magnitude z1) (magnitude z2))
         (equ? (angle z1) (angle z2))))
  (define (=zero? z)
    (equ? (magnitude z) 0))
  ;; 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))))
  (put 'equ?   '(polar polar) eq?)
  (put 'equ?   '(polar rectangular) eq?)
  (put '=zero? '(polar) =zero?)
  'done)
(define (magnitude z)
  (apply-generic 'magnitude z))
(define (angle z)
  (apply-generic 'angle z))


(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 x y)
    ((get 'make-from-mag-ang 'polar) x y))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (add (real-part z1) (real-part z2))
                         (add (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (real-part z1) (real-part z2))
                         (sub (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                       (add (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                       (sub (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-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 'equ? '(complex complex) equ?)
  (put '=zero? '(complex) =zero?)

  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'project '(complex)
        (lambda(z)(make-real-number (real-part z))))

  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))


(define (install-polynomial-package)
  ;; internal procedures
  ;; representation of poly

  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  ;; representation of terms and term lists
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))

  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term
                     t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))

  (define (=zerop? p)
    (empty-termlist? (coeff p)))

  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put '=zero? '(polynomial) =zerop? )
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

(define (make-poly variable . terms)
  ((get 'make 'polynomial) variable terms))
(define (make-term order coeff) (list order coeff))


(install-integer-package)
(install-rational-package)
(install-real-number-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)
(install-polynomial-package)


;;
;;  testing
;;

(define mypoly1 (make-poly 'x (make-term 3 4) (make-term 2 9)))
(display mypoly1) (newline)
(define mypoly2 (make-poly 'x (make-term 7 3) (make-term 3 8)))
(display mypoly2) (newline)

(display (add mypoly1 mypoly2)) (newline)
(display (mul mypoly1 mypoly2)) (newline)

(define mypoly_advanced (make-poly 'y (make-term 5 mypoly1) (make-term 3 mypoly2)))
(display mypoly_advanced) (newline)


(display (add mypoly_advanced mypoly_advanced)) (newline)

(display "------------") (newline)
(define x (make-complex-from-real-imag 1 2))
(define y (make-complex-from-real-imag 1 -2))
(display (drop (add x x))) (newline)
(display (drop (add x y))) (newline)
(display (drop (mul x x))) (newline)
(display (drop (mul x y))) (newline)
(display (drop (div x x))) (newline)
(display (drop (div y y))) (newline)
(display (drop (sub x y))) (newline)

(define rat-1 (make-rational 1 2))
(define rat-2 (make-rational 3 4))
(define cmplx (make-complex-from-real-imag rat-1 rat-2))


(display rat-1) (newline)
(display rat-2) (newline)
(display cmplx) (newline)

(display (add cmplx rat-1)) (newline)
(display (drop (add cmplx rat-1))) (newline)

(display (sub cmplx rat-1)) (newline)
(display (drop (sub cmplx rat-1))) (newline)

(display (mul cmplx rat-1)) (newline)
(display (drop (mul cmplx rat-1))) (newline)

(display (div cmplx rat-1)) (newline)
(display (drop (div cmplx rat-1))) (newline)


No comments: