# 3.3 Modeling with Mutable Data
# 3.3.1 Mutable List Structure
(define x)
(define y)Note: We must build new cons cells rather than quoting like '((a b) c d) because quoted forms are immutable and some Schemes enforce this.
(define (reset!)
(set! x (list (list 'a 'b) 'c 'd))
(set! y (list 'e 'f)))
(reset!)
(set-car! x y)
x => (cons y (cdr x)) => '((e f) c d)
(reset!)
(set-cdr! x y)
x => (cons (car x) y) => '((a b) e f)# Exercise 3.12
(define (append x y)
(if (null? x)
y
(cons (car x) (append (cdr x) y))))
(define (append! x y)
(set-cdr! (last-pair x) y)
x)
(define (last-pair x)
(if (null? (cdr x)) x (last-pair (cdr x))))
(define x (list 'a 'b))
(define y (list 'c 'd))
(define z (append x y))
z => '(a b c d)
(cdr x) => '(b)
; x->[*|*]->[*|X]
; | |
; V V
; a b
(define w (append! x y))
w => '(a b c d)
(cdr x) => '(b c d)
; y
; |
; x->[*|*]->[*|*]->[*|*]->[*|X]
; w/ | | | |
; V V V V
; a b c d# Exercise 3.13
(define (make-cycle x)
(set-cdr! (last-pair x) x)
x)
(define z (make-cycle (list 'a 'b 'c)))
(cadddr z) => 'a
; +-------------------+
; V |
; z->[*|*]->[*|*]->[*|*]-+
; | | |
; V V V
; a b cIf we try to compute (last-pair z), we will never finish because the list is not null-terminated and so null? will never be true. We will be stuck in an infinite recursion.
# Exercise 3.14
(define (mystery x)
(define (loop x y)
(if (null? x)
y
(let ((temp (cdr x)))
(set-cdr! x y)
(loop temp x))))
(loop x '()))In general, mystery reverses the list x. It does this by walking through the list, setting the cdr of each pair to point to the previous pair instead of the next. For the very first pair, it sets the cdr to null.
(define v (list 'a 'b 'c 'd))
; v->[*|*]->[*|*]->[*|*]->[*|X]
; | | | |
; V V V V
; a b c d
(define w (mystery v))
v => '(a)
w => '(d c b a)
; v->[*|X]<-[*|*]<-[*|*]<-[*|*]<-w
; | | | |
; V V V V
; a b c dThese box-and-pointer diagrams make it obvious that mystery simply changes the directions of all the arrows.
# 3.3.1.1 Sharing and identity
(define x (list 'a 'b))
(define z1 (cons x x))
(define z2 (cons (list 'a 'b) (list 'a 'b)))
(define (set-to-wow! x) (set-car! (car x) 'wow) x)
z1 => '((a b) a b)
(set-to-wow! z1) => '((wow b) wow b)
z2 => '((a b) a b)
(set-to-wow! z2) => '((wow b) a b)
(eq? (car z1) (cdr z1)) => #t
(eq? (car z2) (cdr z2)) => #f# Exercise 3.15
In z1, the car and cdr both point to x:
; z1->[*|*]
; | |
; V V
; x->[*|*]->[*|X]
; | |
; V V
; a bAfter set-to-wow!, the a becomes wow for both car and cdr:
; z1->[*|*]
; | |
; V V
; x->[*|*]->[*|X]
; | |
; V V
; wow bIn z2, the car and cdr point to different cons cells:
; z2->[*|*]->[*|*]->[*|X]
; | | |
; | +-> a +-> b
; V
; [*|*]->[*|X]
; | |
; +-> a +-> bAfter set-to-wow!, the a becomes wow only for the car:
; z2->[*|*]->[*|*]->[*|X]
; | | |
; | +-> a +-> b
; V
; [*|*]--->[*|X]
; | |
; +-> wow +-> b# Exercise 3.16
(define (count-pairs x)
(if (not (pair? x))
0
(+ (count-pairs (car x))
(count-pairs (cdr x))
1)))The procedure count-pairs is wrong because it assumes there is no sharing. The lists below named N-M have N pairs, but they use sharing so that count-pairs think they have M pairs.
(define one-1 (cons 'a '()))
(define two-2 (cons 'a (cons 'b '())))
(define two-3 (cons one-1 one-1))
(define three-3 (cons 'a (cons 'a (cons 'a '()))))
(define three-4 (cons 'a (cons one-1 one-1)))
(define three-5 (cons two-2 two-2))
(define three-7 (cons two-3 two-3))
(count-pairs one-1) => 1
(count-pairs two-2) => 2
(count-pairs two-3) => 3
(count-pairs three-3) => 3
(count-pairs three-4) => 4
(count-pairs three-5) => 5
(count-pairs three-7) => 7# Exercise 3.17
(define (count-pairs x)
(let ((seen '()))
(define (iter x)
(if (or (not (pair? x)) (memq x seen))
0
(begin (set! seen (cons x seen))
(+ (iter (car x))
(iter (cdr x))
1))))
(iter x)))
(count-pairs one-1) => 1
(count-pairs two-2) => 2
(count-pairs two-3) => 2
(count-pairs three-3) => 3
(count-pairs three-4) => 3
(count-pairs three-5) => 3
(count-pairs three-7) => 3# Exercise 3.18
(define (cycle? ls)
(define (iter ls seen)
(and (pair? ls)
(or (memq ls seen)
(iter (cdr ls) (cons ls seen)))))
(if (iter ls '()) #t #f))
(cycle? (list 1 2 3)) => #f
(cycle? (make-cycle (list 1 2 3))) => #t# Exercise 3.19
This is Floyd’s cycle-finding algorithm (the tortoise and the hare).
(define (cycle? ls)
(define (iter t h)
(and (pair? h)
(pair? (cdr h))
(or (eq? t h)
(iter (cdr t) (cddr h)))))
(and (pair? ls)
(iter ls (cdr ls))))
(cycle? (list 1 2 3)) => #f
(cycle? (make-cycle (list 1 2 3))) => #t# 3.3.1.2 Mutation is just assignment
(define (cons x y)
(define (set-x! v) (set! x v))
(define (set-y! v) (set! y v))
(define (dispatch m)
(cond ((eq? m 'car) x)
((eq? m 'cdr) y)
((eq? m 'set-car!) set-x!)
((eq? m 'set-cdr!) set-y!)
(else (error 'cons "undefined operation" m))))
dispatch)
(define (car p) (p 'car))
(define (cdr p) (p 'cdr))
(define (set-car! p v) ((p 'set-car!) v) p)
(define (set-cdr! p v) ((p 'set-cdr!) v) p)
(define z (cons 'a 'b))
(car z) => 'a
(cdr z) => 'b
(set-car! z 'c)
(car z) => 'c
(set-cdr! z 'd)
(cdr z) => 'd# Exercise 3.20
(define x (cons 1 2))
(define z (cons x x))
(set-car! (cdr z) 17)
(car x) => 17Following the arrows in the environment diagram below, we see that the cdr of z is the same pair pointed to by x. By changing the car of this pair to 17, we change x from (1 2) to (17 2).
; ______________
; global env ->| x: -+ z: ---|-----------------+
; |_____|________|<----------------|------+
; | ^ V _|___________
; | E1_|___________ [*|*]->| set-x!: ... |
; | | x: 1 y: 2 | | | set-y!: ... |
; | | set-x!: ... | V | dispatch: --|-+
; | | set-y!: ... | params: m | x:+ y:+ | |
; | | dispatch:+ | body: ... |___|_____|___| |
; | |__________|__| ~~~~~~~~~~~ | | |
; | ^ | ^--------|-----|-----+
; | | | | |
; | +-|-----<---+---------<-----------+--<--+
; | | |
; V V |
; [*|*]-+
; paramters: m }<-+
; body: ... }# 3.3.2 Representing Queues
(define front-ptr car)
(define rear-ptr cdr)
(define set-front-ptr! set-car!)
(define set-rear-ptr! set-cdr!)
(define (empty-queue? q) (null? (front-ptr q)))
(define (make-queue) (cons '() '()))
(define (front-queue q)
(if (empty-queue? q)
(error 'front-queue "called with an empty queue" q)
(car (front-ptr q))))
(define (insert-queue! q x)
(let ((new-pair (cons x '())))
(cond ((empty-queue? q)
(set-front-ptr! q new-pair)
(set-rear-ptr! q new-pair)
q)
(*stack-mode*
(set-cdr! new-pair (front-ptr q))
(set-front-ptr! q new-pair))
(else
(set-cdr! (rear-ptr q) new-pair)
(set-rear-ptr! q new-pair)
q))))
(define (delete-queue! q)
(cond ((empty-queue? q)
(error 'delete-queue! "called with an empty queue" q))
(else (set-front-ptr! q (cdr (front-ptr q)))
q)))Make the queue behave as a stack (FILO insertion). Used in Exercise 3.32.
(define *stack-mode* #f)
(define (enable-stack-mode) (set! *stack-mode* #t))
(define (disable-stack-mode) (set! *stack-mode* #f))# Exercise 3.21
(define q1 (make-queue))
(insert-queue! q1 'a) => '((a) a)
(insert-queue! q1 'b) => '((a b) b)
(delete-queue! q1) => '((b) b)
(delete-queue! q1) => '(() b)Eva Lu Ator points out that Lisp is trying to print the list structure that makes up the queue. It doesn’t know anything special about our queue representation. The interpreter’s response isn’t a list of things in the queue, it is the queue as we decided to represent it. It is a bit more clear if we print the lists in dotted cons notation:
; list repr. front rear
; ((a) a) = ((a) . (a))
; ((a b) b) = ((a b) . (b))
; ((b) b) = ((b) . (b))
; (() b) = (() . (b))Now, it is clear that Lisp is showing us the front pointer and the rear pointer, interpreting both as ordinary lists. This works fine for the front pointer, and in fact we can just look at it by itself to see everything in our queue. The rear pointer is always displayed as a list with one item because the cdr of the last item is always null. Even when we delete all the items, we still see the last item in the queue because of the way we implemented delete-queue!.
(define (print-queue q)
(display (front-ptr q))
(newline))
(insert-queue! q1 'c)
(insert-queue! q1 'd)
(print-queue q1) =$> "(c d)\n"# Exercise 3.22
It’s interesting how I ended up using dispatch like you would use the this keyword in object-oriented languages. Another interesting point is the application of procedures in dispatch. For procedures that take arguments other than the queue itself, like for insertion, we have to return the procedure that can then be applied to the argument(s). In this case, the rest of the operations take no other arguments. It might be more consistent to return a procedure of zero arguments—then we would need double parentheses, like ((my-queue 'front-queue))—but this seems a bit strange. Instead, we apply the procedure right away in dispatch and pass on the return value.
(define (make-queue)
(let ((front-ptr '())
(rear-ptr '()))
(define (empty?)
(null? front-ptr))
(define (insert! x)
(let ((new-pair (cons x '())))
(cond ((empty?)
(set! front-ptr new-pair)
(set! rear-ptr new-pair)
dispatch)
(else (set-cdr! rear-ptr new-pair)
(set! rear-ptr new-pair)
dispatch))))
(define (delete!)
(if (empty?)
(error 'delete! "called with an empty queue")
(begin (set! front-ptr (cdr front-ptr))
dispatch)))
(define (dispatch m)
(cond ((eq? m 'empty-queue?) (empty?))
((eq? m 'front-queue)
(if (empty?)
(error 'front-queue "called with an empty queue")
(car front-ptr)))
((eq? m 'insert-queue!) insert!)
((eq? m 'delete-queue!) (delete!))
(else (error 'make-queue "undefined operation" m))))
dispatch))
(define q (make-queue))
(q 'empty-queue?) => #t
((q 'insert-queue!) 'a)
((q 'insert-queue!) 'b)
(q 'empty-queue?) => #f
(q 'front-queue) => 'a
(q 'delete-queue!)
(q 'front-queue) => 'b
(q 'delete-queue!)
(q 'empty-queue?) => #t
(q 'front-queue) =!> "called with an empty queue"
(q 'delete-queue!) =!> "called with an empty queue"# Exercise 3.23
I have implemented the deque as a doubly-linked list. Instead of pointing to the next element, the cdr of each item is a pair whose car points to the previous item and whose cdr points to the next. We call the items nodes:
(define (make-node x prev next) (cons x (cons prev next)))
(define (data-node node) (car node))
(define (prev-node node) (cadr node))
(define (next-node node) (cddr node))
(define (set-prev! node prev) (set-car! (cdr node) prev))
(define (set-next! node next) (set-cdr! (cdr node) next))
(define (front-ptr dq) (car dq))
(define (rear-ptr dq) (cdr dq))
(define (set-front-ptr! dq x) (set-car! dq x))
(define (set-rear-ptr! dq x) (set-cdr! dq x))
(define (make-deque) (cons '() '()))
(define (empty-deque? dq) (null? (front-ptr dq)))
(define (front-deque dq)
(if (empty-deque? dq)
(error 'front-deque "called with an empty deque" dq)
(data-node (front-ptr dq))))
(define (rear-deque dq)
(if (empty-deque? dq)
(error 'rear-deque "called with an empty deque" dq)
(data-node (rear-ptr dq))))
(define (front-insert-deque! dq x)
(cond ((empty-deque? dq)
(let ((node (make-node x '() '())))
(set-front-ptr! dq node)
(set-rear-ptr! dq node)
dq))
(else
(let* ((old-front (front-ptr dq))
(new-front (make-node x '() old-front)))
(set-prev! old-front new-front)
(set-front-ptr! dq new-front)
dq))))
(define (rear-insert-deque! dq x)
(cond ((empty-deque? dq)
(front-insert-deque! dq x))
(else
(let* ((old-rear (rear-ptr dq))
(new-rear (make-node x old-rear '())))
(set-next! old-rear new-rear)
(set-rear-ptr! dq new-rear)
dq))))
(define (front-delete-deque! dq)
(cond ((empty-deque? dq)
(error 'front-delete-deque! "called with an empty deque" dq))
(else
(let* ((old-front (front-ptr dq))
(new-front (next-node old-front)))
(cond ((null? new-front)
(set-front-ptr! dq '())
(set-rear-ptr! dq '())
dq)
(else (set-prev! new-front '())
(set-front-ptr! dq new-front)
dq))))))
(define (rear-delete-deque! dq)
(cond ((empty-deque? dq)
(error 'rear-delete-deque! "called with an empty deque" dq))
(else
(let* ((old-rear (rear-ptr dq))
(new-rear (prev-node old-rear)))
(cond ((null? new-rear)
(front-delete-deque! dq))
(else (set-next! new-rear '())
(set-rear-ptr! dq new-rear)
dq))))))
(define (print-deque dq)
(define (iter node first)
(when (not (null? node))
(when (not first) (display ", "))
(display (data-node node))
(iter (next-node node) #f)))
(display "[")
(iter (front-ptr dq) #t)
(display "]")
(newline))
(define dq (make-deque))
(empty-deque? dq) => #t
(print-deque dq) =$> "[]\n"
(front-insert-deque! dq 'b)
(empty-deque? dq) => #f
(rear-insert-deque! dq 'c)
(front-insert-deque! dq 'a)
(print-deque dq) =$> "[a, b, c]\n"
(rear-delete-deque! dq)
(print-deque dq) =$> "[a, b]\n"
(front-delete-deque! dq)
(print-deque dq) =$> "[b]\n"
(rear-delete-deque! dq)
(empty-deque? dq) => #t
(front-deque dq) =!> "called with an empty deque"
(front-delete-deque! dq) =!> "called with an empty deque"
(rear-delete-deque! dq) =!> "called with an empty deque"# 3.3.3 Representing Tables
# 3.3.3.1 One-dimensional tables
(define (lookup key table)
(let ((record (assoc key (cdr table))))
(if record
(cdr record)
#f)))
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (insert! key value table)
(let ((record (assoc key (cdr table))))
(if record
(set-cdr! record value)
(set-cdr! table
(cons (cons key value)
(cdr table))))))
(define (make-table) (list '*table*))
(define t (make-table))
(lookup 'a t) => #f
(insert! 'a 1 t)
(lookup 'a t) => 1# 3.3.3.2 Two-dimensional tables
(define (lookup key-1 key-2 table)
(let ((subtable (assoc key-1 (cdr table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
#f))
#f)))
(define (insert! key-1 key-2 value table)
(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 t (make-table))
(lookup 'a 'b t) => #f
(insert! 'a 'b 1 t)
(lookup 'a 'b t) => 1
(insert! 'a 'c 2 t)
(insert! 'x 'x 3 t)
(lookup 'a 'c t) => 2
(lookup 'x 'x t) => 3# 3.3.3.3 Creating local tables
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record (cdr record) #f))
#f)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-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! local-table
(cons (list key-1 (cons key-2 value))
(cdr local-table))))))
(define (reset!)
(set-cdr! local-table '()))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
((eq? m 'reset-proc!) reset!)
(else (error 'make-table "unknown operation" m))))
dispatch))This is used extensively in Chapter 2.
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define reset (operation-table 'reset-proc!))# Exercise 3.24
Other than the argument same-key? and the internal procedure assoc, this is the same code as in Section 3.3.3.3.
(define (make-table same-key?)
(define (assoc key records)
(cond ((null? records) #f)
((same-key? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record (cdr record) #f))
#f)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-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! local-table
(cons (list key-1 (cons key-2 value))
(cdr local-table))))))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error 'dispatch "unknown operation" m))))
dispatch))
(define table (make-table (lambda (x y) (< (abs (- x y)) 10))))
((table 'insert-proc!) 0 0 'a)
((table 'lookup-proc) 0 0) => 'a
((table 'lookup-proc) 2 3) => 'a
((table 'lookup-proc) -9 9) => 'a# Exercise 3.25
A table is a pair (key . records), where records is an alist. Each alist entry is either (key . value). If value is a list, then the entry is a subtable. The root key is the symbol *table*. To allow storing values at a key which is a prefix of other keys, we use a sentinel key ().
(define (lookup keys table)
(let ((value (cdr table)))
(cond ((null? keys)
(if (list? value)
(lookup '(()) table)
value))
((list? value)
(let ((subtable (assoc (car keys) value)))
(and subtable (lookup (cdr keys) subtable))))
(else #f))))
(define (insert! keys value table)
(define (iter keys table)
(let ((old-value (cdr table)))
(cond ((null? keys) (set-cdr! table value))
((list? old-value)
(let ((subtable (assoc (car keys) old-value)))
(if subtable
(iter (cdr keys) subtable)
(let ((new-subtable (cons (car keys) '())))
(set-cdr! table (cons new-subtable old-value))
(iter (cdr keys) new-subtable)))))
(else (set-cdr! table (list (cons '() old-value)))
(iter keys table)))))
(iter keys table))
(define table (make-table))
(insert! '(a) 1 table)
(insert! '(a b c) 2 table)
(insert! '(d) 3 table)
(insert! '(e f) 4 table)
(insert! '(e g h) 5 table)
(lookup '(a) table) => 1
(lookup '(a b c) table) => 2
(lookup '(d) table) => 3
(lookup '(e f) table) => 4
(lookup '(e g h) table) => 5
(lookup '(a b) table) => #f
(lookup '(a b c d) table) => #f
(lookup '(z) table) => #f# Exercise 3.26
A table is a pair whose cdr is a node. A node is either null or has the form ((key . value) . (left . right)) where left and right are nodes.
(define (lookup key table)
(define (iter node)
(if (null? node)
#f
(let ((node-key (caar node)))
(cond ((= key node-key) (cdar node))
((< key node-key) (iter (cadr node)))
((> key node-key) (iter (cddr node)))))))
(iter (cdr table)))
(define (insert! key value table)
(define (iter node set-child! parent)
(if (null? node)
(set-child! parent (cons (cons key value) (cons '() '())))
(let ((node-key (caar node)))
(cond ((= key node-key) (set-cdr! (car node) value))
((< key node-key) (iter (cadr node) set-car! (cdr node)))
((> key node-key) (iter (cddr node) set-cdr! (cdr node)))))))
(iter (cdr table) set-cdr! table))
(define table (make-table))
(insert! 0 'a table)
(insert! 25 'b table)
(insert! -3 'c table)
(insert! -4 'd table)
(insert! 7 'e table)
(lookup 0 table) => 'a
(lookup 25 table) => 'b
(lookup -3 table) => 'c
(lookup -4 table) => 'd
(lookup 7 table) => 'e# Exercise 3.27
(define (memoize f)
(let ((table (make-table)))
(lambda (x)
(let ((cached (lookup x table)))
(or cached
(let ((result (f x)))
(insert! x result table)
result))))))
(define memo-fib
(memoize
(lambda (n)
(cond ((= n 0) 0)
((= n 1) 1)
(else (+ (memo-fib (- n 1))
(memo-fib (- n 2))))))))
(memo-fib 6) => 8
(memo-fib 100) => 354224848179261915075See whiteboard/exercise-3.27.jpg for the environment diagram.
The memoized procedure memo-fib computes the nth Fibonacci number in a number of steps proportional to n because it takes the sum of n numbers. When we evaluate (memo-fib n), a tree-recursive process is generated and it descends until it reaches 0 and 1, the base cases of the recursive Fibonacci implementation. The results for these inputs are placed in the table, and then (memo-fib 2) requires only one step, the addition of 0 and 1, because the values are taken from the table. In general, we descend to the bottom of the tree once and then ascend it, never again going down and reaching duplicate leaves. This is twice n steps, so it grows as O(n).
If we had defined memo-fib as (memoize fib), it would not work because recursive calls would use fib, not memo-fib, and so we would still have an exponential number of steps. However, this aspect of the memoization would still work: if you evaluated (memo-fib 42) twice, the second time would take only the step of looking up a value in the table.
# 3.3.4 A Simulator for Digital Circuits
(define (half-adder a b sum carry)
(let ((d (make-wire))
(e (make-wire)))
(or-gate a b d)
(and-gate a b carry)
(inverter carry e)
(and-gate d e sum)))
(define (full-adder a b c-in sum c-out)
(let ((s (make-wire))
(c1 (make-wire))
(c2 (make-wire)))
(half-adder a b s c1)
(half-adder c-in s sum c2)
(or-gate c1 c2 c-out)))# 3.3.4.1 Primitive function boxes
(define inverter-delay 2)
(define and-gate-delay 3)
(define (inverter input output)
(add-action!
input
(lambda ()
(let ((new-signal (logical-not (get-signal input))))
(after-delay
inverter-delay
(lambda () (set-signal! output new-signal)))))))
(define (and-gate a b out)
(define (action)
(let ((new-signal (logical-and (get-signal a) (get-signal b))))
(after-delay
and-gate-delay
(lambda () (set-signal! out new-signal)))))
(add-action! a action)
(add-action! b action))
(define (logical-not a) (- 1 a))
(define (logical-and a b) (* a b))# Exercise 3.28
(define or-gate-delay 5)
(define (or-gate a b out)
(define (action)
(let ((new-signal (logical-or (get-signal a) (get-signal b))))
(after-delay
or-gate-delay
(lambda () (set-signal! out new-signal)))))
(add-action! a action)
(add-action! b action))
(define (logical-or a b) (- (+ a b) (* a b)))# Exercise 3.29
(define (or-gate a b out)
(let ((na (make-wire))
(nb (make-wire))
(c (make-wire)))
(inverter a na)
(inverter b nb)
(and-gate na nb c)
(inverter c out)))
(define compound-or-gate-delay
(+ and-gate-delay (* 2 inverter-delay)))# Exercise 3.30
Adds binary numbers as and bs in little endian order.
(define (ripple-carry-adder as bs ss carry)
(define (iter as bs c-in ss)
(if (null? (cdr as))
(full-adder (car as) (car bs) c-in (car ss) carry)
(let ((c (make-wire)))
(full-adder (car as) (car bs) c-in (car ss) c)
(iter (cdr as) (cdr bs) c (cdr ss)))))
(cond ((not (= (length as) (length bs) (length ss)))
(error 'ripple-carry-adder "bit width mismatch" as bs ss))
((null? as)
(error 'ripple-carry-adder "bit width must be at least 1" as))
(else (let ((c-in (make-wire)))
(set-signal! c-in 0)
(iter as bs c-in ss)))))
(define half-adder-delay
(+ (max or-gate-delay
(+ and-gate-delay inverter-delay))
or-gate-delay))
(define full-adder-delay
(+ (* 2 half-adder-delay)
or-gate-delay))
(define (ripple-carry-adder-delay n)
(* n full-adder-delay))# 3.3.4.2 Representing wires
(define (make-wire)
(let ((signal-value 0)
(action-procedures '()))
(define (set-signal! s)
(when (not (= signal-value s))
(set! signal-value s)
(call-each action-procedures)))
(define (add-action! proc)
(set! action-procedures
(cons proc action-procedures))
(proc))
(define (dispatch m)
(cond ((eq? m 'get-signal) signal-value)
((eq? m 'set-signal!) set-signal!)
((eq? m 'add-action!) add-action!)
(else (error 'dispatch "unknown operation" m))))
dispatch))
(define (call-each procs) (for-each (lambda (f) (f)) procs))
(define (get-signal wire) (wire 'get-signal))
(define (set-signal! wire s) ((wire 'set-signal!) s))
(define (add-action! wire a) ((wire 'add-action!) a))# 3.3.4.3 The agenda
(define the-agenda (make-agenda))
(define (reset) (reset-agenda! the-agenda))
(define (after-delay delay-time action)
(add-to-agenda! (+ delay-time (simulation-time the-agenda))
action
the-agenda))
(define (propagate)
(unless (empty-agenda? the-agenda)
(let ((first-item (first-agenda-item the-agenda)))
(first-item)
(remove-first-agenda-item! the-agenda)
(propagate))))# 3.3.4.4 A sample simulation
(define (probe name wire)
(add-action!
wire
(lambda ()
(display (format "\n~a ~a New-value = ~a"
name (simulation-time the-agenda) (get-signal wire))))))
(reset)
(define input-1 (make-wire))
(define input-2 (make-wire))
(define sum (make-wire))
(define carry (make-wire))
(probe 'sum sum)
=$> ["sum 0 New-value = 0"]
(probe 'carry carry)
=$> ["carry 0 New-value = 0"]
(half-adder input-1 input-2 sum carry)
(set-signal! input-1 1)
(propagate)
=$> ["sum 8 New-value = 1"]
(set-signal! input-2 1)
(propagate)
=$> ["carry 11 New-value = 1"
"sum 16 New-value = 0"]# Exercise 3.31
We can make wires that do not call actions immediately by wrapping actions in procedures that do nothing on their first call.
(define (make-bad-wire)
(let ((wire (make-wire)))
(lambda (m)
(if (not (eq? m 'add-action!))
(wire m)
(lambda (action)
((wire 'add-action!)
(let ((first #t))
(lambda ()
(if first
(set! first #f)
(action))))))))))Consider an inverter between two wires:
(reset)
(define a (make-bad-wire))
(define b (make-bad-wire))
(get-signal a) => 0
(get-signal b) => 0
(inverter a b)Since add-action! is not calling the procedure right away, we’ve now added an action to a but it has not been executed. The signals haven’t changed:
(get-signal a) => 0
(get-signal b) => 0This is an incorrect state. To fix it, we’d have to flip a on and off. Therefore, we must execute actions right after adding them to ensure the circuit is in a stable state.
Let’s trace through the previous example without calling actions when they are added. Nothing is printed when we call probe because the probe action is not called immediately. Nothing is printed when we propagate setting input-1 to 1 either: it flows through the OR gate, but not through the AND gate because the latter does not know its other input is 1 (that would have required propagating the 0 from input-2 through the other AND & NOT gates). Finally, when we set input-2 to 1 and propagate, it flows through the circuit leaving sum at 0 (still no printing), but changing carry to 1 (which becomes the only thing printed).
(reset)
(define input-1 (make-bad-wire))
(define input-2 (make-bad-wire))
(define sum (make-bad-wire))
(define carry (make-bad-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) =$> ["carry 11 New-value = 1"]# 3.3.4.5 Implementing the agenda
(define make-time-segment cons)
(define segment-time car)
(define segment-queue cdr)
(define (make-agenda) (list 0))
(define (simulation-time agenda) (car agenda))
(define (set-simulation-time! agenda time) (set-car! agenda time))
(define (segments agenda) (cdr agenda))
(define (set-segments! agenda segments) (set-cdr! agenda segments))
(define (first-segment agenda) (car (segments agenda)))
(define (rest-segments agenda) (cdr (segments agenda)))
(define (empty-agenda? agenda)
(null? (segments agenda)))
(define (reset-agenda! agenda)
(set-simulation-time! agenda 0)
(set-segments! agenda '()))
(define (add-to-agenda! time action agenda)
(define (belongs-before? segments)
(or (null? segments)
(< time (segment-time (car segments)))))
(define (make-new-time-segment time action)
(let ((q (make-queue)))
(insert-queue! q action)
(make-time-segment time q)))
(define (add-to-segments! segments)
(if (= (segment-time (car segments)) time)
(insert-queue! (segment-queue (car segments)) action)
(let ((rest (cdr segments)))
(if (belongs-before? rest)
(set-cdr! segments
(cons (make-new-time-segment time action)
(cdr segments)))
(add-to-segments! rest)))))
(let ((segments (segments agenda)))
(if (belongs-before? segments)
(set-segments!
agenda
(cons (make-new-time-segment time action) segments))
(add-to-segments! segments))))
(define (remove-first-agenda-item! agenda)
(let ((q (segment-queue (first-segment agenda))))
(delete-queue! q)
(when (empty-queue? q)
(set-segments! agenda (rest-segments agenda)))))
(define (first-agenda-item agenda)
(if (empty-agenda? agenda)
(error 'first-agenda-item "agenda is empty")
(let ((first-seg (first-segment agenda)))
(set-simulation-time! agenda (segment-time first-seg))
(front-queue (segment-queue first-seg)))))# Exercise 3.32
The FIFO order of procedure queues for each segment must be used because it causes actions to be executed in the same order as they were triggered. If actions A1, A2, and A3 occur in that order, they will be inserted and popped in that order. Executing them in reverse order leads to different, incorrect behaviour. Consider an and-gate whose inputs change from 0, 1 to 1, 0:
(reset)
(define a (make-wire))
(define b (make-wire))
(define c (make-wire))
(set-signal! a 0)
(set-signal! b 1)
(and-gate a b c)
(probe 'c c)
=$> ["c 0 New-value = 0"]
(propagate) =$> ""
(set-signal! a 1)
(set-signal! b 0)
(propagate)
=$> ["c 6 New-value = 1"
"c 6 New-value = 0"]The value of c goes to 1, but settles to 0 once all actions are processed. If we use a stack (FILO) rather than a queue (FIFO) for actions, there will be a mismatch between the execution order and signal calculations. This is because gates calculate new-signal immediately, and only delay setting the output to that value. With FILO behaviour, (set-signal! a 1) will create an action to set c to 1 (since a and b are 1). Then (set-signal! b 0) will create an action to set c to 0, the correct final value. But the actions execute in reverse order, so c ends up incorrectly at 1:
(enable-stack-mode)
(reset)
(define a (make-wire))
(define b (make-wire))
(define c (make-wire))
(set-signal! a 0)
(set-signal! b 1)
(and-gate a b c)
(probe 'c c) =$> ["c 0 New-value = 0"]
(propagate) =$> ""
(set-signal! a 1)
(set-signal! b 0)
(propagate) =$> ["c 6 New-value = 1"]
(disable-stack-mode)# 3.3.5 Propagation of Constraints
# 3.3.5.1 Using the constraint system
(define (celsius-fahrenheit-converter c f)
(let ((u (make-connector))
(v (make-connector))
(w (make-connector))
(x (make-connector))
(y (make-connector)))
(multiplier c w u)
(multiplier v x u)
(adder v y f)
(constant 9 w)
(constant 5 x)
(constant 32 y)))
(define C (make-connector))
(define F (make-connector))
(celsius-fahrenheit-converter C F)
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)
(set-value! C 25 'user)
=$> ["Probe: Celsius temp = 25"
"Probe: Fahrenheit temp = 77"]
(set-value! F 212 'user)
=!> "contradiction: 77 212"
(forget-value! C 'user)
=$> ["Probe: Celsius temp = ?"
"Probe: Fahrenheit temp = ?"]
(set-value! F 212 'user)
=$> ["Probe: Fahrenheit temp = 212"
"Probe: Celsius temp = 100"]# 3.3.5.2 Implementing the constraint system
(define (adder a b sum)
(define (process-new-value)
(cond ((and (has-value? a) (has-value? b))
(set-value! sum (+ (get-value a) (get-value b)) me))
((and (has-value? a) (has-value? sum))
(set-value! b (- (get-value sum) (get-value a)) me))
((and (has-value? b) (has-value? sum))
(set-value! a (- (get-value sum) (get-value b)) me))))
(define (process-forget-value)
(forget-value! sum me)
(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 'adder "unknown request" request))))
(connect a me)
(connect b me)
(connect sum me)
me)
(define (multiplier x y product)
(define (process-new-value)
(cond ((or (and (has-value? x) (zero? (get-value x)))
(and (has-value? y) (zero? (get-value y))))
(set-value! product 0 me))
((and (has-value? x) (has-value? y))
(set-value! product (* (get-value x) (get-value y)) me))
((and (has-value? x) (has-value? product))
(set-value! y (/ (get-value product) (get-value x)) me))
((and (has-value? y) (has-value? product))
(set-value! x (/ (get-value product) (get-value y)) me))))
(define (process-forget-value)
(forget-value! product me)
(forget-value! x me)
(forget-value! y 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 'multiplier "unknown request" request))))
(connect x me)
(connect y me)
(connect product me)
me)
(define (constant value connector)
(define (me request)
(error 'constant "unknown request" request))
(connect connector me)
(set-value! connector value me)
me)
(define (probe name connector)
(define (print-probe value)
(display (format "\nProbe: ~a = ~a" name value)))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(print-probe (get-value connector)))
((eq? request 'I-lost-my-value)
(print-probe "?"))
(else (error 'probe "unknown request" request))))
(connect connector me)
me)# 3.3.5.3 Representing connectors
Moved here from Section 3.3.5.2 to avoid import cycle.
(define (inform-about-value constraint)
(constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
(constraint 'I-lost-my-value))
(define (make-connector)
(let ((value #f)
(informant #f)
(constraints '()))
(define (set-value! new-val setter)
(cond ((not (has-value? me))
(set! value new-val)
(set! informant setter)
(for-each-except setter inform-about-value constraints))
((not (= value new-val))
(error 'set-value! "contradiction" value new-val))
(else 'ignored)))
(define (forget-value! retractor)
(cond ((eq? retractor informant)
(set! informant #f)
(for-each-except retractor inform-about-no-value constraints))
(else 'ignored)))
(define (connect new-constraint)
(unless (memq new-constraint constraints)
(set! constraints (cons new-constraint constraints)))
(when (has-value? me)
(inform-about-value new-constraint)))
(define (me request)
(cond ((eq? request 'has-value?)
(if informant #t #f))
((eq? request 'get-value) value)
((eq? request 'set-value!) set-value!)
((eq? request 'forget-value!) forget-value!)
((eq? request 'connect) connect)
(else (error 'make-connector "unknown operation" request))))
me))
(define (for-each-except exception proc ls)
(define (iter items)
(unless (null? items)
(unless (eq? (car items) exception)
(proc (car items)))
(iter (cdr items))))
(iter ls))
(define (has-value? connector) (connector 'has-value?))
(define (get-value connector) (connector 'get-value))
(define (set-value! connector val who) ((connector 'set-value!) val who))
(define (forget-value! connector who) ((connector 'forget-value!) who))
(define (connect connector constraint) ((connector 'connect) constraint))# Exercise 3.33
(define (averager a b c)
(let ((u (make-connector))
(w (make-connector)))
(adder a b u)
(multiplier c w u)
(constant 2 w)))
(define a (make-connector))
(define b (make-connector))
(define c (make-connector))
(averager a b c)
(probe "a" a)
(probe "c" c)
(set-value! a 10 'user)
=$> ["Probe: a = 10"]
(set-value! b 20 'user)
=$> ["Probe: c = 15"]
(forget-value! a 'user)
=$> ["Probe: a = ?"
"Probe: c = ?"]
(set-value! c 99 'user)
=$> ["Probe: c = 99"
"Probe: a = 178"]# Exercise 3.34
(define (bad-squarer a b)
(multiplier a a b))At first glance, Louis Reasoner’s constraint seems okay:
(define a (make-connector))
(define b (make-connector))
(probe "a" a)
(probe "b" b)
(bad-squarer a b)
(set-value! a 5 'user)
=$> ["Probe: b = 25"
"Probe: a = 5"]However, going the other way doesn’t work:
(forget-value! a 'user)
=$> ["Probe: b = ?"
"Probe: a = ?"]
(set-value! b 49 'user)
=$> ["Probe: b = 49"]Upon reflection, it would be remarkable if it performed a square root without us ever coding the algorithm! The problem is, multiplier is too general. Louis Reasoner’s constraint does not take advantage of the extra information specific to multiplications of a number to itself. It doesn’t know that the multiplicand and the multiplier are the same connector.
# Exercise 3.35
(define (squarer a b)
(define (process-new-value)
(cond ((has-value? a)
(set-value! b (square (get-value a)) me))
((has-value? b)
(if (< (get-value b) 0)
(error 'squarer "square less than 0" (get-value b))
(set-value! a (sqrt (get-value b)) me)))))
(define (process-forget-value)
(forget-value! b)
(forget-value! a)
(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 'squarer "unknown request" request))))
(connect a me)
(connect b me)
me)
(define a (make-connector))
(define b (make-connector))
(probe "a" a)
(squarer a b)
(set-value! b 49 'user) =$> ["Probe: a = 7"]# Exercise 3.36
See whiteboard/exercise-3.36.jpg for the environment diagram.
# Exercise 3.37
(define (celsius->fahrenheit x)
(c+ (c* (c/ (cv 9) (cv 5))
x)
(cv 32)))
(define (cv val) (let ((c (make-connector))) (constant val c) c))
(define (c+ x y) (let ((z (make-connector))) (adder x y z) z))
(define (c- x y) (let ((z (make-connector))) (adder y z x) z))
(define (c* x y) (let ((z (make-connector))) (multiplier x y z) z))
(define (c/ x y) (let ((z (make-connector))) (multiplier y z x) z))
(define C (make-connector))
(define F (celsius->fahrenheit C))
(probe "C" C)
(set-value! F 212 'user) =$> ["Probe: C = 100"]