SICP/ex-2_77-97.scm

(load "shared/util.scm")

(display "\nexample - generic arithmetic operations\n")

; (define (display x) ())
; (define (newline) ())
; can be used to import stuff silently

; Put and get functions. We could have implemented this via a list of
; three-tuples, but I don't know how to create global variables yet so we just
; use this code from SO. Doesn't look too complicated.
; https://stackoverflow.com/questions/5499005/how-do-i-get-the-functions-put-and-get-in-sicp-scheme-exercise-2-78-and-on
(define *op-table* (make-hash-table))
(define (put op type proc)
  (hash-table/put! *op-table* (list op type) proc))
(define (get op type)
  (hash-table/get *op-table* (list op type) #f))

(define *coercion-table* (make-hash-table))
(define (put-coercion type1 type2 proc)
  (hash-table/put! *coercion-table* (list type1 type2) proc))
(define (get-coercion type1 type2)
  (hash-table/get *coercion-table* (list type1 type2) #f))

;; Helpers for generic arithmetic operations
(define (attach-tag type-tag contents)
  (cond
    ((eq? type-tag 'scheme-number) contents)
    (else (cons type-tag contents))))

(define (type-tag datum)
  (cond
    ((number? datum) 'scheme-number)
    ((pair? datum) (car datum))
    (else (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (has-tag? datum)
  (cond
    ((number? datum) #t)
    ((pair? datum) #t)
    (else #f)))

(define (contents datum)
  (cond
    ((number? datum) datum)
    ((pair? datum) (cdr datum))
    (else (error "Bad tagged datum -- CONTENTS" datum))))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((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 (install-scheme-number-package)
  (define (tag x) x)
  (define (scheme->rational x)
    (make-rational x 1))
  (define (gcd-scheme a b)
    (if (and (integer? a) (integer? b))
      (if (= b 0) (abs a) (gcd-scheme b (remainder a b)))
      'nogcd))
  (define (reduce-integers n d)
    (if (and (integer? n) (integer? d))
      (let ((g (gcd n d)))
        (list (/ n g) (/ d g)))
      'noreduce))
  (put 'reduce '(scheme-number scheme-number)
       (lambda (x y) (reduce-integers x y)))
  (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 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))
  (put 'exp '(scheme-number scheme-number)
       (lambda (x y) (tag (expt x y))))
  (put '=zero? '(scheme-number)
       (lambda (x) (= x 0)))
  (put 'negate '(scheme-number)
       (lambda (x) (- x)))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  (put 'arctan '(scheme-number scheme-number)
       (lambda (x y) (atan x y)))
  (put 'square-root '(scheme-number) sqrt)
  (put 'raise 'scheme-number scheme->rational)
  (put 'gcd '(scheme-number scheme-number) gcd-scheme)
  (display "[install-scheme-number-package]\n")
  'done)

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((reduced (reduce n d)))
      (if (eq? reduced 'noreduce)
        (cons n d)
        (cons (car reduced) (cadr reduced)))))
  (define (add-rat x y)
    (let ((new-n (add (mul (numer x) (denom y))
                      (mul (numer y) (denom x))))
          (new-d (mul (denom x) (denom y))))
      (make-rat new-n new-d)))
  (define (sub-rat x y)
    (make-rat (sub (mul (numer x) (denom y))
                   (mul (numer y) (denom x)))
              (mul (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (mul (numer x) (numer y))
              (mul (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (mul (numer x) (denom y))
              (mul (denom x) (numer y))))
  (define (add3-rat x y z)
    (add-rat (add-rat x y) z))
  (define (equ?-rat x y)
    (equ? (mul (numer x) (denom y))
          (mul (numer y) (denom x))))
  (define (rational->real x)
    (let ((n (numer x))
          (d (denom x)))
      (cond
        ((and (number? n) (number? d))
          (make-real (/ (numer x) (denom x))))
        (else 'invalid))))
  (define (rational->scheme x)
    (let ((n (numer x)) (d (denom x)))
      (cond
        ((and (number? n) (number? d))
         (make-scheme-number (inexact->exact (round (/ (numer x) (denom x))))))
        (else 'invalid))))

  ;; 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 'add3 '(rational rational rational)
       (lambda (x y z) (tag (add3-rat x y z))))
  (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) equ?-rat)
  (put '=zero? '(rational)
       (lambda (x) (= (numer x) 0)))
  (put 'negate '(rational)
       (lambda (x) (tag (make-rat (- (numer x))
                                  (denom x)))))
  (define (arctan-rational x y)
    (atan (/ (numer x) (denom x))
          (/ (numer y) (denom y))))
  (put 'arctan '(rational rational) arctan-rational)
  (put 'square-root '(rational)
       (lambda (x) (sqrt (/ (numer x) (denom x)))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'raise 'rational rational->real)
  (put 'project 'rational rational->scheme)
  (display "[install-rational-package]\n")
  'done)

(define (install-real-package)
  (define (make-real x) (tag x))
  (define (real->rational x)
    (make-rational x 1))
  (define (real->complex x)
    (make-complex-from-real-imag x 0))
  (define (tag x)
    (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ x y))))
  (put 'equ? '(real real)
       (lambda (x y) (= x y)))
  (put 'exp '(real real)
       (lambda (x y) (tag (expt x y))))
  (put '=zero? '(real)
       (lambda (x) (= x 0)))
  (put 'make 'real
       (lambda (x) (make-real x)))
  (put 'raise 'real real->complex)
  (put 'project 'real real->rational)
  (display "[install-real-package]\n")
  'done)

(define (install-rectangular-package)
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (square x) (mul x x))
  (define (magnitude z)
    (square-root (add (square (real-part z))
                      (square (imag-part z)))))
  (define (angle z)
    (arctan (imag-part z)
            (real-part z)))
  (define (tag z) (attach-tag 'rectangular z))
  (define (make-from-real-imag x y)
    (tag (cons x y)))
  (define (make-from-mag-ang r a)
    (tag (cons (mul r (cos a)) (mul r (sin a)))))
  ; interface to the rest of the system
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put '=zero? '(rectangular) (lambda (z) (= (real-part z) (imag-part z) 0)))
  (put 'make-from-mag-ang 'rectangular make-from-mag-ang)
  (put 'make-from-real-imag 'rectangular make-from-real-imag)
  (display "[install-rectangular-package]\n")
  'done)

(define (install-polar-package)
  (define (real-part z)
    (mul (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (mul (magnitude z) (sin (angle z))))
  (define (magnitude z) (car z))
  (define (angle z) (cdr z))
  (define (sqrt x) (mul x x))
  (define (tag z) (attach-tag 'polar z))
  (define (make-from-real-imag x y)
    (tag (cons (sqrt (add (square x) (square y)))
               (atan y x))))
  (define (make-from-mag-ang r a) (tag (cons r a)))
  ; interface to rest of the system
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put '=zero? '(polar) (lambda (z) (= (magnitude z) 0)))
  (put 'make-from-mag-ang 'polar make-from-mag-ang)
  (put 'make-from-real-imag 'polar make-from-real-imag)
  (display "[install-polar-package]\n")
  'done)

(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))
  ;; getters
  (define (real-part z) (apply-generic 'real-part z))
  (define (imag-part z) (apply-generic 'imag-part z))
  (define (magnitude z) (apply-generic 'magnitude z))
  (define (angle z) (apply-generic 'angle z))
  ;; 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))))
  (define (equ?-complex z1 z2)
    (and (equ? (magnitude z1) (magnitude z2))
         (equ? (angle z1) (angle z2))))
  (define (negate-complex z)
    (tag (make-from-real-imag (negate (real-part z))
                              (negate (imag-part z)))))
  (define (complex->real x)
    (make-real (real-part x)))
  ;; interface to rest of the system
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (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 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'equ? '(complex complex) equ?-complex)
  (put '=zero? '(complex) =zero?)
  (put 'negate '(complex) negate-complex)
  (put 'project 'complex complex->real)
  (display "[install-complex-package]\n")
  'done)

;; constructors
(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

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

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

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

(define (real-part z) ((get 'real-part '(complex)) z))
(define (imag-part z) ((get 'imag-part '(complex)) z))
(define (magnitude z) ((get 'magnitude '(complex)) z))
(define (angle z) ((get 'angle '(complex)) z))

;; generic operations
(define (add x y) (apply-generic 'add x y))
(define (add3 x y z) (apply-generic 'add3 x y z))
(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 (exp x y) (apply-generic 'exp x y))
(define (arctan x y) (apply-generic 'arctan x y))
(define (square-root x) (apply-generic 'square-root x))
(define (negate x) (apply-generic 'negate x))
(define (gcd x y)
  (if (procedure? (get 'gcd (list (type-tag x) (type-tag y))))
    (apply-generic 'gcd x y)
    'nogcd))
(define (reduce x y)
  (if (procedure? (get 'reduce (list (type-tag x) (type-tag y))))
    (apply-generic 'reduce x y)
    'noreduce))

(install-scheme-number-package)
(install-rational-package)
(install-real-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)

(assert (add (make-scheme-number 10) (make-scheme-number 20)) (make-scheme-number 30))
(define p1 (make-complex-from-mag-ang 14.142135623730951 0.7853981633974483))
(define e1 (make-complex-from-real-imag 10 10))
(assert (add e1 e1) (make-complex-from-real-imag 20 20))

(newline) (display "ex-2.77 - see comments") (newline)

; real-part (and all other selectors are implemented via calls to apply
; generic. The first call to apply generic has the type 'magnitude '(complex).
; By adding the code from Alyssa that call gets dispatched a second time which
; results in a call to apply generic with 'magnitude '(rectangular). This calls
; the actual magnitude function from the rectangular package.

(newline) (display "ex-2.78 - simplify scheme number") (newline)

; Solution at the beginning of this file.
(assert (add 5 3) 8)

(newline) (display "ex-2.79 - equ?") (newline)

; Extended each of the packages and defined generic procedure
(assert (equ? (make-scheme-number 10) (make-scheme-number 10)) #t)
(assert (equ? (make-rational 3 4) (make-rational 6 8)) #t)
(assert (equ? (make-complex-from-mag-ang 3 4) (make-complex-from-real-imag 6 8)) #f)
(assert (equ? p1 e1) #t) ; define above

(newline) (display "ex-2.80 - =zero?") (newline)

; Extended each of the packages and defined generic procedure
(assert (=zero? 0) #t)
(assert (=zero? 1) #f)
(assert (=zero? (make-rational 0 1)) #t)
(assert (=zero? (make-rational 1 1)) #f)
(assert (=zero? e1) #f)
(assert (=zero? p1) #f)

(newline) (display "ex-2.81 - Louis trying things") (newline)

(define (scheme-number->complex n)
  (make-complex-from-real-imag (contents n) 0))

(put-coercion 'scheme-number 'complex scheme-number->complex)

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (let ((t1->t2 (get-coercion type1 type2))
                      (t2->t1 (get-coercion type2 type1)))
                  (cond
                    ((eq? type1 type2) (error "No need to coerce identical types"
                                              (list op type-tags)))
                    (t1->t2 (apply-generic op (t1->t2 a1) a2))
                    (t2->t1 (apply-generic op a1 (t2->t1 a2)))
                    (else (error "No method for these types" (list op type-tags))))))
              (error "No method for these types"
                     (list op type-tags)))))))

(display "[see comments]\n")
(assert (exp 3 3) 27)
(assert (add (make-scheme-number 3) (make-complex-from-real-imag 3 4))
        (make-complex-from-real-imag 6 4))

; a. This is an endless loop. Louis change is not necessary, because if we
; coerce the arguments into the same type we would have found the respective
; procedure already.

; (define (scheme-number->scheme-number n) n)
; (define (complex->complex z) z)
; (put-coercion 'scheme-number 'scheme-number scheme-number->scheme-number)
; (put-coercion 'complex 'complex complex->complex)

; (exp (make-complex-from-real-imag 3 4) (make-complex-from-mag-ang 2 3))

; b. apply-generic already handles arguments of the same type correctly. It
; will simply not find a coercion procedure and return.

; c. added check for identical types to apply-generic. The following now just
; causes an error and no endless loop.
; (exp (make-complex-from-real-imag 3 4) (make-complex-from-mag-ang 2 3))


(newline) (display "ex-2.82 - multi argument coercion") (newline)


(define (scheme-number->rational n)
  (make-rational (contents n) 1))
(put-coercion 'scheme-number 'rational scheme-number->rational)

(define (coerce-args target-type args)
  (define (coerce-arg arg)
    (let ((t1->t2 (get-coercion (type-tag arg) target-type)))
      (if (procedure? t1->t2) (t1->t2 arg) arg)))
  (map coerce-arg args))

(define (apply-generic op . args)
  (define (try-args args-list)
    (if (null? args-list)
      (error "No method for these types" (list op (map type-tag args)))
      (let ((proc (get op (map type-tag (car args-list))))
            (args-contents (map contents (car args-list))))
        (if (procedure? proc)
          (apply proc args-contents)
          (try-args (cdr args-list))))))
  (define (coerce-to-arg arg)
    (coerce-args (type-tag arg) args))
  (try-args (cons args (map coerce-to-arg args))))

(assert (add3 (make-rational 1 3) 2 (make-rational 3 9)) (make-rational 8 3))

; This approach does not work if there exist procedures for mixed types or if
; the coerced type that would work is different from any of the existing
; arguments' types.

(display (coerce-args 'rational (list (make-rational 1 3) 2 3))) (newline)

(newline) (display "ex-2.83 - raise") (newline)

; Our scheme-number package supports real numbers so we use that as our
; real-number package without further changes. Additionally, we create an
; integer package that only accepts integers in the constructor.

(define (raise x)
  ((get 'raise (type-tag x)) (contents x)))

(assert (sub (make-scheme-number 3) (make-scheme-number 1)) (make-scheme-number 2))

(define i (make-scheme-number 3))
(display i) (newline)
(display (raise i)) (newline)
(display (raise (raise i))) (newline)
(display (raise (raise (raise i)))) (newline)

(newline) (display "ex-2.84") (newline)

; All we have to do is update coerce-args to do consecutive raises
; to reach the target type.
(define (coerce-args target-type args)
  ; (display "COERCE-ARGS ") (display target-type) (display " ") (display args) (newline)
  (define (coerce-arg arg)
    ; (display "COERCE-ARG ") (display arg) (newline)
    (if (eq? (type-tag arg) target-type)
      arg
      (let ((raise (get 'raise (type-tag arg))))
        (if (procedure? raise)
          (raise (contents arg))
          arg))))
  (let ((coerced-args (map coerce-arg args)))
    (if (equal? args coerced-args)
      coerced-args ; no more raising possible
      (coerce-args target-type coerced-args))))

(assert (equ? (make-scheme-number 3) (make-complex-from-real-imag 3 0)) #t)
(assert (equ? (make-scheme-number 3) (make-complex-from-real-imag 3 1)) #f)
(assert (equ? (make-scheme-number 3) (make-rational 3 1)) #t)
(assert (add3 (make-rational 1 3) (make-scheme-number 2) (make-rational 3 9)) (make-rational 8 3))

(newline) (display "ex-2.85 - project and drop") (newline)

; Do not implement project in terms of apply-generic as that will result in an
; endless loop when trying to drop values later automatically within the
; context of apply-generic.
(define (project x)
  ((get 'project (type-tag x)) (contents x)))

(define c (make-complex-from-real-imag 4.2 1))
(display c) (newline)
(display (project c)) (newline)
(display (project (project c))) (newline)
(display (project (project (project c)))) (newline)

; Implement drop to transform number to lowest possible representation
(define (drop x)
  ; (display "DROP ") (display x) (newline)
  (if (has-tag? x)
    (let ((project (get 'project (type-tag x))))
      (if (procedure? project)
        (let ((projected (project (contents x))))
          (cond
            ((eq? projected 'invalid) x)
            ((equ? projected x) (drop projected))
            (else x)))
        x))
    x))

;(assert (drop 3) (make-scheme-number 3))
;(assert (drop (make-complex-from-real-imag 3.2 0)) (drop (make-real (/ 16 5.))))
;(assert (drop (make-complex-from-real-imag 3 0)) (make-scheme-number 3))

(define (apply-generic op . args)
  ; (display "APPLY-GENERIC ") (display op) (display " ") (display args) (newline)
  (define (try-args args-list)
    (if (null? args-list)
      (error "No method for these types" (list op (map type-tag args)))
      (let ((proc (get op (map type-tag (car args-list))))
            (args-contents (map contents (car args-list))))
        (if (procedure? proc)
          (drop (apply proc args-contents))
          (try-args (cdr args-list))))))
  (define (coerce-to-arg arg)
    ; (display "COERCE-TO-ARG ") (display arg) (newline)
    (coerce-args (type-tag arg) args))
  (try-args (cons args (map coerce-to-arg args))))

(assert (equ? (add (make-rational 1 3)
             (make-complex-from-real-imag 3 0))
        (make-rational 10 3)) #t)
(assert (add (make-rational 6 3)
             (make-complex-from-real-imag 3 0))
        (make-scheme-number 5))
(assert (add (make-rational 6 3)
             (make-complex-from-real-imag 3 0))
        5)

(display "\nex-2.86 - generic complex numbers\n")

; All the procedures that are used by the complex packages would also have to
; use the generic procedures. For example, we cannot use *, -, /, +, and have
; to replace them with their generic counter-part. We then also have to
; implement sine and cosine. I have skipped sin and cos, but handle atan and
; sqrt, so the following works.

(define cr (make-complex-from-real-imag (make-rational 1 2)
                                        (make-rational 1 2)))
(display (add cr cr)) (newline)
(display (mul cr cr)) (newline)

(display "\nexample - symbolic algebra\n")

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

  ;; procedures same-variable? and variable? from section 2.3.2
  (define (variable? x) (symbol? x))
  (define (=number? exp num)
    (and (number? exp) (= exp num)))
  (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 (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 (negate-term term)
    (make-term (order term) (negate (coeff term))))

  (define (negate-terms terms)
    (map negate-term terms))

  (define (sub-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (negate-terms (term-list p2))))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))

  (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 (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 (=zero?-poly p)
    (define (=zero?-terms terms)
      (cond
        ((empty-termlist? terms) #t)
        ((not (=zero? (coeff (first-term terms)))) #f)
        (else (=zero?-terms (rest-terms terms)))))
    (=zero?-terms (term-list 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 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put '=zero? '(polynomial) =zero?-poly)
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  (display "[install-polynomial-package]\n")
  'done)

(install-polynomial-package)

(define (make-poly var terms)
  ((get 'make 'polynomial) var terms))

(define p (make-poly 'x '((100 2) (1 2))))
;(display p)
(assert (mul p p)
        (make-poly 'x '((200 4) (101 8) (2 4))))


(display "\nex-2.87 - =zero?\n")

(assert (=zero? p) #f)
(assert #t
        (=zero? (make-poly 'x (list
                        (list 10 (make-rational 0 10))
                        (list 5 (make-complex-from-real-imag 0 0))
                        (list 1 0)))))

(define px p)
(define py (make-poly 'y (list (list 3 px))))
(display (add py py))
(newline)

(display "\nex-2.88 - sub\n")

; Implement via negate procedure
(assert (negate (make-scheme-number -3)) 3)
(assert (negate (make-rational -1 3))
        (make-rational 1 3))
(assert (make-complex-from-real-imag 2 4)
        (negate (make-complex-from-real-imag -2 -4)))

(define p1 (make-poly 'x (list (list 5 4) (list 2 1))))
(define p2 (make-poly 'x (list (list 5 2) (list 2 (make-rational 1 2)))))
(assert (sub p1 p2) p2)

(display "\nex-2.89 - sparse representation\n")


(define (install-polynomial-package)
  ;; internal procedures
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (make-poly variable term-list)
    (cons variable term-list))

  ;; procedures same-variable? and variable? from section 2.3.2
  (define (variable? x) (symbol? x))
  (define (=number? exp num)
    (and (number? exp) (= exp num)))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  ;; generic implementations
  (define (first-term term-list)
    ((get 'first-term (type-tag term-list)) (contents term-list)))

  (define (adjoin-term term term-list)
    ((get 'adjoin-term (type-tag term-list)) term (contents term-list)))

  ;; dense implementations
  (define (tag-dense p) (attach-tag 'dense p))
  (define (make-poly-dense variable term-list)
    (cons variable (tag-dense term-list)))

  (define (first-term-dense term-list)
    ; (display "FIRST-TERM-DENSE ") (display term-list) (newline)
    (make-term (- (length term-list) 1)
               (car term-list)))

  (define (adjoin-term-dense term term-list)
    (let ((coeff-term (coeff term))
          (order-term (order term))
          (length-terms (length term-list)))
      (cond
        ((= order-term length-terms) (tag-dense (cons coeff-term term-list)))
        ((< order-term length-terms) (error "Cannot adjoin lower-order term to terms"))
        (else (tag-dense
                (cons
                  coeff-term
                  (contents (adjoin-term-dense
                              (make-term (- order-term 1) 0)
                              term-list))))))))

  (put 'first-term 'dense first-term-dense)
  (put 'adjoin-term 'dense adjoin-term-dense)

  ;; sparse implementations
  (define (tag-sparse p) (attach-tag 'sparse p))
  (define (make-poly-sparse variable term-list)
    (cons variable (tag-sparse term-list)))

  (define (adjoin-term-sparse term term-list)
    (if (=zero? (coeff term))
        (tag-sparse term-list)
        (tag-sparse (cons term term-list))))

  (define (first-term-sparse term-list) (car term-list))

  (put 'first-term 'sparse first-term-sparse)
  (put 'adjoin-term 'sparse adjoin-term-sparse)

  (define (empty-termlist t)
    (attach-tag (type-tag t) '()))
  (define (rest-terms term-list)
    (let ((term-type (type-tag term-list))
          (terms (contents term-list)))
      (attach-tag term-type (cdr terms))))

  (define (empty-termlist? term-list) (null? (contents term-list)))
  (define (make-term order coeff)
    (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))

  (define (coeffs term-list)
    (if (empty-termlist? term-list)
      '()
      (cons (coeff (first-term term-list))
            (coeffs (rest-terms term-list)))))

  (define (add-terms L1 L2)
    ; (display "ADD-TERMS ") (display L1) (display L2) (newline)
    (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 (get-coercion-target p1 p2)
    (let ((v1 (variable p1))
          (v2 (variable p2)))
      (cond
        ; Here we could introduce an ordering where we find the variable with
        ; the highest ordering and return it, but for testing purposes let's
        ; just hardcode it.
        ((and (eq? v1 'y) (eq? v2 'x)) 'x)
        ((and (eq? v1 'x) (eq? v2 'y)) 'x)
        (else (error "Coercion not supported -- GET-COERCION-TARGET"
                     (list p1 p2))))))

  (define (scale-terms factor terms)
    ; (display "SCALE-TERMS ") (display factor) (display terms) (newline)
    (if (empty-termlist? terms)
      terms
      (let ((term (first-term terms))
            (rest (rest-terms terms)))
      (adjoin-term (make-term (order term) (mul (coeff term) factor))
                   (scale-terms factor rest)))))

  (put 'mul '(scheme-number polynomial)
       (lambda (s p) (tag (make-poly (variable p)
                                     (scale-terms s (term-list p))))))

  (define (coerce-terms terms source-var target-var)
    ; (display "COERCE-TERMS ") (display terms) (newline)
    (define (coerce-term t)
      ; (display "COERCE-TERM ") (display t) (newline)
      (let ((c (coeff t))
            (o (order t))
            (new-poly (tag (make-poly-sparse
                             source-var
                             (list (list (order t) 1))))))
        ; (display "NEW-POLY ") (display new-poly) (newline)
        (if (eq? (type-tag c) 'polynomial)
          (let ((new-poly (tag (make-poly-sparse source-var (list (list o 1))))))
            (scale-terms new-poly (contents (term-list c))))
          (let ((sub-poly (tag (make-poly-sparse
                                 source-var
                                 (list (list o c))))))
            (cons 'sparse (list (list 0 sub-poly)))))))
    (if (empty-termlist? terms)
      terms
      (add-terms (coerce-term (first-term terms))
                 (coerce-terms (rest-terms terms) source-var target-var))))


  (define (coerce-poly p target-var)
    ; (display "COERCE-POLY ") (display p) (display " TARGET ") (display target-var) (newline)
    (if (eq? (variable p) target-var)
      p
      (let ((coercion-result (coerce-terms (term-list p) (variable p) target-var)))
        ; (display "COERCE-POLY-RESULT ") (display coercion-result) (newline)
        (make-poly target-var coercion-result))))

  (define (coerce-polys p1 p2)
    ; (display "COERCE-POLYS ") (display p1) (display p2) (newline)
    (let ((coercion-target-variable (get-coercion-target p1 p2)))
      (if coercion-target-variable
        (list (coerce-poly p1 coercion-target-variable)
              (coerce-poly p2 coercion-target-variable))
        #f)))

  (define (add-poly p1 p2)
    ; (display "ADD-POLY ") (display p1) (display p2) (newline)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (let ((coerced-polys (coerce-polys p1 p2)))
          (if coerced-polys
            (add-poly (car coerced-polys) (cadr coerced-polys))
            (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))))

  (define (sub-poly p1 p2)
    (define (negate-term term)
      (make-term (order term) (negate (coeff term))))
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (map negate-term (term-list p2))))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))

  (define (mul-terms L1 L2)
    ; (display "MUL-TERMS") (display L1) (display L2) (newline)
    (if (empty-termlist? L1)
        L1
        (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)
    ; (display "MUL-TERM-BY-ALL-TERMS ") (display t1) (display L) (newline)
    (if (empty-termlist? L)
        L
        (let ((t2 (first-term L)))
          ; (display "T1 ") (display t1) (display " T2 ") (display t2) (newline)
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))

  (define (mul-poly p1 p2)
    ; (display "MUL-POLY ") (display p1) (display p2) (newline)
    (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 (div-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
      (let ((result (div-terms (term-list p1) (term-list p2)))
            (var (variable p1)))
        (list
          (tag (make-poly var (car result)))
          (tag (make-poly var (cadr result)))))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))

  (define (div-terms L1 L2)
    ; (display "DIV-TERMS ") (display L1) (display L2) (newline)
    (define (negate-term t)
      (make-term (order t) (negate (coeff t))))
    (define (negate-terms terms)
      (let ((term-type (type-tag terms))
            (term-list (contents terms)))
        (cons term-type (map negate-term term-list))))
    (if (empty-termlist? L1)
        (list L1 L1)
        (let ((t1 (first-term L1)) ; dividend
              (t2 (first-term L2))) ; divisor
         (if (> (order t2) (order t1))
             (list (empty-termlist L2) L1)
             (let ((new-c (div (coeff t1) (coeff t2)))
                   (new-o (- (order t1) (order t2)))
                   (new-term (make-term (- (order t1) (order t2))
                                        (div (coeff t1) (coeff t2)))))
               (let ((new-dividend (add-terms
                                     L1
                                     (negate-terms
                                       (mul-terms
                                         (adjoin-term new-term (empty-termlist L1))
                                         L2)))))
                 (let ((rest-of-result (div-terms new-dividend L2)))
                   (list (adjoin-term new-term (car rest-of-result))
                         (cadr rest-of-result)))))))))

  (define (=zero?-poly p)
    (define (=zero?-terms terms)
      (cond
        ((empty-termlist? terms) #t)
        ((not (=zero? (coeff (first-term terms)))) #f)
        (else (=zero?-terms (rest-terms terms)))))
    (=zero?-terms (term-list p)))


  (define (gcd-poly p1 p2)
    ; (display "GCD-POLY") (display p1) (display p2) (newline)
    (define (remainder-terms a b)
      (cadr (div-terms a b)))

    (define (gcd-terms a b)
      ; (display "GCD-TERMS") (display a) (display b) (newline)
      (if (empty-termlist? b)
          a
          (gcd-terms b (remainder-terms a b))))

    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (gcd-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))

  (define (remainder-terms-pseudo p q)
    (let ((o1 (order (first-term p)))
          (o2 (order (first-term q)))
          (c (coeff (first-term q))))
      (let ((integerizing-factor
              (expt c (+ 1 o1 (- o2)))))
        (cadr (div-terms (scale-terms integerizing-factor p)
                         q)))))

  (define (gcd-terms-pseudo a b)
    ; (display "GCD-TERMS-PSEUDO") (display a) (display b) (newline)
    (if (empty-termlist? b)
        a
        (gcd-terms-pseudo b (remainder-terms-pseudo a b))))

  ; Returns the coefficients for a list of integers.
  (define (gcd-list xs)
    (cond
      ((null? xs) 1)
      ((null? (cdr xs)) (car xs))
      (else (gcd-list (cons (gcd (car xs) (cadr xs)) (cddr xs))))))

  (define (gcd-poly-pseudo p1 p2)
    ; (display "GCD-POLY-PSEUDO") (display p1) (display p2) (newline)

    (if (same-variable? (variable p1) (variable p2))
      (let ((result-terms (gcd-terms-pseudo (term-list p1)
                                            (term-list p2))))
        (let ((gcd-result (gcd-list (coeffs result-terms))))
          (make-poly (variable p1)
                     (scale-terms (/ 1 gcd-result) result-terms))))
      (error "Polys not in same var -- ADD-POLY"
             (list p1 p2))))

  (define (reduce-terms a b)
    (let ((g (gcd-terms-pseudo a b)))
      (let ((gcd-result (gcd-list (coeffs g))))
        (let ((g-scaled (scale-terms (/ 1 gcd-result) g)))
          (list (car (div-terms a g-scaled)) (car (div-terms b g-scaled)))))))

  (define (reduce-poly p1 p2)
    ; (display "REDUCE-POLY ") (display p1) (display p2) (newline)
    (if (same-variable? (variable p1) (variable p2))
      (let ((reduced-list (reduce-terms (term-list p1)
                                        (term-list p2))))
        (list (tag (make-poly (variable p1) (car reduced-list)))
              (tag (make-poly (variable p2) (cadr reduced-list)))))
      (error "Polys not in same var -- ADD-POLY"
             (list p1 p2))))

  ;; 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 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put 'div '(polynomial polynomial)
       (lambda (p1 p2) (div-poly p1 p2)))
  (put 'greatest-comond-divisor '(polynomial polynomial)
       (lambda (p1 p2) (tag (gcd-poly p1 p2))))
  (put 'greatest-comond-divisor-pseudo '(polynomial polynomial)
       (lambda (p1 p2) (tag (gcd-poly-pseudo p1 p2))))
  (put 'reduce '(polynomial polynomial)
       (lambda (p1 p2) (reduce-poly p1 p2)))
  (put '=zero? '(polynomial) =zero?-poly)
  (put 'make 'poly-sparse
       (lambda (var terms) (tag (make-poly-sparse var terms))))
  (put 'make 'poly-dense
       (lambda (var terms) (tag (make-poly-dense var terms))))
  (display "[install-polynomial-package]\n")
  'done)

(install-polynomial-package)

(define (make-poly-sparse var terms)
  ((get 'make 'poly-sparse) var terms))

(define (make-poly-dense var terms)
  ((get 'make 'poly-dense) var terms))


(define p1 (make-poly-dense 'x (list 5 1)))
(display p1) (newline)
(display (add p1 p1)) (newline)

(assert (add p1 p1) (make-poly-dense 'x (list 10 2)))
(assert (add (make-poly-dense 'x (list       2 2 0 1))
             (make-poly-dense 'x (list 1 2 3 2 3 6 6)))
        (make-poly-dense 'x (list 1 2 3 4 5 6 7)))
(assert (mul (make-poly-dense 'x (list 1 1))
             (make-poly-dense 'x (list 1 1)))
        (make-poly-dense 'x (list 1 2 1)))

(display "\nex-2.90 - support sparse and dense polynomials\n")

(define p (make-poly-sparse 'x '((100 2) (1 2))))
(display p) (newline)
(assert (add p p) (make-poly-sparse 'x '((100 4) (1 4))))
(assert (mul p p)
        (make-poly-sparse 'x '((200 4) (101 8) (2 4))))


(display "\nex-2.91 - divide\n")

(define p1 (make-poly-sparse 'x '((5 1) (0 -1))))
(define p2 (make-poly-sparse 'x '((2 1) (0 -1))))
(assert (mul p1 p1) (make-poly-sparse 'x '((10 1) (5 -2) (0 1))))
(assert (mul p1 p2) (make-poly-sparse 'x '((7 1) (5 -1) (2 -1) (0 1))))
(let ((result (div p1 p2)))
  (assert (car result) (make-poly-sparse 'x '((3 1) (1 1))))
  (assert (cadr result) (make-poly-sparse 'x '((1 1) (0 -1)))))


(display "\nex-2.92 - coerce polynomials\n")

(define p1 (make-poly-sparse
             'x
             (list (list 1 (make-poly-sparse
                             'y
                             '((2 1) (0 1)))))))
(define p2 (make-poly-sparse
             'y
             (list
               (list 4 3)
               (list 2 (make-poly-sparse 'x '((2 1) (0 8)))))))

(display (add p1 p2)) (newline)

(display "\nex-2.93 - polynomial rationals\n")

(define p1 (make-poly-sparse 'x '((2 1)(0 1))))
(define p2 (make-poly-sparse 'x '((3 1)(0 1))))
(define rf (make-rational p2 p1))

(display rf) (newline)
(display (add rf rf)) (newline)

(display "\nex-2.94 - polynomial gcd\n")

(define (greatest-common-divisor x y) (apply-generic 'greatest-comond-divisor x y))
(define p1 (make-poly-sparse 'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-poly-sparse 'x '((3 1) (1 -1))))
(assert (greatest-common-divisor p1 p2)
        (make-poly-sparse 'x '((2 -1) (1 1))))

(display "\nex-2.95\n")

(define p1 (make-poly-sparse 'x '((2 1) (1 -2) (0 1))))
(define p2 (make-poly-sparse 'x '((2 11) (0 7))))
(define p3 (make-poly-sparse 'x '((1 13) (0 5))))

(define q1 (mul p1 p2))
(define q2 (mul p1 p3))

(display q1) (newline)
(display q2) (newline)
(display (greatest-common-divisor q1 q2)) (newline)


(display "\nex-2.96 - pseudoremainder and improved GCD\n")

(define (gcd-poly-pseudo x y) (apply-generic 'greatest-comond-divisor-pseudo x y))
(assert (gcd-poly-pseudo q1 q2) p1)

(display "\nex-2.97\n")

(assert (car (reduce q1 q2)) p2)
(assert (cadr (reduce q1 q2)) p3)
(assert (reduce 8 14.242) 'noreduce)
(assert (reduce 6 8) (list 3 4))
(assert (cadr (make-rational q1 q2)) p2)

(define p1 (make-poly-sparse 'x '((1 1)(0 1))))
(define p2 (make-poly-sparse 'x '((3 1)(0 -1))))
(define p3 (make-poly-sparse 'x '((1 1))))
(define p4 (make-poly-sparse 'x '((2 1)(0 -1))))

(define rf1 (make-rational p1 p2))
(define rf2 (make-rational p3 p4))

(display (add rf1 rf2)) (newline)