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.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 665c255d 2023-08-04 jrmu 
200 665c255d 2023-08-04 jrmu (define (accept-action-procedure! proc)
201 665c255d 2023-08-04 jrmu   (set! action-procedures (cons proc action-procedures)))
202 665c255d 2023-08-04 jrmu 
203 665c255d 2023-08-04 jrmu ;; In that case, the initial state of the system may not be consistent. For example, suppose we had:
204 665c255d 2023-08-04 jrmu 
205 665c255d 2023-08-04 jrmu (define in-wire (make-wire))
206 665c255d 2023-08-04 jrmu (define out-wire (make-wire))
207 665c255d 2023-08-04 jrmu (inverter in-wire out-wire)
208 665c255d 2023-08-04 jrmu 
209 665c255d 2023-08-04 jrmu ;; 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