# weima learns to program

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)

(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))
(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))))
(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))
(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))
(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)
(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
(make-from-real-imag (add (real-part z1) (real-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))
(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))
(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
(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))

(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
((< (order t1) (order t2))
(else
(make-term (order t1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(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)))
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable 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))
(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 (mul mypoly1 mypoly2)) (newline)

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

(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)