83 and 84

2 files changed, 243 insertions, 1 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)