1 ;; Exercise 3.28.  Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate. 
2 
3 (define (half-adder a b s c)
4   (let ((d (make-wire)) (e (make-wire)))
5     (or-gate a b d)
6     (and-gate a b c)
7     (inverter c e)
8     (and-gate d e s)
9     'ok))
10 (define (full-adder a b c-in sum c-out)
11   (let ((s (make-wire))
12         (c1 (make-wire))
13         (c2 (make-wire)))
14     (half-adder b c-in s c1)
15     (half-adder a s sum c2)
16     (or-gate c1 c2 c-out)
17     'ok))
18 (define (inverter input output)
19   (define (invert-input)
20     (let ((new-value (logical-not (get-signal input))))
21       (after-delay inverter-delay
22                    (lambda ()
23                      (set-signal! output new-value)))))
24   (add-action! input invert-input)
25   'ok)
26 (define (logical-not s)
27   (cond ((= s 0) 1)
28         ((= s 1) 0)
29         (else (error "Invalid signal" s))))
30 
31 (define (and-gate a1 a2 output)
32   (define (logical-and x y)
33     (* x y))
34   (define (and-action-procedure)
35     (let ((new-value
36            (logical-and (get-signal a1) (get-signal a2))))
37       (after-delay and-gate-delay
38                    (lambda ()
39                      (set-signal! output new-value)))))
40   (add-action! a1 and-action-procedure)
41   (add-action! a2 and-action-procedure)
42   'ok)
43 (define (make-wire)
44   (let ((signal-value 0) (action-procedures '()))
45     (define (set-my-signal! new-value)
46       (if (not (= signal-value new-value))
47           (begin (set! signal-value new-value)
48                  (call-each action-procedures))
49           'done))
50     (define (accept-action-procedure! proc)
51       (set! action-procedures (cons proc action-procedures))
52       (proc))
53     (define (dispatch m)
54       (cond ((eq? m 'get-signal) signal-value)
55             ((eq? m 'set-signal!) set-my-signal!)
56             ((eq? m 'add-action!) accept-action-procedure!)
57             (else (error "Unknown operation -- WIRE" m))))
58     dispatch))
59 (define (call-each procedures)
60   (if (null? procedures)
61       'done
62       (begin
63         ((car procedures))
64         (call-each (cdr procedures)))))
65 (define (get-signal wire)
66   (wire 'get-signal))
67 (define (set-signal! wire new-value)
68   ((wire 'set-signal!) new-value))
69 (define (add-action! wire action-procedure)
70   ((wire 'add-action!) action-procedure))
71 (define (after-delay delay action)
72   (add-to-agenda! (+ delay (current-time the-agenda))
73                   action
74                   the-agenda))
75 (define (propagate)
76   (if (empty-agenda? the-agenda)
77       'done
78       (let ((first-item (first-agenda-item the-agenda)))
79         (first-item)
80         (remove-first-agenda-item! the-agenda)
81         (propagate))))
82 (define (probe name wire)
83   (add-action! wire
84                (lambda ()        
85                  (newline)
86                  (display name)
87                  (display " ")
88                  (display (current-time the-agenda))
89                  (display "  New-value = ")
90                  (display (get-signal wire)))))
91 (define inverter-delay 2)
92 (define and-gate-delay 3)
93 (define or-gate-delay 5)
94 (define input-1 (make-wire))
95 (define input-2 (make-wire))
96 (define sum (make-wire))
97 (define carry (make-wire))
98 (define (make-time-segment time queue)
99   (cons time queue))
100 (define (segment-time s) (car s))
101 (define (segment-queue s) (cdr s))
102 (define (make-agenda) (list 0))
103 (define the-agenda (make-agenda))
104 (define (current-time agenda) (car agenda))
105 (define (set-current-time! agenda time)
106   (set-car! agenda time))
107 (define (segments agenda) (cdr agenda))
108 (define (set-segments! agenda segments)
109   (set-cdr! agenda segments))
110 (define (first-segment agenda) (car (segments agenda)))
111 (define (rest-segments agenda) (cdr (segments agenda)))
112 (define (empty-agenda? agenda)
113   (null? (segments agenda)))
114 (define (add-to-agenda! time action agenda)
115   (define (belongs-before? segments)
116     (or (null? segments)
117         (< time (segment-time (car segments)))))
118   (define (make-new-time-segment time action)
119     (let ((q (make-queue)))
120       (insert-queue! q action)
121       (make-time-segment time q)))
122   (define (add-to-segments! segments)
123     (if (= (segment-time (car segments)) time)
124         (insert-queue! (segment-queue (car segments))
125                        action)
126         (let ((rest (cdr segments)))
127           (if (belongs-before? rest)
128               (set-cdr!
129                segments
130                (cons (make-new-time-segment time action)
131                      (cdr segments)))
132               (add-to-segments! rest)))))
133   (let ((segments (segments agenda)))
134     (if (belongs-before? segments)
135         (set-segments!
136          agenda
137          (cons (make-new-time-segment time action)
138                segments))
139         (add-to-segments! segments))))
140 (define (remove-first-agenda-item! agenda)
141   (let ((q (segment-queue (first-segment agenda))))
142     (delete-queue! q)
143     (if (empty-queue? q)
144         (set-segments! agenda (rest-segments agenda)))))
145 (define (first-agenda-item agenda)
146   (if (empty-agenda? agenda)
147       (error "Agenda is empty -- FIRST-AGENDA-ITEM")
148       (let ((first-seg (first-segment agenda)))
149         (set-current-time! agenda (segment-time first-seg))
150         (front-queue (segment-queue first-seg)))))
151 (define (front-ptr queue) (car queue))
152 (define (rear-ptr queue) (cdr queue))
153 (define (set-front-ptr! queue item) (set-car! queue item))
154 (define (set-rear-ptr! queue item) (set-cdr! queue item))
155 (define (empty-queue? queue) (null? (front-ptr queue)))
156 (define (make-queue) (cons '() '()))(define (front-queue queue)
157   (if (empty-queue? queue)
158       (error "FRONT called with an empty queue" queue)
159       (car (front-ptr queue))))
160 (define (insert-queue! queue item)
161   (let ((new-pair (cons item '())))
162     (cond ((empty-queue? queue)
163            (set-front-ptr! queue new-pair)
164            (set-rear-ptr! queue new-pair)
165            queue)
166           (else
167            (set-cdr! (rear-ptr queue) new-pair)
168            (set-rear-ptr! queue new-pair)
169            queue)))) 
170 (define (delete-queue! queue)
171   (cond ((empty-queue? queue)
172          (error "DELETE! called with an empty queue" queue))
173         (else
174          (set-front-ptr! queue (cdr (front-ptr queue)))
175          queue))) 
176 
177 (define (or-gate a1 a2 output)
178   (define (logical-or x y)
179     (if (or (= x 1) (= y 1))
180 	1
181 	0))
182   (define (or-action-procedure)
183     (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
184       (after-delay or-gate-delay
185 		   (lambda ()
186 		     (set-signal! output new-value)))))
187   (add-action! a1 or-action-procedure)
188   (add-action! a2 or-action-procedure)
189   'ok)
190 
191 ;; the delay is roughly 2*inverter-delay + 1 and-gate-delay
192 
193 ;; Exercise 3.30.  Figure 3.27 shows a ripple-carry adder formed by stringing together n full-adders. This is the simplest form of parallel adder for adding two n-bit binary numbers. The inputs A1, A2, A3, ..., An and B1, B2, B3, ..., Bn are the two binary numbers to be added (each Ak and Bk is a 0 or a 1). The circuit generates S1, S2, S3, ..., Sn, the n bits of the sum, and C, the carry from the addition. Write a procedure ripple-carry-adder that generates this circuit. The procedure should take as arguments three lists of n wires each -- the Ak, the Bk, and the Sk -- and also another wire C. The major drawback of the ripple-carry adder is the need to wait for the carry signals to propagate. What is the delay needed to obtain the complete output from an n-bit ripple-carry adder, expressed in terms of the delays for and-gates, or-gates, and inverters?
194 
195 (define (ripple-carry-adder a b s c)
196   (if (null? a)
197       'done
198       (let ((ak (car a))
199 	    (bk (car b))
200 	    (sk (car s))
201 	    (ck (make-wire)))
202 	(full-adder ak bk ck sk c)
203 	(ripple-carry-adder (cdr a) (cdr b) (cdr s) ck))))
204 
205 ;; returns list of wires with digits
206 (define (make-digits digits)
207   (if (null? digits)
208       '()
209       (let ((digit (car digits))
210 	    (wire (make-wire)))
211 	(set-signal! wire digit)
212 	(cons wire (make-digits (cdr digits))))))
213 
214 (define one-three-six (make-digits '(1 0 0 0 1 0 0 0)))
215 (define seven-five (make-digits '(0 1 0 0 1 0 1 1)))
216 (define sum1 (make-digits '(0 0 0 0 0 0 0 0)))
217 (define carry1 (make-wire))
218 (ripple-carry-adder one-three-six
219 		    seven-five
220 		    sum1
221 		    carry1)
222 (propagate)
223 (define two-three-seven (make-digits '(1 1 1 0 1 1 0 1)))
224 (define one-nine-eight (make-digits '(1 1 0 0 0 1 1 0)))
225 (define sum2 (make-digits '(0 0 0 0 0 0 0 0)))
226 (define carry2 (make-wire))
227 
228 (ripple-carry-adder two-three-seven
229 		    one-nine-eight
230 		    sum2
231 		    carry2)
232 (propagate)
233 
234 (define (test-case actual expected)
235   (newline)
236   (display "Actual:   ")
237   (display actual)
238   (newline)
239   (display "Expected: ")
240   (display expected)
241   (newline))
242 (test-case (map get-signal one-three-six) '(1 0 0 0 1 0 0 0))
243 (test-case (map get-signal seven-five) '(0 1 0 0 1 0 1 1))
244 (test-case (map get-signal sum1) '(1 1 0 1 0 0 1 1))
245 (test-case (get-signal carry1) 0)
246 
247 (test-case (map get-signal two-three-seven)  '(1 1 1 0 1 1 0 1))
248 (test-case (map get-signal one-nine-eight) '(1 1 0 0 0 1 1 0))
249 (test-case (map get-signal sum2) '(1 0 1 1 0 0 1 1))
250 (test-case (get-signal carry2) 1)
251 
252 (define carry3 (make-wire))
253 (ripple-carry-adder '() '() '() carry3)
254 (test-case (get-signal carry3) 0)