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