bugs

4 files changed, 157 insertions, 40 deletions

diff --git a/coding-exercises/2/78/install-complex-package.rkt b/coding-exercises/2/78/install-complex-package.rkt
index a99b7d5..e332351 100644
--- a/coding-exercises/2/78/install-complex-package.rkt
+++ b/coding-exercises/2/78/install-complex-package.rkt
@@ -42,7 +42,7 @@
     (and (= (real-part z1) (real-part z2))
          (= (imag-part z1) (imag-part z2))))
   (define (=zero? z)
-    (and (= (real-part z)) (= (imag-part z))))
+    (and (= (real-part z) 0) (= (imag-part z) 0)))
 
   ;; interface
   (define (typetag z) (attach-tag 'complex z))
diff --git a/coding-exercises/2/83/install.rkt b/coding-exercises/2/83/install.rkt
index 109862e..0cd8bbf 100644
--- a/coding-exercises/2/83/install.rkt
+++ b/coding-exercises/2/83/install.rkt
@@ -11,7 +11,21 @@
          make-complex-rect
          test-complex-rect
          make-complex-polar
-         test-complex-polar)
+         test-complex-polar
+         =zero?
+         equ?
+         add
+         sub
+         mul
+         div
+         sinme
+         cosme
+         atanme
+         sqrme
+         sqrtme
+         raiseme
+         dropme)
+
 (require "./install-integer.rkt"
          "./install-rational.rkt"
          "./install-real.rkt"
@@ -34,7 +48,7 @@
 (define (install-arithmetic-package)
   (list get put apply-fn))
 
-;; test running
+;; constructors
 ;; integer
 (define (make-integer n)
   ((get 'make 'integer) n))
@@ -60,3 +74,35 @@
 (define test-complex (make-complex 1 2))
 (define test-complex-rect (make-complex-rect 1 2))
 (define test-complex-polar (make-complex-rect 1 2))
+
+;; polynomial
+(define (make-polynomial var terms)
+  ((get 'make 'polynomial) var terms))
+
+;; generic methods
+(define (equ? a1 a2)
+  (apply-fn 'equ? a2))
+(define (=zero? datum)
+  (apply-fn '=zero? datum))
+(define (add a1 a2)
+  (apply-fn 'add a1 a2))
+(define (sub a1 a2)
+  (apply-fn 'sub a1 a2))
+(define (mul a1 a2)
+  (apply-fn 'mul a1 a2))
+(define (div a1 a2)
+  (apply-fn 'div a1 a2))
+(define (raiseme datum)
+  (apply-fn 'raise datum))
+(define (dropme datum)
+  (apply-fn 'project datum))
+(define (sqrme datum)
+  (apply-fn 'sqr datum))
+(define (sqrtme datum)
+  (apply-fn 'sqrt datum))
+(define (cosme datum)
+  (apply-fn 'cos datum))
+(define (sinme datum)
+  (apply-fn 'sin datum))
+(define (atanme a1 a2)
+  (apply-fn 'atan a2))
diff --git a/coding-exercises/2/87.rkt b/coding-exercises/2/87.rkt
index 6c2a3f6..d73093e 100644
--- a/coding-exercises/2/87.rkt
+++ b/coding-exercises/2/87.rkt
@@ -1,4 +1,5 @@
 #lang racket
+(require "../../shared/data-directed-programming.rkt")
 (require "./83/install.rkt")
 ;; arithmetic package
 (define get-put-apply (install-arithmetic-package))
@@ -10,35 +11,96 @@
   ;; internal procedures
   (define (tagme p)
     (attach-tag 'polynomial p))
-  ;;repr
+  (define (variable? x) (symbol? x))
+  (define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y)))
+
+  ;; terms
+  (define (make-term order coeff) (list order coeff))
+  (define (order term) (car term))
+  (define (coeff term) (cadr term))
+
+  ;; termlists
+  (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))
+
+  ;; polys
   (define (make-poly variable term-list)
     (cons variable term-list))
   (define (variable p) (car p))
   (define (term-list p) (cdr p))
-  ;; preds
-  (define (variable? x) (symbol? x))
-  (define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y)))
-  ;; term list
-  (define (adjoin-term term-list term)
-    '())
-  (define (coeff term)
-    '())
+
   ;; ops
+  (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 t2)
+                        (order t1))
+                     (adjoin-term
+                       t2 (add-terms L1 (rest-terms L2))))
+                    (else
+                      (adjoin-term
+                        (make-term
+                          (order t1)
+                          (apply-fn '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 (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-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-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)))))
-  ;; interface)
-
-
-
+      (error "Polys not in same var -- MUL-POLY" (list p1 p2))))
+  ;;interface
+  (put 'add '(polynomial polynomial) (lambda (p1 p2) (tagme (add-poly p1 p2))))
+  (put 'mul '(polynomial polynomial) (lambda (p1 p2) (tagme (mul-poly p1 p2))))
+  (put 'make 'polynomial
+       (lambda (var terms) (tagme (make-poly var terms))))
+  'done)
 
+(install-polynomial-package put)
+(define (make-polynomial var terms)
+  ((get 'make 'polynomial) var terms))
+(define test-poly1 (make-polynomial 'x (list
+                                         (list 1 test-integer))))
+(define test-poly2 (make-polynomial 'x (list
+                                         (list 100 test-complex)
+                                         (list 3 test-real)
+                                         (list 1 test-rat)
+                                         (list 0 test-integer))))
+((lambda ()
+   (newline)
+   (display (add test-poly2 test-poly2))))
diff --git a/shared/data-directed-programming.rkt b/shared/data-directed-programming.rkt
index abaa498..4b4762c 100644
--- a/shared/data-directed-programming.rkt
+++ b/shared/data-directed-programming.rkt
@@ -28,6 +28,7 @@
     ((exact-integer? datum) 'integer)
     ((inexact-real? datum) 'real)
     ((number? datum) 'scheme-number)
+    ((boolean? datum) 'boolean)
     (else (error "Bad tagged datum -- TYPE-TAG" datum))))
 (define (contents datum)
   (cond
@@ -109,6 +110,14 @@
            (apply proc (map contents args))
            false)))))
 
+(define (make-apply-pred-symbol get)
+  (lambda (op . args)
+     (let ((type-tags (map type-tag args)))
+       (let ((proc (get op type-tags)))
+         (if proc
+           (apply proc (map contents args))
+           false)))))
+
 (define (make-apply-with-coercion get get-coercion)
   (define (make-apply get)
     (lambda (op . args)
@@ -157,15 +166,15 @@
                      (not (equal? (type-tag x)
                                   (type-tag (car args)))))
                    args)))
-(define (count-raises-until-top apply-pred datum)
+(define (count-raises-until-top get datum)
   (define (iter i raised)
-    (let ((result (apply-pred 'raise raised)))
-      (if result
-        (iter (+ i 1) result)
+    (let ((proc (get 'raise (list (type-tag raised)))))
+      (if proc
+        (iter (+ i 1) (proc (contents raised)))
         i)))
   (iter 0 datum))
 
-(define (highest-type apply-pred items)
+(define (highest-type get items)
   (cdr
     (foldl
      (lambda (raises item result)
@@ -174,22 +183,22 @@
              (else result)))
      (cons -1 'nil)
      (map (lambda (x)
-            (count-raises-until-top apply-pred x))
+            (count-raises-until-top get x))
           items)
      (map type-tag items))))
 
-(define (raise-until apply-pred type datum)
+(define (raise-until get type datum)
   (cond ((equal? type (type-tag datum)) datum)
-        (else (let ((result (apply-pred 'raise datum)))
-                (if result
-                  (raise-until apply-pred type result)
+        (else (let ((proc (get 'raise (list (type-tag datum)))))
+                (if proc
+                  (raise-until get type (proc (contents datum)))
                   false)))))
 
-(define (raise-until-type-match apply-pred type items)
+(define (raise-until-type-match get type items)
   (cond ((null? items) '())
-        (else (let ((result (raise-until apply-pred type (car items))))
+        (else (let ((result (raise-until get type (car items))))
                 (if result
-                  (cons result (raise-until-type-match apply-pred type (cdr items)))
+                  (cons result (raise-until-type-match get type (cdr items)))
                   (error "Could not raise type --" (list type items)))))))
 
 ; (raise-until-type-match (make-apply-pred get)
@@ -202,15 +211,14 @@
     (let ((result (apply apply-generic (cons op args))))
       (if result
         result
-        (let ((raised-args (raise-until-type-match apply-generic (highest-type apply-generic args) args)))
+        (let ((raised-args (raise-until-type-match get (highest-type get args) args)))
           (let ((raised-result (apply apply-generic (cons op raised-args))))
             (if raised-result
                raised-result
                (error "Could not apply --" (list op args raised-args)))))))))
 
 (define (make-apply-with-raising-and-drop get)
-  (define apply-pred (make-apply-pred get))
-
+  (define apply-pred (make-apply get))
   (define (raisetower datum)
     (apply-pred 'raise datum))
 
@@ -223,6 +231,7 @@
   (define (can-drop? datum)
     (equ? (raisetower (project datum))
           datum))
+
   (define (towerdrop datum)
     (cond ((and (get 'project (list (type-tag datum)))
                 (can-drop? datum))
@@ -230,11 +239,11 @@
           (else datum)))
 
   (lambda (op . args)
-    (let ((result (apply apply-pred (cons op args))))
-      (if result
-        (towerdrop result)
-        (let ((raised-args (raise-until-type-match apply-pred (highest-type apply-pred args) args)))
-          (let ((raised-result (apply apply-pred (cons op raised-args))))
-            (if raised-result
-               (towerdrop raised-result)
+    (let ((proc (get op (map type-tag args))))
+      (if proc
+        (towerdrop (apply proc (map contents args)))
+        (let ((raised-args (raise-until-type-match get (highest-type get args) args)))
+          (let ((raised-proc (get op (map type-tag raised-args))))
+            (if raised-proc
+               (towerdrop (apply raised-proc (map contents raised-args)))
                (error "Could not apply --" (list op args raised-args)))))))))