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