1 (define (half-adder a b s c)
2   (let ((d (make-wire)) (e (make-wire)))
3     (or-gate a b d)
4     (and-gate a b c)
5     (inverter c e)
6     (and-gate d e s)
7     'ok))
8 (define (full-adder a b c-in sum c-out)
9   (let ((s (make-wire))
10         (c1 (make-wire))
11         (c2 (make-wire)))
12     (half-adder b c-in s c1)
13     (half-adder a s sum c2)
14     (or-gate c1 c2 c-out)
15     'ok))
16 (define (inverter input output)
17   (define (invert-input)
18     (let ((new-value (logical-not (get-signal input))))
19       (after-delay inverter-delay
20                    (lambda ()
21                      (set-signal! output new-value)))))
22   (add-action! input invert-input)
23   'ok)
24 (define (logical-not s)
25   (cond ((= s 0) 1)
26         ((= s 1) 0)
27         (else (error "Invalid signal" s))))
28 
29 (define (and-gate a1 a2 output)
30   (define (logical-and x y)
31     (* x y))
32   (define (and-action-procedure)
33     (let ((new-value
34            (logical-and (get-signal a1) (get-signal a2))))
35       (after-delay and-gate-delay
36                    (lambda ()
37                      (set-signal! output new-value)))))
38   (add-action! a1 and-action-procedure)
39   (add-action! a2 and-action-procedure)
40   'ok)
41 (define (make-wire)
42   (let ((signal-value 0) (action-procedures '()))
43     (define (set-my-signal! new-value)
44       (if (not (= signal-value new-value))
45           (begin (set! signal-value new-value)
46                  (call-each action-procedures))
47           'done))
48     (define (accept-action-procedure! proc)
49       (set! action-procedures (cons proc action-procedures))
50       (proc))
51     (define (dispatch m)
52       (cond ((eq? m 'get-signal) signal-value)
53             ((eq? m 'set-signal!) set-my-signal!)
54             ((eq? m 'add-action!) accept-action-procedure!)
55             (else (error "Unknown operation -- WIRE" m))))
56     dispatch))
57 (define (call-each procedures)
58   (if (null? procedures)
59       'done
60       (begin
61         ((car procedures))
62         (call-each (cdr procedures)))))
63 (define (get-signal wire)
64   (wire 'get-signal))
65 (define (set-signal! wire new-value)
66   ((wire 'set-signal!) new-value))
67 (define (add-action! wire action-procedure)
68   ((wire 'add-action!) action-procedure))
69 (define (after-delay delay action)
70   (add-to-agenda! (+ delay (current-time the-agenda))
71                   action
72                   the-agenda))
73 (define (propagate)
74   (if (empty-agenda? the-agenda)
75       'done
76       (let ((first-item (first-agenda-item the-agenda)))
77         (first-item)
78         (remove-first-agenda-item! the-agenda)
79         (propagate))))
80 (define (probe name wire)
81   (add-action! wire
82                (lambda ()        
83                  (newline)
84                  (display name)
85                  (display " ")
86                  (display (current-time the-agenda))
87                  (display "  New-value = ")
88                  (display (get-signal wire)))))
89 (define inverter-delay 2)
90 (define and-gate-delay 3)
91 (define or-gate-delay 5)
92 (define input-1 (make-wire))
93 (define input-2 (make-wire))
94 (define sum (make-wire))
95 (define carry (make-wire))
96 (define (make-time-segment time queue)
97   (cons time queue))
98 (define (segment-time s) (car s))
99 (define (segment-queue s) (cdr s))
100 (define (make-agenda) (list 0))
101 (define the-agenda (make-agenda))
102 (define (current-time agenda) (car agenda))
103 (define (set-current-time! agenda time)
104   (set-car! agenda time))
105 (define (segments agenda) (cdr agenda))
106 (define (set-segments! agenda segments)
107   (set-cdr! agenda segments))
108 (define (first-segment agenda) (car (segments agenda)))
109 (define (rest-segments agenda) (cdr (segments agenda)))
110 (define (empty-agenda? agenda)
111   (null? (segments agenda)))
112 (define (add-to-agenda! time action agenda)
113   (define (belongs-before? segments)
114     (or (null? segments)
115         (< time (segment-time (car segments)))))
116   (define (make-new-time-segment time action)
117     (let ((q (make-queue)))
118       (insert-queue! q action)
119       (make-time-segment time q)))
120   (define (add-to-segments! segments)
121     (if (= (segment-time (car segments)) time)
122         (insert-queue! (segment-queue (car segments))
123                        action)
124         (let ((rest (cdr segments)))
125           (if (belongs-before? rest)
126               (set-cdr!
127                segments
128                (cons (make-new-time-segment time action)
129                      (cdr segments)))
130               (add-to-segments! rest)))))
131   (let ((segments (segments agenda)))
132     (if (belongs-before? segments)
133         (set-segments!
134          agenda
135          (cons (make-new-time-segment time action)
136                segments))
137         (add-to-segments! segments))))
138 (define (remove-first-agenda-item! agenda)
139   (let ((q (segment-queue (first-segment agenda))))
140     (delete-queue! q)
141     (if (empty-queue? q)
142         (set-segments! agenda (rest-segments agenda)))))
143 (define (first-agenda-item agenda)
144   (if (empty-agenda? agenda)
145       (error "Agenda is empty -- FIRST-AGENDA-ITEM")
146       (let ((first-seg (first-segment agenda)))
147         (set-current-time! agenda (segment-time first-seg))
148         (front-queue (segment-queue first-seg)))))
149 (define (front-ptr queue) (car queue))
150 (define (rear-ptr queue) (cdr queue))
151 (define (set-front-ptr! queue item) (set-car! queue item))
152 (define (set-rear-ptr! queue item) (set-cdr! queue item))
153 (define (empty-queue? queue) (null? (front-ptr queue)))
154 (define (make-queue) (cons '() '()))(define (front-queue queue)
155   (if (empty-queue? queue)
156       (error "FRONT called with an empty queue" queue)
157       (car (front-ptr queue))))
158 (define (insert-queue! queue item)
159   (let ((new-pair (cons item '())))
160     (cond ((empty-queue? queue)
161            (set-front-ptr! queue new-pair)
162            (set-rear-ptr! queue new-pair)
163            queue)
164           (else
165            (set-cdr! (rear-ptr queue) new-pair)
166            (set-rear-ptr! queue new-pair)
167            queue)))) 
168 (define (delete-queue! queue)
169   (cond ((empty-queue? queue)
170          (error "DELETE! called with an empty queue" queue))
171         (else
172          (set-front-ptr! queue (cdr (front-ptr queue)))
173          queue))) 
174 
175 (define (or-gate a1 a2 output)
176   (define (logical-or x y)
177     (if (or (= x 1) (= y 1))
178 	1
179 	0))
180   (define (or-action-procedure)
181     (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
182       (after-delay or-gate-delay
183 		   (lambda ()
184 		     (set-signal! output new-value)))))
185   (add-action! a1 or-action-procedure)
186   (add-action! a2 or-action-procedure)
187   'ok)
188 
189 (define (test-case actual expected)
190   (newline)
191   (display "Actual:   ")
192   (display actual)
193   (newline)
194   (display "Expected: ")
195   (display expected)
196   (newline))
197 
198 ;; Exercise 3.31.   The internal procedure accept-action-procedure! defined in make-wire specifies that when a new action procedure is added to a wire, the procedure is immediately run. Explain why this initialization is necessary. In particular, trace through the half-adder example in the paragraphs above and say how the system's response would differ if we had defined accept-action-procedure! as
199 
200 (define (accept-action-procedure! proc)
201   (set! action-procedures (cons proc action-procedures)))
202 
203 ;; In that case, the initial state of the system may not be consistent. For example, suppose we had:
204 
205 (define in-wire (make-wire))
206 (define out-wire (make-wire))
207 (inverter in-wire out-wire)
208 
209 ;; out-wire should be set to 1 but it won't be until in-wire has its value changed, at which point the signal will finally propagate