section 3.3 done

3 files changed, 475 insertions, 0 deletions

diff --git a/coding-exercises/3/24.rkt b/coding-exercises/3/24.rkt
new file mode 100644
index 0000000..1929bed
--- /dev/null
+++ b/coding-exercises/3/24.rkt
@@ -0,0 +1,71 @@
+#lang racket
+(require compatibility/mlist)
+
+(define (make-2d-table same-key?)
+  (let ((local-table (mlist '*table*)))
+    (define (assoc key records)
+      (cond ((null? records) false)
+            ((same-key? key (mcar (mcar records))) (mcar records))
+            (else (assoc key (mcdr records)))))
+    (define (lookup key-1 key-2)
+      (let ((subtable (assoc key-1 (mcdr local-table))))
+        (if subtable
+          (let ((record (assoc key-2 (mcdr subtable))))
+            (if record
+              (mcdr record)
+              false))
+          false)))
+    (define (insert! key-1 key-2 value)
+      (let ((subtable (assoc key-1 (mcdr local-table))))
+        (if subtable
+          (let ((record (assoc key-2 (mcdr subtable))))
+            (if record
+              (set-mcdr! record value)
+              (set-mcdr! subtable
+                         (mcons (mcons key-2 value)
+                                (mcdr subtable)))))
+          (set-mcdr! local-table
+            (mcons (mlist key-1 (mcons key-2 value)) (mcdr local-table)))))
+      'ok)
+    (define (dispatch m)
+      (cond ((eq? m 'lookup-proc) lookup)
+            ((eq? m 'insert-proc) insert!)
+            (else (error "Unknown operation -- TABLE" m))))
+    dispatch))
+(define tbl (make-2d-table (lambda (a b) (equal? a b))))
+((tbl 'insert-proc) 'test 'message "hi")
+((tbl 'lookup-proc) 'test 'message)
+
+(define (make-general-table same-key?)
+  (let ((local-table (mlist '*table*)))
+    (define (assoc key records)
+      (cond ((null? records) false)
+            ((same-key? key (mcar (mcar records))) (mcar records))
+            (else (assoc key (mcdr records)))))
+    (define (lookup keys) (mcdr (foldl (lambda (key tbl) (assoc key (mcdr tbl))) local-table keys)))
+    (define (insert! keys value)
+      (set-mcdr!
+       (foldl (lambda (key tbl)
+                (let ((subtable (assoc key (mcdr tbl))))
+                  (if subtable
+                    subtable
+                    (let ((empty-record (mlist key)))
+                      (set-mcdr! tbl (mcons empty-record (mcdr tbl)))
+                      empty-record))))
+             local-table
+             keys)
+       value)
+      'ok)
+    (define (dispatch m)
+      (cond ((eq? m 'lookup-proc) lookup)
+            ((eq? m 'insert-proc) insert!)
+            (else (error "Unknown operation -- TABLE" m))))
+    dispatch))
+(define gentbl (make-general-table (lambda (a b) (equal? a b))))
+((gentbl 'insert-proc) '(test message) "hi")
+((gentbl 'lookup-proc) '(test message))
+
+;; Example table could be represented as a binary tree on the keys
+;;  '((B value) (((A value) () ()))
+;;              (((C value) () ())))
+;; The insert and lookup procedure can then just be implemented using the element-of-set? and adjoin-set methods if the entry selector is adjusted for the (key value) format
diff --git a/coding-exercises/3/28.rkt b/coding-exercises/3/28.rkt
new file mode 100644
index 0000000..f954452
--- /dev/null
+++ b/coding-exercises/3/28.rkt
@@ -0,0 +1,148 @@
+#lang racket
+(define (get-signal wire)
+    (print "setsig"))
+(define (set-signal! wire))
+(define (add-action! wire cb))
+
+(define (after-delay n f) (print "delay") (println n) (f))
+
+(define (logical-and a1 a2)
+    (and (= 1 a1) (= 1 a2)))
+
+(define (logical-or a1 a2)
+    (or (= 1 a1) (= 1 a2)))
+
+(define (logical-not s)
+    (cond ((= 0 s) 1)
+          ((= 1 s) 0)
+          (else (error "Invalid signal" s))))
+
+(define (inverter input output)
+    (define (invert-input)
+        (let ((new-value (logical-not input)))
+            (after-delay inverter-delay (lambda ()
+                                            (set-signal! output new-value)))))
+    (add-action! input invert-input)
+    'ok)
+
+(define (and-gate i1 i2 output)
+    (define (and-action-procedure)
+        (let ((value (logical-and (get-signal a1) (get-signal a2))))
+            (after-delay and-gate-delay
+                         (lambda ()
+                             (set-signal! output value)))))
+    (add-action! i1 and-action-procedure)
+    (add-action! i2 and-action-procedure)
+    'ok)
+
+(define (or-gate i1 i2 output)
+    (define (or-action)
+        (let ((value (logical-or (get-signal i1) (get-signal i2))))
+            (after-delay or-gate-delay (lambda () (set-signal! output value)))))
+    (add-action! i1 or-action)
+    (add-action! i2 or-action)
+    'ok)
+
+(define (half-adder a b s c)
+    (let ((d (make-wire))
+          (e (make-wire)))
+        (or-gate a b d)
+        (and-gate a b c)
+        (inverter c e)
+        (and-gate d e s)
+        'ok))
+
+(define (full-adder a b c-in sum c-out)
+    (let ((s (make-wire))
+          (c1 (make-wire))
+          (c2 (make-wire)))
+        (half-adder b c-in s c1)
+        (half-adder a s sum c2)
+        (or-gate c1 c2 c-out)
+        'ok))
+
+;; n * full-adder <=>
+;; n * ( 2 * half-adder + or-gate) <=>
+;; n * ( 2 * and-gate + or-gate)
+(define (ripple-carry-adder A B S C)
+    (cond
+     ((or (null? A) (null? B)) S)
+     (else (let ((carry-out (make-wire)))
+             (full-adder (car A) (car B) C (car S) carry-out)
+             (ripple-carry-adder (cdr A) (cdr B) (cdr S) carry-out)))))
+
+(define (call-each procedures)
+    (if (null? procedures)
+        'done
+        (begin
+         ((car procedures))
+         (call-each (cdr procedures)))))
+
+(define (make-wire)
+    (let ((signal-value 0) (action-procedures '()))
+        (define (set-my-signal! new-value)
+            (if (not (= signal-value new-value))
+                (begin (set! signal-value new-value)
+                       (call-each action-procedures))
+                'done))
+        (define (accept-action-procedure! proc)
+            (set! action-procedures (cons proc action-procedures))
+            (proc))
+        (define (dispatch m)
+            (cond ((eq? m 'get-signal) signal-value)
+                  ((eq? m 'set-signal!) set-my-signal!)
+                  ((eq? m 'add-action!) accept-action-procedure!)
+                  (else (error "Unknown operation -- WIRE" m))))
+        dispatch))
+
+(define (get-signal wire)
+    (wire 'get-signal))
+(define (set-signal! wire)
+    ((wire 'set-signal) new-value))
+(define (add-action! wire action-procedure)
+    ((wire 'add-action!) action-procedure))
+
+(define (after-delay d action)
+    (add-to-agenda! (+ d (current-time the-agenda))
+                    action
+                    the-agenda))
+
+(define (propagate)
+    (if (empty-agenda? the-agenda)
+        'done
+        (let ((first-item (first-agenda-item the-agenda)))
+            (first-item)
+            (remove-first-agenda-item! the-agenda)
+            (propagate))))
+
+(define (probe name wire)
+    (add-action! wire
+                 (lambda ()
+                     (newline)
+                     (display name)
+                     (display " ")
+                     (display (current-time the-agenda))
+                     (display " New-value = ")
+                     (display (get-signal wire)))))
+
+(define the-agenda (make-agenda))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(probe 'sum sum)
+(probe 'carry carry)
+
+(half-adder input-1 input-2 sum carry)
+(set-signal! input-1 1)
+(propagate)
+
+(set-signal! input-2 1)
+(propagate)
+
+;; e needs to be 1 in the system to make it work correct.
+;; You can try to draw how the agenda would execute the assignments to a b c d and e.
diff --git a/coding-exercises/3/33.rkt b/coding-exercises/3/33.rkt
new file mode 100644
index 0000000..b8b2f25
--- /dev/null
+++ b/coding-exercises/3/33.rkt
@@ -0,0 +1,256 @@
+#lang racket
+
+(define (inform-about-value constraint) (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint) (constraint 'I-lost-my-value))
+
+(define (has-value? connector) (connector 'has-value?))
+(define (get-value connector) (connector 'value))
+(define (set-value! connector new-value informant) ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor) ((connector 'forget) retractor))
+(define (connect connector new-constraint) ((connector 'connect) new-constraint))
+
+
+(define (for-each-except q f list)
+    (define (loop items)
+        (cond ((null? items) 'done)
+              ((eq? q (car items)) (loop (cdr items)))
+              (else (f (car items))
+                    (loop (cdr items)))))
+    (loop list))
+
+(define (make-connector)
+    (let ((value false)
+          (informant false)
+          (constraints '()))
+        (define (set-my-value newval setter)
+            (cond ((not (has-value? me))
+                   (set! value newval)
+                   (set! informant setter)
+                   (for-each-except setter
+                                    inform-about-value
+                                    constraints))
+                  ((not (= value newval))
+                   (error "Contradiction" (list value newval)))
+                  (else 'ignored)))
+        (define (forget-my-value retractor)
+            (if (eq? retractor informant)
+                (begin (set! informant false)
+                       (for-each-except retractor
+                                        inform-about-no-value
+                                        constraints))
+                'ignored))
+        (define (connect new-constraint)
+            (when (not (memq new-constraint constraints))
+                (set! constraints
+                      (cons new-constraint constraints)))
+            (when (has-value? me)
+                (inform-about-value new-constraint))
+            'done)
+        (define (me request)
+            (cond ((eq? request 'has-value?)
+                   (if informant true false))
+                  ((eq? request 'value) value)
+                  ((eq? request 'set-value!) set-my-value)
+                  ((eq? request 'forget) forget-my-value)
+                  ((eq? request 'connect) connect)
+                  (else (error "Unknown operation -- CONNECTOR" request))))
+        me))
+
+(define (constant value connector)
+    (define (me request)
+        (error "Unknown request -- CONSTANT" request))
+    (connect connector me)
+    (set-value! connector value me)
+    me)
+
+(define (probe name connector)
+    (define (print-probe value)
+        (newline)
+        (display "Probe: ")
+        (display name)
+        (display " = ")
+        (display value))
+    (define (process-new-value)
+        (print-probe (get-value connector)))
+    (define (process-forget-value)
+        (print-probe "?"))
+    (define (me request)
+        (cond ((eq? request 'I-have-a-value)
+               (process-new-value))
+              ((eq? request 'I-lost-my-value)
+               (process-forget-value))
+              (else (error "Unknown request -- PROBE" request))))
+    (connect connector me)
+    me)
+
+(define (multiplier m1 m2 product)
+    (define (process-new-value)
+        (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+                   (and (has-value? m2) (= (get-value m2) 0)))
+               (set-value! product 0 me))
+              ((and (has-value? m1) (has-value? m2))
+               (set-value! product
+                           (* (get-value m1) (get-value m2))
+                           me))
+              ((and (has-value? product) (has-value? m1))
+               (set-value! m2
+                           (/ (get-value product) (get-value m1))
+                           me))
+              ((and (has-value? product) (has-value? m2))
+               (set-value! m1
+                           (/ (get-value product) (get-value m2))
+                           me))))
+    (define (process-forget-value)
+        (forget-value! product me)
+        (forget-value! m1 me)
+        (forget-value! m2 me)
+        (process-new-value))
+    (define (me request)
+        (cond ((eq? request 'I-have-a-value)
+               (process-new-value))
+              ((eq? request 'I-lost-my-value)
+               (process-forget-value))
+              (else (error "Unknown request -- MULTIPLIER" request))))
+    (connect m1 me)
+    (connect m2 me)
+    (connect product me)
+    me)
+
+(define (adder a1 a2 sum)
+    (define (process-new-value)
+        (cond ((and (has-value? a1) (has-value? a2))
+               (set-value! sum
+                           (+ (get-value a1) (get-value a2))
+                           me))
+              ((and (has-value? a1) (has-value? sum))
+               (set-value! a2
+                           (- (get-value sum) (get-value a1))
+                           me))
+              ((and (has-value? a2) (has-value? sum))
+               (set-value! a1
+                           (- (get-value sum) (get-value a2))
+                           me))))
+    (define (process-forget-value)
+        (forget-value! sum me)
+        (forget-value! a1 me)
+        (forget-value! a2 me)
+        (process-new-value))
+    (define (me request)
+        (cond ((eq? request 'I-have-a-value)
+               (process-new-value))
+              ((eq? request 'I-lost-my-value)
+               (process-forget-value))
+              (else (error "Unknown request -- ADDER" request))))
+    (connect a1 me)
+    (connect a2 me)
+    (connect sum me)
+    me)
+
+(define (averager a b c)
+    (define (process-new-value)
+        (cond ((and (has-value? a) (has-value? b))
+               (set-value! c
+                           (/ (+ (get-value a) (get-value b))
+                              2)
+                           me))
+              ((and (has-value? a) (has-value? c))
+               (set-value! b
+                           (- (* 2 (get-value c))
+                              (get-value a))
+                           me))
+              ((and (has-value? b) (has-value? c))
+               (set-value! a
+                           (- (* 2 (get-value c))
+                              (get-value b))
+                           me))))
+    (define (process-forget-value)
+        (forget-value! a me)
+        (forget-value! b me)
+        (forget-value! c me)
+        (process-new-value))
+    (define (me request)
+        (cond ((eq? request 'I-have-a-value)
+               (process-new-value))
+              ((eq? request 'I-lost-my-value)
+               (process-forget-value))
+              (else (error "Unknown request -- AVERAGER" request))))
+    (connect a me)
+    (connect b me)
+    (connect c me)
+    me)
+
+(let ((a (make-connector))
+      (b (make-connector))
+      (c (make-connector)))
+    (probe 'a a)
+    (probe 'b b)
+    (probe 'c c)
+    ;; (define d (constant 6 a))
+    (define e (constant 3 b))
+    (define avg (averager a b c))
+    (newline)
+    ;;(forget-value! a d)
+    (newline)
+    (set-value! c 100 'user))
+
+;; using multiplier as squarer only works in one direction
+(define (squarer a b)
+    (define (process-new-value)
+        (if (has-value? b)
+            (if (< (get-value b) 0)
+                (error "square less than 0 -- SQUARER" (get-value b))
+                (when (not (has-value? a))
+                    (set-value! a
+                                (sqrt (get-value b))
+                                me)))
+            (when (has-value? a)
+                (set-value! b
+                            (* (get-value a) (get-value a))
+                            me))))
+    (define (process-forget-value)
+        (forget-value! a me)
+        (forget-value! b me)
+        (process-new-value))
+    (define (me request)
+        (cond ((eq? request 'I-have-a-value)
+               (process-new-value))
+              ((eq? request 'I-lost-my-value)
+               (process-forget-value))
+              (else (error "Unknown request -- SQUARER" request))))
+    (connect a me)
+    (connect b me)
+    me)
+
+;; bidirectional
+(let ((a (make-connector))
+      (b (make-connector)))
+    (probe 'a a)
+    (probe 'b b)
+    (newline)
+    (set-value! a 10 'user)
+    (define s (squarer a b))
+    (newline)
+    (forget-value! a 'user)
+    (newline)
+    (set-value! b 100 'user)
+    (newline))
+
+;; expression style (return compound object pointer)
+(define (c+ x y)
+    (let ((z (make-connector)))
+        (adder x y z)
+        z))
+(define (c- x y)
+    (let ((u (make-connector))
+          (v (make-connector))
+          (w (make-connector)))
+       (constant -1 u)
+       (multiplier u y v)
+       (adder x v w)
+       w))
+(define (cv a)
+    (let ((z (make-connector)))
+        (constant a z)
+        z))
+(get-value (c+ (cv 5) (cv 6)))
+(get-value (c- (cv 5) (cv 6)))