Implement till 2.89

I have also added my solution to
http://community.schemewiki.org/?sicp-ex-2.89 because none of the other
ones looked right to me when checking.

ex-2_77-97.scm

@@ -73,6 +73,8 @@
        (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)
@@ -129,6 +131,9 @@
   (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))))
@@ -248,6 +253,8 @@
   (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
@@ -270,6 +277,7 @@
        (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)
@@ -306,6 +314,7 @@
 (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)
@@ -599,6 +608,16 @@
         (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)
@@ -636,6 +655,8 @@
        (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))))
@@ -669,4 +690,151 @@
 
 (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")