Get negate working for numbers (includes lots of debugging)

2_78.rkt

@@ -105,21 +105,54 @@
          (proc (get op type-tags))
          (result
           (if proc
-              (apply proc (map contents args))
+              (begin
+                (display "Applying ")
+                (display (list op args))
+                (newline)
+                (apply proc (map contents args)))
               (if (> (length args) 1)
                   (let ((coerced-args (coerce-args args type-tags)))
                     (if (not (null? coerced-args))
-                        (apply apply-generic (cons op coerced-args))
+                        (begin
+                          (display "Applying with coerced args ")
+                          (display (list op coerced-args))
+                          (newline)
+                          (apply apply-generic (cons op coerced-args)))
                         (error "Can't coerce arguments to a common type"
                                (list op type-tags))))
-                  (error "Too few args")))))
+                  (error "No matching operator for args" op args)))))
     (if (and (pair? result)
              (not (or (eq? op 'raise)
-                      (eq? op 'lower))))
-        (drop result)
-        result)))
+                      (eq? op 'project)
+                      (eq? op 'real-part)
+                      (eq? op 'imag-part)
+                      (eq? op 'angle)
+                      (eq? op 'magnitude))))
+        (begin
+          (display "Drop ")
+          (display result)
+          (newline)
+          (drop result))
+        (begin
+          (display "Result ")
+          (display result)
+          (newline)
+          result))))
 
 
+(define (attach-tag type-tag contents)
+  (cons type-tag contents))
+
+(define (type-tag datum)
+  (cond ((pair? datum) (car datum))
+        (else (error "Bad tagged datum -- TYPE-TAG" datum))))
+
+(define (contents datum)
+  (cond ((pair? datum) (cdr datum))
+        (else (error "Bad tagged datum -- CONTENTS" datum))))
+
+(define type-tagged? pair?)
+
 ;; Scheme numbers
 
 (define (install-scheme-number-package)
@@ -136,6 +169,8 @@
        (lambda (x y) (tag (* x y))))
   (put 'div '(scheme-number scheme-number)
        (lambda (x y) (tag (/ x y))))
+  (put 'negate '(scheme-number)
+       (lambda (x) (* -1 x)))
   (put 'equ? '(scheme-number scheme-number) =)
   (put '=zero? '(scheme-number)
        (lambda (x) (= x 0)))
@@ -156,9 +191,17 @@
   (put 'add '(integer integer)
        (lambda (x y)
          (make-integer (+ x y))))
+  (put 'sub '(integer integer)
+       (lambda (x y)
+         (make-integer (- x y))))
+  (put 'div '(integer integer)
+       (lambda (x y)
+         (make-integer (/ x y))))
   (put 'mul '(integer integer)
        (lambda (x y)
          (make-integer (* x y))))
+  (put 'negate '(integer)
+       (lambda (x) (* -1 x)))
   (put 'sine '(integer)
        (lambda (x) (sine (raise-int x))))
   (put 'cosine '(integer)
@@ -187,9 +230,18 @@
   (put 'add '(real real)
        (lambda (x y)
          (make-real (+ x y))))
+  (put 'sub '(real real)
+       (lambda (x y)
+         (make-real (- x y))))
   (put 'mul '(real real)
        (lambda (x y)
          (make-real (* x y))))
+  (put 'div '(real real)
+       (lambda (x y)
+         (make-real (/ x y))))
+  (put 'negate '(real)
+       (lambda (x)
+         (make-real (* -1 x))))
   (put 'sine '(real)
        (lambda (x) (make-real (sin x))))
   (put 'cosine '(real)
@@ -202,7 +254,7 @@
        (lambda (x y)
          (= x y)))
   (put 'raise '(real)
-       (lambda (x) (make-complex-from-real-imag x 0)))
+       (lambda (x) (make-complex-from-real-imag (make-real x) (make-real 0))))
   (put 'project '(real)
        (lambda (x) (make-rational
                     (round (* x 1000))
@@ -251,6 +303,9 @@
        (lambda (x y) (tag (mul-rat x y))))
   (put 'div '(rational rational)
        (lambda (x y) (tag (div-rat x y))))
+  (put 'negate '(rational)
+       (lambda (x)
+         (make-rational (* -1 (numer x)) (denom x))))
   (put 'sine '(rational)
        (lambda (x) (sine (raise-rat x))))
   (put 'cosine '(rational)
@@ -262,7 +317,7 @@
                              (raise-rat y))))
   (put 'equ? '(rational rational) eq-rat)
   (put '=zero? '(rational)
-       (lambda (x) (= (numer x) 0)))
+       (lambda (x) (equ? (numer x) (make-integer 0))))
   (put 'raise '(rational) raise-rat)
   (put 'project '(rational)
        (lambda (x)
@@ -291,6 +346,10 @@
   (define (make-from-mag-ang r a) 
     (cons (mul r (cosine a))
           (mul r (sine a))))
+  (define (negate z)
+    (make-from-real-imag
+     (mul (make-real -1) (real-part z))
+     (mul (make-real -1) (imag-part z))))
 
   ;; interface to the rest of the system
   (define (tag x) (attach-tag 'rectangular x))
@@ -298,6 +357,10 @@
   (put 'imag-part '(rectangular) imag-part)
   (put 'magnitude '(rectangular) magnitude)
   (put 'angle '(rectangular) angle)
+  (put 'negate '(rectangular)
+       (lambda (z) (tag (negate z))))
+  ;;(put 'project '(rectangular)
+   ;;    (lambda (z) (real-part z)))
   (put 'make-from-real-imag 'rectangular
        (lambda (x y) (tag (make-from-real-imag x y))))
   (put 'make-from-mag-ang 'rectangular
@@ -316,6 +379,11 @@
   (define (make-from-real-imag x y) 
     (cons (square-root (add (square x) (square y)))
           (arctan y x)))
+  (define pi (make-real (* 2 (asin 1)))) 
+  (define (negate z)
+    (make-from-mag-ang
+     (magnitude z)
+     (add pi (angle z))))
 
   ;; interface to the rest of the system
   (define (tag x) (attach-tag 'polar x))
@@ -323,6 +391,10 @@
   (put 'imag-part '(polar) imag-part)
   (put 'magnitude '(polar) magnitude)
   (put 'angle '(polar) angle)
+  (put 'negate '(polar)
+       (lambda (z) (tag (negate z))))
+  ;;(put 'project '(polar)
+       ;;(lambda (z) real-part z))
   (put 'make-from-real-imag 'polar
        (lambda (x y) (tag (make-from-real-imag x y))))
   (put 'make-from-mag-ang 'polar
@@ -338,17 +410,17 @@
     ((get 'make-from-mag-ang 'polar) r a))
   ;; internal procedures
   (define (add-complex z1 z2)
-    (make-from-real-imag (+ (real-part z1) (real-part z2))
-                         (+ (imag-part z1) (imag-part 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 (- (real-part z1) (real-part z2))
-                         (- (imag-part z1) (imag-part 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 (* (magnitude z1) (magnitude z2))
-                       (+ (angle z1) (angle z2))))
+    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
+                       (add (angle z1) (angle z2))))
   (define (div-complex z1 z2)
-    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
-                       (- (angle z1) (angle z2))))
+    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
+                       (sub (angle z1) (angle z2))))
 
   ;; interface to rest of the system
   (define (tag z) (attach-tag 'complex z))
@@ -364,17 +436,26 @@
        (lambda (z1 z2) (tag (div-complex z1 z2))))
   (put 'equ? '(complex complex)
        (lambda (z1 z2)
-         (and (= (real-part z1) (real-part z2))
-              (= (imag-part z1) (imag-part z2)))))
+         (and (equ? (real-part z1) (real-part z2))
+              (equ? (imag-part z1) (imag-part z2)))))
   (put '=zero? '(complex)
-       (lambda (z) (= (magnitude z) 0)))
+       (lambda (z) (equ? (magnitude z) (make-real 0))))
+  ;;(put 'negate '(complex)
+       ;;(lambda (z) (tag (negate z))))
+  (put 'negate '(complex)
+       (lambda (z)
+         (tag
+          (make-from-real-imag
+           (mul (real-part z) (make-real -1))
+           (mul (imag-part z) (make-real -1))))))
+         
   (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 'project '(complex)
        (lambda (z)
-         (make-real (real-part z))))
+         (real-part z)))
   'done)
 
 ;; *incomplete* skeleton of package
@@ -460,6 +541,13 @@
         (error "Polys not in same var -- MUL-POLY"
                (list p1 p2))))
 
+  (define (=zero-poly? p)
+    (let ((terms (term-list p)))
+      (if (null? terms)
+          #t
+          (and (= (coeff (first-term terms)) 0)
+               (=zero-poly? (rest-terms terms))))))
+
   ;; interface to rest of the system
   (define (tag p) (attach-tag 'polynomial p))
   (put 'add '(polynomial polynomial) 
@@ -519,6 +607,7 @@
 (define (cosine x) (apply-generic 'cosine x))
 (define (square-root x) (apply-generic 'square-root x))
 (define (arctan x y) (apply-generic 'arctan x y))
+(define (negate x) (apply-generic 'negate x))
 (define (square x) (mul x x))
 
 (define (equ? x y) (apply-generic 'equ? x y))
@@ -533,10 +622,24 @@
 (define (drop x)
   (and (type-tagged? x)
        (let ((p (project x)))
-         (cond ((null? p) x)
-               ((equ? x (raise p))
-                (drop p))
-               (else x)))))
+         (begin
+           (display "drop: ")
+           (display x)
+           (newline)
+           (cond ((null? p)
+                  (display "drop: p Null ")
+                  (newline)
+                  x)
+                 ((equ? x (raise p))
+                  (display "drop: x equal to raise p, dropping ")
+                  (display p)
+                  (newline)
+                  (drop p))
+                 (else
+                  (display "drop: returning ")
+                  (display x)
+                  (newline)
+                  x))))))
 
 (install-scheme-number-package)
 (install-integer-package)
@@ -549,19 +652,6 @@
 
 
 
-(define (attach-tag type-tag contents)
-  (cons type-tag contents))
-
-(define (type-tag datum)
-  (cond ((pair? datum) (car datum))
-        (else (error "Bad tagged datum -- TYPE-TAG" datum))))
-
-(define (contents datum)
-  (cond ((pair? datum) (cdr datum))
-        (else (error "Bad tagged datum -- CONTENTS" datum))))
-
-(define type-tagged? pair?)
-
 ;; Coercion
 
 
@@ -590,3 +680,7 @@
 ;; It isn't possible to coerce from one to the other, so a mixed-type operator is needed, and this
 ;; approach would fail.
 
+
+
+
+