SICP/ex-2_77-97.scm

(load "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))
  (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)
  (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)
    (if (and (integer? n) (integer? d))
      (let ((g (gcd n d)))
        (cons (/ n g) (/ d g)))
      (cons n d)))
  (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 (add3-rat x y z)
    (add-rat (add-rat x y) z))
  (define (equ? x y)
    (= (* (numer x) (denom y))
       (* (numer y) (denom x))))
  (define (rational->real x)
    (make-real (/ (numer x) (denom x))))
  (define (rational->scheme x)
    (make-scheme-number (inexact->exact (round (/ (numer x) (denom 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 '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?)
  (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 (- (real-part z)) (- (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))

(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)
  (define (coerce-arg arg)
    (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 "---------\ndrop  ") (display x) (newline)
  (if (has-tag? x)
    (let ((project (get 'project (type-tag x))))
      (if (procedure? project)
        (let ((projected (project (contents x))))
          (if (equ? projected x)
            (drop projected)
            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 "-----\napply-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)
    (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 (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)
    (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 - spare representation\n")


(define (install-polynomial-sparse-representation-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)))

  (define (first-term term-list)
    (make-term (- (length term-list) 1)
               (car term-list)))

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

  (define (the-empty-termlist) '())
  (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 (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)
    (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-sparse-representation-package]\n")
  'done)

(install-polynomial-sparse-representation-package)

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


;(display "\nex-2.90\n")

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

;(display "\nex-2.92\n")

;(display "\nex-2.93\n")