mirror of https://gitlab.com/RaphyJake/sicp.git
done!
This commit is contained in:
Raphael Jakobs
parent
b72346efef
commit
129e377a4b
|
|
@ -0,0 +1,58 @@
|
|||
(define (lookup key table)
|
||||
(let ((record (assoc key (cdr table))))
|
||||
(if record
|
||||
(cdr record)
|
||||
#f)))
|
||||
|
||||
|
||||
(define (make-table op)
|
||||
(define table (list '*table*))
|
||||
|
||||
(define (assoc key records)
|
||||
(cond ((null? records) #f)
|
||||
((op key (caar records)) (car records))
|
||||
(else (assoc key (cdr records)))))
|
||||
|
||||
|
||||
(define (lookup key-1 key-2)
|
||||
(let ((subtable (assoc key-1 (cdr table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record (car record) #f) )
|
||||
#f)))
|
||||
|
||||
(define (insert! key-1 key-2 value)
|
||||
(let ((subtable (assoc key-1 (cdr table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record (set-cdr! record value)
|
||||
(set-cdr! subtable (cons
|
||||
(cons key-2 value)
|
||||
(cdr subtable)))))
|
||||
(set-cdr! table
|
||||
(cons (list key-1 (cons key-2 value)) (cdr table))))))
|
||||
|
||||
|
||||
(define (dispatch m) (cond ((eq? m 'insert) insert!)
|
||||
((eq? m 'lookup) lookup)))
|
||||
|
||||
dispatch)
|
||||
|
||||
(define q (make-table eq?))
|
||||
|
||||
((q 'insert) 'to-do 'school 'eat-crap)
|
||||
((q 'lookup) 'to-do 'school)
|
||||
|
||||
((q 'insert) 'to-do 'school 'eat-pussy)
|
||||
((q 'lookup) 'to-do 'school)
|
||||
|
||||
((q 'insert) 'to-do 'gatorade 'get-paid)
|
||||
((q 'insert) 'to-do 'gatorade 'get-laid)
|
||||
((q 'insert) 'to-sex 'your-mom 'done)
|
||||
((q 'insert) 'to-sex 'elisa 'not-done)
|
||||
|
||||
|
||||
((q 'lookup) 'to-do 'gatorade)
|
||||
((q 'lookup) 'to-sex 'elisa)
|
||||
((q 'lookup) 'to-sex 'your-mom)
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
The enclosing environment of (fib) is the global environment, so memoization won't work! Fib will call the global fib, instead of memo-fib.
|
||||
|
|
@ -0,0 +1,164 @@
|
|||
(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-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else "AAAAAAAAAAAAAAAAAAAAA")))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect sum me)
|
||||
me)
|
||||
|
||||
(define (multiplier a1 a2 product)
|
||||
(define (process-new-value)
|
||||
(cond
|
||||
((or (and (has-value? a1) (= 0 (get-value a1)))
|
||||
(and (has-value? a2) (= 0 (get-value a2)))) (set-value! product 0 me))
|
||||
((and (has-value? a1) (has-value? a2)) (set-value! product (* (get-value a1)
|
||||
(get-value a2)) me))
|
||||
((and (has-value? a1) (has-value? product))
|
||||
(set-value! a2
|
||||
(/ (get-value product)
|
||||
(get-value a1)) me))
|
||||
|
||||
((and (has-value? a2) (has-value? product))
|
||||
(set-value! a1
|
||||
(/ (get-value product)
|
||||
(get-value a2)) me))))
|
||||
|
||||
(define (process-forget-value)
|
||||
(forget-value! product me)
|
||||
(forget-value! a1 me)
|
||||
(forget-value! a2 me)
|
||||
(process-new-value))
|
||||
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "AAAAAAAAAAAAAAAAAAAAA"))))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect product me)
|
||||
me)
|
||||
|
||||
(define (averager a b c)
|
||||
(let ((u (make-connector))
|
||||
(v (make-connector)))
|
||||
(constant 2 u)
|
||||
(adder a b v)
|
||||
(multiplier u c v)
|
||||
))
|
||||
|
||||
(define (inform-about-value constraint) (constraint 'I-have-a-new-value))
|
||||
(define (inform-about-no-value constraint) (constraint 'I-lost-my-value))
|
||||
|
||||
|
||||
(define (constant value connector)
|
||||
(define (me request) (display "FUUUUUUUUUUUCK!!!!!!"))
|
||||
(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-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "FUUUUUUUUUUUCK!"))))
|
||||
(connect connector me)
|
||||
me)
|
||||
|
||||
|
||||
(define (make-connector)
|
||||
(let ((value #f) (informant #f) (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)) (display "SHIT!"))
|
||||
(else 'ignored)))
|
||||
|
||||
(define (forget-my-value retractor)
|
||||
(if (eq? retractor informant)
|
||||
(begin (set! informant #f) (set! value #f) (for-each-except retractor inform-about-no-value constraints))
|
||||
'ignored))
|
||||
(define (connect new-constraint)
|
||||
(if (not (memq new-constraint constraints))
|
||||
(set! constraints (cons new-constraint constraints)) 'a)
|
||||
(if (has-value? me) (inform-about-value new-constraint) 'a)
|
||||
'done)
|
||||
(define (me request)
|
||||
(cond ((eq? request 'has-value?) (if informant #t #f))
|
||||
((eq? request 'value) value)
|
||||
((eq? request 'forget) forget-my-value)
|
||||
((eq? request 'set-value!) set-my-value)
|
||||
((eq? request 'connect) connect)
|
||||
(else (display "SHIT!!!!!!!!!!!!!!"))))
|
||||
me))
|
||||
|
||||
(define (for-each-except exception procedure list)
|
||||
(define (loop items)
|
||||
(cond ((null? items) (newline) 'done)
|
||||
((eq? (car items) exception) (loop (cdr items)))
|
||||
(else (procedure (car items)) (loop (cdr items)))))
|
||||
(loop list))
|
||||
|
||||
(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 B (make-connector))
|
||||
(define A (make-connector))
|
||||
(define C (make-connector))
|
||||
|
||||
(probe "A" A)
|
||||
(probe "B" B)
|
||||
(probe "C" C)
|
||||
|
||||
|
||||
(averager A B C)
|
||||
|
||||
(display "a")
|
||||
(set-value! A 10 'user)
|
||||
(set-value! B 12 'user)
|
||||
|
||||
(forget-value! B 'user)
|
||||
(set-value! C 200 'user)
|
||||
|
|
@ -0,0 +1 @@
|
|||
Set a to some value, and you will get a fine square. forget the value of A, set B to some value: Nothing will happen. The multiplier needs at least 2 element to infer the third. Now, try to set A to something.. and a mess will happen. I believe there are multiple flaws in his idea. I think a would be set to b/a and that's it.
|
||||
|
|
@ -0,0 +1,182 @@
|
|||
(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-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else "AAAAAAAAAAAAAAAAAAAAA")))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect sum me)
|
||||
me)
|
||||
|
||||
(define (multiplier a1 a2 product)
|
||||
(define (process-new-value)
|
||||
(cond
|
||||
((or (and (has-value? a1) (= 0 (get-value a1)))
|
||||
(and (has-value? a2) (= 0 (get-value a2)))) (set-value! product 0 me))
|
||||
((and (has-value? a1) (has-value? a2)) (set-value! product (* (get-value a1)
|
||||
(get-value a2)) me))
|
||||
((and (has-value? a1) (has-value? product))
|
||||
(set-value! a2
|
||||
(/ (get-value product)
|
||||
(get-value a1)) me))
|
||||
|
||||
((and (has-value? a2) (has-value? product))
|
||||
(set-value! a1
|
||||
(/ (get-value product)
|
||||
(get-value a2)) me))))
|
||||
|
||||
(define (process-forget-value)
|
||||
(forget-value! product me)
|
||||
(forget-value! a1 me)
|
||||
(forget-value! a2 me)
|
||||
(process-new-value))
|
||||
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "AAAAAAAAAAAAAAAAAAAAA"))))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect product me)
|
||||
me)
|
||||
|
||||
(define (squarer a b)
|
||||
(define (square x) (* x x)) ; duh
|
||||
|
||||
(define (process-new-value)
|
||||
(cond ((has-value? a) (set-value! b (square (get-value a)) me))
|
||||
((has-value? b) (if (> 0 (get-value b))
|
||||
(display "SHIT!! FUCK!!! ERROR")
|
||||
(set-value! a (sqrt (get-value b)) me)
|
||||
))))
|
||||
(define (process-forget-value)
|
||||
(forget-value! a me)
|
||||
(forget-value! b me))
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "AAAAAAAAAAAAAAAAAAAAA"))))
|
||||
(connect a me)
|
||||
(connect b me)
|
||||
me)
|
||||
|
||||
|
||||
(define (averager a b c)
|
||||
(let ((u (make-connector))
|
||||
(v (make-connector)))
|
||||
(constant 2 u)
|
||||
(adder a b v)
|
||||
(multiplier u c v)))
|
||||
|
||||
|
||||
(define (inform-about-value constraint) (constraint 'I-have-a-new-value))
|
||||
(define (inform-about-no-value constraint) (constraint 'I-lost-my-value))
|
||||
|
||||
|
||||
(define (constant value connector)
|
||||
(define (me request) (display "FUUUUUUUUUUUCK!!!!!!"))
|
||||
(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-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "FUUUUUUUUUUUCK!"))))
|
||||
(connect connector me)
|
||||
me)
|
||||
|
||||
|
||||
(define (make-connector)
|
||||
(let ((value #f) (informant #f) (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)) (display "SHIT!"))
|
||||
(else 'ignored)))
|
||||
|
||||
(define (forget-my-value retractor)
|
||||
(if (eq? retractor informant)
|
||||
(begin (set! informant #f) (set! value #f) (for-each-except retractor inform-about-no-value constraints))
|
||||
'ignored))
|
||||
(define (connect new-constraint)
|
||||
(if (not (memq new-constraint constraints))
|
||||
(set! constraints (cons new-constraint constraints)) 'a)
|
||||
(if (has-value? me) (inform-about-value new-constraint) 'a)
|
||||
'done)
|
||||
(define (me request)
|
||||
(cond ((eq? request 'has-value?) (if informant #t #f))
|
||||
((eq? request 'value) value)
|
||||
((eq? request 'forget) forget-my-value)
|
||||
((eq? request 'set-value!) set-my-value)
|
||||
((eq? request 'connect) connect)
|
||||
(else (display "SHIT!!!!!!!!!!!!!!"))))
|
||||
me))
|
||||
|
||||
(define (for-each-except exception procedure list)
|
||||
(define (loop items)
|
||||
(cond ((null? items) (newline) 'done)
|
||||
((eq? (car items) exception) (loop (cdr items)))
|
||||
(else (procedure (car items)) (loop (cdr items)))))
|
||||
(loop list))
|
||||
|
||||
(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 B (make-connector))
|
||||
(define A (make-connector))
|
||||
|
||||
|
||||
(probe "A" A)
|
||||
(probe "B" B)
|
||||
|
||||
(squarer A B)
|
||||
|
||||
(set-value! A 10 'user)
|
||||
(forget-value! A 'user)
|
||||
|
||||
(set-value! B 256 'user)
|
||||
(set-value! A 10 'user)
|
||||
|
|
@ -0,0 +1,192 @@
|
|||
;; CONSTRAINTS
|
||||
|
||||
(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-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else "AAAAAAAAAAAAAAAAAAAAA")))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect sum me)
|
||||
me)
|
||||
|
||||
(define (multiplier a1 a2 product)
|
||||
(define (process-new-value)
|
||||
(cond
|
||||
((or (and (has-value? a1) (= 0 (get-value a1)))
|
||||
(and (has-value? a2) (= 0 (get-value a2)))) (set-value! product 0 me))
|
||||
((and (has-value? a1) (has-value? a2)) (set-value! product (* (get-value a1)
|
||||
(get-value a2)) me))
|
||||
((and (has-value? a1) (has-value? product))
|
||||
(set-value! a2
|
||||
(/ (get-value product)
|
||||
(get-value a1)) me))
|
||||
|
||||
((and (has-value? a2) (has-value? product))
|
||||
(set-value! a1
|
||||
(/ (get-value product)
|
||||
(get-value a2)) me))))
|
||||
|
||||
(define (process-forget-value)
|
||||
(forget-value! product me)
|
||||
(forget-value! a1 me)
|
||||
(forget-value! a2 me)
|
||||
(process-new-value))
|
||||
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "AAAAAAAAAAAAAAAAAAAAA"))))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect product me)
|
||||
me)
|
||||
|
||||
(define (averager a b c)
|
||||
(let ((u (make-connector))
|
||||
(v (make-connector)))
|
||||
(constant 2 u)
|
||||
(adder a b v)
|
||||
(multiplier u c v)
|
||||
))
|
||||
|
||||
|
||||
(define (inform-about-value constraint) (constraint 'I-have-a-new-value))
|
||||
(define (inform-about-no-value constraint) (constraint 'I-lost-my-value))
|
||||
|
||||
;; SYNTACTIC SUGAR
|
||||
|
||||
(define (c+ x y)
|
||||
(let ((z (make-connector)))
|
||||
(adder x y z)
|
||||
z))
|
||||
|
||||
(define (c- x y)
|
||||
(let ((z (make-connector)))
|
||||
(adder z y x)
|
||||
z))
|
||||
|
||||
(define (c* x y)
|
||||
(let ((z (make-connector)))
|
||||
(multiplier x y z)
|
||||
z))
|
||||
|
||||
(define (c/ x y)
|
||||
(let ((z (make-connector)))
|
||||
(multiplier z y x)
|
||||
z))
|
||||
|
||||
(define (cv value)
|
||||
(let ((z (make-connector)))
|
||||
(constant value z)
|
||||
z))
|
||||
|
||||
(define (constant value connector)
|
||||
(define (me request) (display "FUUUUUUUUUUUCK!!!!!!"))
|
||||
(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-new-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (display "FUUUUUUUUUUUCK!"))))
|
||||
(connect connector me)
|
||||
me)
|
||||
|
||||
|
||||
(define (make-connector)
|
||||
(let ((value #f) (informant #f) (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)) (display "SHIT"))
|
||||
(else 'ignored)))
|
||||
|
||||
(define (forget-my-value retractor)
|
||||
(if (eq? retractor informant)
|
||||
(begin (set! informant #f) (set! value #f) (for-each-except retractor inform-about-no-value constraints))
|
||||
'ignored))
|
||||
(define (connect new-constraint)
|
||||
(if (not (memq new-constraint constraints))
|
||||
(set! constraints (cons new-constraint constraints)) 'a)
|
||||
(if (has-value? me) (inform-about-value new-constraint) 'a)
|
||||
'done)
|
||||
(define (me request)
|
||||
(cond ((eq? request 'has-value?) (if informant #t #f))
|
||||
((eq? request 'value) value)
|
||||
((eq? request 'forget) forget-my-value)
|
||||
((eq? request 'set-value!) set-my-value)
|
||||
((eq? request 'connect) connect)
|
||||
(else (display "SHIT!!!!!!!!!!!!!!"))))
|
||||
me))
|
||||
|
||||
(define (for-each-except exception procedure list)
|
||||
(define (loop items)
|
||||
(cond ((null? items) (newline) 'done)
|
||||
((eq? (car items) exception) (loop (cdr items)))
|
||||
(else (procedure (car items)) (loop (cdr items)))))
|
||||
(loop list))
|
||||
|
||||
(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 C (make-connector))
|
||||
|
||||
(define (fahren-cel-converter x)
|
||||
(c+ (c* (c/ (cv 9) (cv 5)) x) (cv 32)))
|
||||
|
||||
(define F (fahren-cel-converter C))
|
||||
|
||||
(probe "Far temp" F)
|
||||
(probe "Celsius temp" C)
|
||||
|
||||
|
||||
(set-value! F 120.0 'user)
|
||||
|
||||
(forget-value! F 'user)
|
||||
|
||||
(set-value! C 35 'user)
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
(define (lookup key table)
|
||||
(let ((record (assoc key (cdr table))))
|
||||
(if record
|
||||
(cdr record)
|
||||
#f)))
|
||||
|
||||
(define (assoc key records)
|
||||
(cond ((null? records) #f)
|
||||
((eq? key (caar records)) (car records))
|
||||
(else (assoc key (cdr records)))))
|
||||
|
||||
|
||||
|
||||
(define (make-table)
|
||||
(define table (list '*table*))
|
||||
|
||||
(define (lookup key-1 key-2)
|
||||
(let ((subtable (assoc key-1 (cdr table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record (car record) #f) )
|
||||
#f)))
|
||||
|
||||
(define (insert! key-1 key-2 value)
|
||||
(let ((subtable (assoc key-1 (cdr table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record (set-cdr! record value)
|
||||
(set-cdr! subtable (cons
|
||||
(cons key-2 value)
|
||||
(cdr subtable)))))
|
||||
(set-cdr! table
|
||||
(cons (list key-1 (cons key-2 value)) (cdr table))))))
|
||||
|
||||
|
||||
(define (dispatch m) (cond ((eq? m 'insert) insert!)
|
||||
((eq? m 'lookup) lookup)))
|
||||
|
||||
dispatch)
|
||||
|
||||
(define q (make-table))
|
||||
|
||||
((q 'insert) 'to-do 'school 'eat-crap)
|
||||
((q 'lookup) 'to-do 'school)
|
||||
|
||||
((q 'insert) 'to-do 'school 'eat-pussy)
|
||||
((q 'lookup) 'to-do 'school)
|
||||
|
||||
((q 'insert) 'to-do 'gatorade 'get-paid)
|
||||
((q 'insert) 'to-do 'gatorade 'get-laid)
|
||||
((q 'insert) 'to-sex 'your-mom 'done)
|
||||
((q 'insert) 'to-sex 'elisa 'not-done)
|
||||
|
||||
|
||||
((q 'lookup) 'to-do 'gatorade)
|
||||
((q 'lookup) 'to-sex 'elisa)
|
||||
((q 'lookup) 'to-sex 'your-mom)
|
||||
|
||||
Loading…
Reference in New Issue