83 and 84

3 files changed, 299 insertions, 14 deletions

diff --git a/coding-exercises/2/81.rkt b/coding-exercises/2/81.rkt
index c0af5ae..4b7a108 100644
--- a/coding-exercises/2/81.rkt
+++ b/coding-exercises/2/81.rkt
@@ -107,4 +107,3 @@
          (if proc
              (apply proc (map contents args))
              (try-coerce type-tags op args))))))
-
diff --git a/coding-exercises/2/83.rkt b/coding-exercises/2/83.rkt
new file mode 100644
index 0000000..26a8ea8
--- /dev/null
+++ b/coding-exercises/2/83.rkt
@@ -0,0 +1,243 @@
+#lang racket
+(require "../../shared/data-directed-programming.rkt")
+(require "../../shared/lists.rkt")
+(require "./78/scheme-number.rkt")
+(require "./78/install-rational-package.rkt")
+(require "./78/install-complex-package.rkt")
+;; We are basically making a data directed framework for arithmethic operations in this module
+(define pkg (make-dispatch-table))
+(define put (putter pkg))
+(define get (getter pkg))
+(define print-tbl (printer pkg))
+
+
+(define coercion (make-dispatch-table))
+(define put-coercion (putter coercion))
+(define get-coercion (getter coercion))
+(define print-coercion (printer coercion))
+
+(define apply-generic (make-apply get))
+(define apply-coercion (make-apply-with-coercion get get-coercion))
+
+;; stores integers as exact racket integers
+(define (install-integer put get)
+  ;; local methods
+  (define (tagme datum)
+    (attach-tag 'integer datum))
+  (define (make i)
+    (inexact->exact (round i)))
+  (define (raiseme i)
+    (if (equal? (type-tag i) 'integer)
+      ((get 'make 'rational) i 1)
+      (error "cannot raise non integer in integer package")))
+  ;; constructor
+  (put 'make 'integer (lambda (x) (tagme (make x))))
+  ;; methods
+  (put 'add '(integer integer) (lambda (x y) (tagme (make (+ x y)))))
+  (put 'sub '(integer integer) (lambda (x y) (tagme (make (- x y)))))
+  (put 'mul '(integer integer) (lambda (x y) (tagme (make (* x y)))))
+  (put 'div '(integer integer) (lambda (x y) (tagme (make (/ x y)))))
+  (put 'raise '(integer) raiseme)
+  ;; predicates
+  (put 'equ? '(integer integer) (lambda (x y) (= x y)))
+  (put '=zero? '(integer) (lambda (x) (= 0 x)))
+  'done)
+
+;; stores rationals as custom data object
+(define (install-rational put get)
+  ;; local methods
+  (define (tagme x) (attach-tag 'rational x))
+  (define (numer x) (car x))
+  (define (denom x) (cdr x))
+  (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 (equ? x y)
+    (and (equal? (numer x) (numer y))
+         (equal? (denom x) (denom y))))
+  (define (=zero? x)
+    (equal? (numer x) 0))
+
+  (define (make-rat n d)
+    (define (sign x)
+      (cond
+        ((and (< x 0) (< d 0)) (* -1 x))
+        ((and (< 0 x) (< d 0)) (* -1 x))
+        (else x)))
+    (let ((g (gcd n d)))
+      (cons (sign (/ n g)) (abs (/ d g)))))
+
+  (define (raiseme rat)
+    ((get 'make 'real) (/ (numer rat) (denom rat))))
+
+  ;; constructor
+  (put 'make 'rational
+       (lambda (x y) (tagme (make-rat x y))))
+
+  ;; interface
+  (put 'add '(rational rational)
+       (lambda (x y) (tagme (add-rat x y))))
+  (put 'sub '(rational rational)
+       (lambda (x y) (tagme (sub-rat x y))))
+  (put 'mul '(rational rational)
+       (lambda (x y) (tagme (mul-rat x y))))
+  (put 'div '(rational rational)
+       (lambda (x y) (tagme (div-rat x y))))
+  (put 'raise '(rational) raiseme)
+
+  ;; predicates
+  (put 'equ? '(rational rational)
+       (lambda (x y) (equ? x y)))
+  (put '=zero? '(rational)
+       (lambda (x) (=zero? x)))
+  'done)
+
+;; stores reals as inexact racket numbers
+(define (install-real put get)
+  ;; local methods
+  (define (tagme datum)
+    (attach-tag 'real datum))
+  (define (make i)
+    (exact->inexact i))
+  (define (raiseme r)
+    ((get 'make-from-real-imag 'complex) r 0))
+  ;; constructor
+  (put 'make 'real (lambda (x) (tagme (make x))))
+  ;; methods
+  (put 'add '(real real) (lambda (x y) (tagme (make (+ x y)))))
+  (put 'sub '(real real) (lambda (x y) (tagme (make (- x y)))))
+  (put 'mul '(real real) (lambda (x y) (tagme (make (* x y)))))
+  (put 'div '(real real) (lambda (x y) (tagme (make (/ x y)))))
+  (put 'raise '(real) raiseme)
+  ;; predicates
+  (put 'equ? '(real real) (lambda (x y) (= x y)))
+  (put '=zero? '(real) (lambda (x) (= 0 x)))
+  'done)
+
+;; stores complex numbers as custom data type
+(install-integer put get)
+(install-rational put get)
+(install-real put get)
+;; use from previous exercise
+(install-complex-package apply-generic get put)
+
+;; test running
+;; integer
+(define (make-integer n)
+  ((get 'make 'integer) n))
+(define test-num (make-integer 3))
+
+;; rational
+(define (make-rat n d)
+  ((get 'make 'rational) n d))
+(define test-rat (make-rat 1 2))
+
+;; real
+(define (make-real n)
+  ((get 'make 'real) n))
+(define test-real (make-real 1.5))
+
+;; complex
+(define (make-complex x y)
+  ((get 'make-from-real-imag 'complex) x y))
+(define test-complex (make-complex 1 2))
+
+(define (raisetower datum)
+  (apply-coercion 'raise datum))
+
+;; ((lambda ()
+;;    (display test-num)
+;;    (newline)
+;;    (display test-rat)
+;;    (newline)
+;;    (display test-real)
+;;    (newline)
+;;    (display test-complex)
+;;    (newline)
+;;    (display (raisetower 1))
+;;    (newline)
+;;    (display (raisetower test-rat))
+;;    (newline)
+;;    (display (raisetower test-real))
+;;    (newline)))
+
+
+;; 84
+(define (type-match? args)
+  (not (find-first (lambda (x)
+                     (not (equal? (type-tag x)
+                                  (type-tag (car args)))))
+                   args)))
+(define (count-raises-until-top apply-generic datum)
+  (define (iter i raised)
+    (let ((result (apply-generic 'raise raised)))
+      (if result
+        (iter (+ i 1) result)
+        i)))
+  (iter 0 datum))
+
+
+
+(define (highest-type apply-generic items)
+  (cdr
+    (foldl
+     (lambda (raises item result)
+       (cond ((< (car result) 0) (cons raises item))
+             ((< raises (car result)) (cons raises item))
+             (else result)))
+     (cons -1 'nil)
+     (map (lambda (x)
+            (count-raises-until-top apply-generic x))
+          items)
+     (map type-tag items))))
+
+(define (raise-until apply-generic type datum)
+  (cond ((equal? type (type-tag datum)) datum)
+        (else (let ((result (apply-generic 'raise datum)))
+                (if result
+                  (raise-until apply-generic type result)
+                  false)))))
+
+(define (raise-until-type-match apply-generic type items)
+  (cond ((null? items) '())
+        (else (let ((result (raise-until apply-generic type (car items))))
+                (if result
+                  (cons result (raise-until-type-match apply-generic type (cdr items)))
+                  (error "Could not raise type --" (list type items)))))))
+
+; (raise-until-type-match (make-apply-pred get)
+;                         (highest-type (make-apply-pred get) (list 1 test-complex))
+;                         (list 1 test-complex)))))))
+
+
+(define (make-apply-with-raising apply-generic get)
+  (lambda (op . args)
+    (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-result (apply apply-generic (cons op raised-args))))
+            (if raised-result
+               raised-result
+               (error "Could not apply --" (list op args raised-args)))))))))
+
+(define apply-with-raising (make-apply-with-raising (make-apply-pred get) get))
+((lambda ()
+   (newline)
+   (apply-with-raising 'add 1 test-complex)))
+
+;; 85
+;; lowerable?
+(define (project datum)
+  datum)
diff --git a/shared/data-directed-programming.rkt b/shared/data-directed-programming.rkt
index 603d4d7..2edf4d5 100644
--- a/shared/data-directed-programming.rkt
+++ b/shared/data-directed-programming.rkt
@@ -1,6 +1,7 @@
 #lang racket
 (provide
   make-apply-with-coercion
+  make-apply-pred
   make-apply
   make-dispatch-table
   printer
@@ -12,27 +13,20 @@
   find-type)
 (require "./lists.rkt")
 
-(define (make-apply-with-coercion get get-coercion)
-  (lambda (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)))))))
-
-
 ;; Type tagged data
 (define (attach-tag type-tag contents)
-  (cond ((number? contents) contents)
+  (cond ((exact-integer? contents) contents)
+        ((inexact-real? contents) contents)
+        ((number? contents) contents)
         ((symbol? contents) contents)
         (else (cons type-tag contents))))
 (define (type-tag datum)
   (cond
     ((pair? datum) (car datum))
-    ((number? datum) 'scheme-number)
     ((symbol? datum) 'symbol)
+    ((exact-integer? datum) 'integer)
+    ((inexact-real? datum) 'real)
+    ((number? datum) 'scheme-number)
     (else (error "Bad tagged datum -- TYPE-TAG" datum))))
 (define (contents datum)
   (cond
@@ -107,3 +101,52 @@
              "No method for these types -- APPLY-GENERIC"
              (list op type-tags)))))))
 
+(define (make-apply-pred 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)
+       ;; (display args)
+       (let ((type-tags (map type-tag args)))
+         (let ((proc (get op type-tags)))
+           (if proc
+             (apply proc (map contents args))
+             false)))))
+  (define apply-generic (make-apply get))
+
+  ;; try to coerce all arguments to a type
+  (define (coerce-or-fail t args)
+    (define (iter coerced remaining-args)
+      (cond ((null? remaining-args) coerced)
+            ((equal? t (type-tag (car remaining-args)))
+             (append coerced (car remaining-args)))
+            (else (let ((t->arg (get-coercion t (type-tag (car remaining-args)))))
+                   (if t->arg
+                     (append coerced (t->arg t))
+                     false)))))
+    (iter '() args))
+
+  ;; try to coerce all arguments to the type of one them
+  (define (try-coerce type-tags op args)
+    (define (iter havent-tried)
+      (if (null? havent-tried)
+        (error "no method for these types --" (list op type-tags))
+        (let ((coerced-args (coerce-or-fail (type-tag (car havent-tried)) args)))
+          (if coerced-args
+            (apply apply-generic (cons op coerced-args))
+            (iter (cdr havent-tried))))))
+    (iter type-tags))
+
+  (lambda (op . args)
+     ;; (display args)
+     (let ((type-tags (map type-tag args)))
+       (let ((proc (get op type-tags)))
+         (if proc
+             (apply proc (map contents args))
+             (try-coerce type-tags op args))))))