diff options
Diffstat (limited to 'coding-exercises')
| -rw-r--r-- | coding-exercises/2/66.rkt | 2 | ||||
| -rw-r--r-- | coding-exercises/3/24.rkt | 71 | ||||
| -rw-r--r-- | coding-exercises/3/28.rkt | 148 | ||||
| -rw-r--r-- | coding-exercises/3/33.rkt | 256 |
4 files changed, 476 insertions, 1 deletions
diff --git a/coding-exercises/2/66.rkt b/coding-exercises/2/66.rkt index 7cfedb8..892daee 100644 --- a/coding-exercises/2/66.rkt +++ b/coding-exercises/2/66.rkt @@ -14,7 +14,7 @@ (else (list-lookup given-key (cdr set-of-records))))) (define (lookup given-key set-of-records) - (if (null? set-of-records) + (if (null? set-of-records) false (let ((v (key (car set-of-records)))) (cond ((= given-key v) v) 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))) |