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.32.  The procedures to be run during each time segment of the agenda are kept in a queue. Thus, the procedures for each segment are called in the order in which they were added to the agenda (first in, first out). Explain why this order must be used. In particular, trace the behavior of an and-gate whose inputs change from 0,1 to 1,0 in the same segment and say how the behavior would differ if we stored a segment's procedures in an ordinary list, adding and removing procedures only at the front (last in, first out). 
199 
200 ;; When the input is changed from (0, 1) to (1, 1), the output wire will be set to 1. When the inputs are then changed from (1, 1) to (1, 0), the output wire will be set to 0. However, if we do not use FIFO for the agenda, then the output wire will first be set to 0, then 1, leaving our circuit in an inconsistent state.