Implement till 2.90

ex-2_77-97.scm

@@ -254,7 +254,8 @@
     (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)))))
+    (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
@@ -701,16 +702,15 @@
 (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")
+(display "\nex-2.89 - sparse representation\n")
 
 
-(define (install-polynomial-sparse-representation-package)
+(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 (make-poly variable term-list)
+    (cons variable term-list))
 
   ;; procedures same-variable? and variable? from section 2.3.2
   (define (variable? x) (symbol? x))
@@ -719,22 +719,63 @@
   (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)
+    ;(display "ADJOIN-TERM ") (display term) (display term-list) (newline)
+    ((get 'adjoin-term (type-tag term-list)) term (contents term-list)))
+
+  ;; sparse implementations
+  (define (tag-sparse p) (attach-tag 'sparse p))
+  (define (make-poly-sparse variable term-list)
+    (cons variable (tag-sparse term-list)))
+
+  (define (first-term-sparse term-list)
+    ;(display "first-term-sparse ") (display term-list) (newline)
     (make-term (- (length term-list) 1)
                (car term-list)))
 
-  (define (adjoin-term term term-list)
+  (define (adjoin-term-sparse 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) (tag-sparse (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))))))
+        (else (tag-sparse
+                (cons
+                  coeff-term
+                  (contents (adjoin-term-sparse
+                              (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))
+  (put 'first-term 'sparse first-term-sparse)
+  (put 'adjoin-term 'sparse adjoin-term-sparse)
+
+  ;; dense implementations
+  (define (tag-dense p) (attach-tag 'dense p))
+  (define (make-poly-dense variable term-list)
+    (cons variable (tag-dense term-list)))
+
+  (define (adjoin-term-dense term term-list)
+    (if (=zero? (coeff term))
+        (tag-dense term-list)
+        (tag-dense (cons term term-list))))
+
+  (define (first-term-dense term-list) (car term-list))
+
+  (put 'first-term 'dense first-term-dense)
+  (put 'adjoin-term 'dense adjoin-term-dense)
+
+  (define (the-empty-termlist) (tag-sparse '()))
+  (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))
@@ -777,13 +818,13 @@
 
   (define (mul-terms L1 L2)
     (if (empty-termlist? L1)
-        (the-empty-termlist)
+        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)
     (if (empty-termlist? L)
-        (the-empty-termlist)
+        L
         (let ((t2 (first-term L)))
           (adjoin-term
            (make-term (+ (order t1) (order t2))
@@ -815,25 +856,44 @@
   (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")
+  (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-sparse-representation-package)
+(install-polynomial-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))))
+(define (make-poly-sparse var terms)
+  ((get 'make 'poly-sparse) var terms))
+
+(define (make-poly-dense var terms)
+  ((get 'make 'poly-dense) var terms))
 
 
-;(display "\nex-2.90\n")
+(define p1 (make-poly-sparse 'x (list 5 1)))
+(display p1) (newline)
+(display (add p1 p1)) (newline)
 
-;(display "\nex-2.91\n")
+(assert (add p1 p1) (make-poly-sparse 'x (list 10 2)))
+(assert (add (make-poly-sparse 'x (list       2 2 0 1))
+             (make-poly-sparse 'x (list 1 2 3 2 3 6 6)))
+        (make-poly-sparse 'x (list 1 2 3 4 5 6 7)))
+(assert (mul (make-poly-sparse 'x (list 1 1))
+             (make-poly-sparse 'x (list 1 1)))
+        (make-poly-sparse 'x (list 1 2 1)))
+
+(display "\nex-2.90 - support sparse and dense polynomials\n")
+
+(define p (make-poly-dense 'x '((100 2) (1 2))))
+(display p) (newline)
+(assert (add p p) (make-poly-dense 'x '((100 4) (1 4))))
+(assert (mul p p)
+        (make-poly-dense 'x '((200 4) (101 8) (2 4))))
+
+
+(display "\nex-2.91\n")
 
 ;(display "\nex-2.92\n")