82 is not tested but meh

1 files changed, 110 insertions, 0 deletions

diff --git a/coding-exercises/2/81.rkt b/coding-exercises/2/81.rkt
new file mode 100644
index 0000000..c0af5ae
--- /dev/null
+++ b/coding-exercises/2/81.rkt
@@ -0,0 +1,110 @@
+#lang racket
+(require "../../shared/data-directed-programming.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))
+
+(install-scheme-number-package put)
+(install-rational-package put)
+(install-complex-package apply-generic get put)
+
+;; 81
+;;a
+;; type-tags are '(complex complex)
+;; proc is false because exp is only defined for '(scheme-number scheme-number)
+;; type1 and type2 are both 'complex
+;; a1 a2 should be the complex tagged data
+;; So now we are getting coercions, Louis' coercions of complex->complex and scheme-number->scheme-number are installed.
+;; Louis' coercion complex->complex are also the only option for t1->t2 and t2->t1
+;; This means that (apply-generic 'exp a1 a2) is called again, and we start over again from the beginning in a loop.
+;;b
+;; He is mistaken.
+;; If there is no procedure for the two arguments with the same type, then coercing the type to itself will not change the result of the lookup in the dispatch table.
+;;c
+(define (make-apply-with-coercion get get-coercion)
+  (lambda (op . args)
+     (display args)
+     (let ((type-tags (map type-tag args)))
+       (let ((proc (get op type-tags)))
+         (cond (proc
+                 (apply proc (map contents args)))
+               ((and (not (equal? (car type-tags)
+                                  (cadr type-tags)))
+                     (= (length args) 2))
+                (let ((type1 (car type-tags))
+                      (type2 (cadr type-tags))
+                      (a1 (car args))
+                      (a2 (cadr args)))
+                  (let ((t1->t2 (get-coercion type1 type2))
+                        (t2->t1 (get-coercion type2 type1)))
+                    (cond (t1->t2
+                            (apply-generic op (t1->t2 a1) a2))
+                          (t2->t1
+                            (apply-generic op a1 (t2->t1 a2)))
+                          (else
+                            (error "No method for these types" (list op type-tags)))))))
+               (else (error "No method for these types -- APPLY-GENERIC"
+                            (list op type-tags))))))))
+
+(define (scheme-number->scheme-number n) n)
+(define (complex->complex z) z)
+(put-coercion 'scheme-number 'scheme-number scheme-number->scheme-number)
+(put-coercion 'complex 'complex complex->complex)
+(define (ex x y) (apply-generic 'exp x y))
+(put 'exp '(scheme-number scheme-number) (lambda (x y) (attach-tag 'scheme-number (expt x y))))
+(define apply-generic-with-coercion (make-apply-with-coercion get get-coercion))
+
+;; no method and no infinite recursion
+;; (apply-generic-with-coercion 'exp ((get 'make-from-real-imag 'complex) 10 2) ((get 'make-from-real-imag 'complex) 10 3))
+
+;; 82
+;; So in the tower of types (numbers, rationals, reals, complex) of the arithmetic package this method covers most cases?
+;; Because we can always coerce the lower arguments to the argument with the highest type.
+;;
+;; The cases that are not covered are for example ones where only a subset of the arguments needs to be coerced to find a suitable mixed type method, since we always coerce all arguments in this strategy.
+(define (make-apply-with-coercion-args get get-coercion)
+
+  ;; 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))))))
+