From 51f723f38644d99b4ceef8a5bbe9f28b71a6874f Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Wed, 23 Dec 2020 11:04:55 -0500
Subject: [PATCH] Implement till 3.30

---
 .gitignore                          |   1 -
 ex-2_44-52.scm                      |   2 +-
 ex-3_28-xx.scm                      | 218 +++++++++++++++++++++++++++-
 misc/agenda.scm                     |  72 +++++++++
 {picture_language => misc}/draw.scm |   2 +-
 misc/queue.scm                      |  33 +++++
 6 files changed, 324 insertions(+), 4 deletions(-)
 create mode 100644 misc/agenda.scm
 rename {picture_language => misc}/draw.scm (91%)
 create mode 100644 misc/queue.scm

diff --git a/.gitignore b/.gitignore
index 5c40082..e363ff5 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,3 @@
-old_ch2
 # ---> Scheme
 *.py
 *.png
diff --git a/ex-2_44-52.scm b/ex-2_44-52.scm
index 6161c8d..fd2523d 100644
--- a/ex-2_44-52.scm
+++ b/ex-2_44-52.scm
@@ -192,7 +192,7 @@
           (make-line 0.6 0.65 0.65 0.8)
           (make-line 0.65 0.8 0.6 1.0))))
 
-(load "picture_language/draw.scm")
+(load "misc/draw.scm")
 
 (draw-to-py (painter-diamond simple-frame) "wave")
 
diff --git a/ex-3_28-xx.scm b/ex-3_28-xx.scm
index 92ec8f2..eeeb5fe 100644
--- a/ex-3_28-xx.scm
+++ b/ex-3_28-xx.scm
@@ -1,4 +1,220 @@
 (load "util.scm")
+(load "misc/agenda.scm")
+(load "misc/queue.scm")
+
+(display "\nexample - simulator of digital circuits\n")
+
+(define (call-each procedures)
+  (if (null? procedures)
+      'done
+      (begin
+        ((car procedures))
+        (call-each (cdr procedures)))))
+
+(define (make-wire)
+  (let ((signal-value 0) (action-procedures '()))
+    (define (set-my-signal! new-value)
+      (if (not (= signal-value new-value))
+          (begin (set! signal-value new-value)
+                 (call-each action-procedures))
+          'done))
+    (define (accept-action-procedure! proc)
+      (set! action-procedures (cons proc action-procedures))
+      (proc))
+    (define (dispatch m)
+      (cond ((eq? m 'get-signal) signal-value)
+            ((eq? m 'set-signal!) set-my-signal!)
+            ((eq? m 'add-action!) accept-action-procedure!)
+            (else (error "Unknown operation -- WIRE" m))))
+    dispatch))
+
+(define (probe name wire)
+  (add-action! wire
+               (lambda ()
+                 (newline)
+                 (display name)
+                 (display " ")
+                 (display (current-time the-agenda))
+                 (display "  New-value = ")
+                 (display (get-signal wire)))))
+
+(define (get-signal wire)
+  (wire 'get-signal))
+(define (set-signal! wire new-value)
+  ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+  ((wire 'add-action!) action-procedure))
+
+(define the-agenda (make-agenda))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+
+(define (logical-not s)
+  (cond ((= s 0) 1)
+        ((= s 1) 0)
+        (else (error "NOT - invalid signal" s))))
+
+(define (logical-and s1 s2)
+  (cond ((and (= s1 0) (= s2 0)) 0)
+        ((and (= s1 0) (= s2 1)) 0)
+        ((and (= s1 1) (= s2 0)) 0)
+        ((and (= s1 1) (= s2 1)) 1)
+        (else (error "AND - invalid signal"))))
+
+(define (logical-or s1 s2)
+  (cond ((and (= s1 0) (= s2 0)) 0)
+        ((and (= s1 0) (= s2 1)) 1)
+        ((and (= s1 1) (= s2 0)) 1)
+        ((and (= s1 1) (= s2 1)) 1)
+        (else (error "OR - invalid signal"))))
+
+(define (half-adder a b s c)
+  (let ((d (make-wire)) (e (make-wire)))
+    (or-gate a b d)
+    (and-gate a b c)
+    (inverter c e)
+    (and-gate d e s)
+    'ok))
+
+(define (full-adder a b c-in sum c-out)
+  (let ((s (make-wire))
+        (c1 (make-wire))
+        (c2 (make-wire)))
+    (half-adder b c-in s c1)
+    (half-adder a s sum c2)
+    (or-gate c1 c2 c-out)
+    'ok))
+
+(define (inverter input output)
+  (define (invert-input)
+    (let ((new-value (logical-not (get-signal input))))
+      (after-delay inverter-delay
+                   (lambda ()
+                     (set-signal! output new-value)))))
+  (add-action! input invert-input)
+  'ok)
+
+(define (and-gate a1 a2 output)
+  (define (and-action-procedure)
+    (let ((new-value
+           (logical-and (get-signal a1) (get-signal a2))))
+      (after-delay and-gate-delay
+                   (lambda ()
+                     (set-signal! output new-value)))))
+  (add-action! a1 and-action-procedure)
+  (add-action! a2 and-action-procedure)
+  'ok)
+
+(assert (logical-and 1 0) 0)
+(assert (logical-and 1 1) 1)
+
+(display "\nex-3.28 - or-gate\n")
+
+(define (or-gate a1 a2 output)
+  (define (or-action-procedure)
+    (let ((new-value
+           (logical-or (get-signal a1) (get-signal a2))))
+      (after-delay or-gate-delay
+                   (lambda ()
+                     (set-signal! output new-value)))))
+  (add-action! a1 or-action-procedure)
+  (add-action! a2 or-action-procedure)
+  'ok)
+
+(assert (logical-or 0 1) 1)
+(assert (logical-or 1 1) 1)
+
+
+(display "\nex-3.29 - or-gate via and-gate and inverter\n")
+
+(define (nand-gate a1 a2 output)
+  (let ((b (make-wire)))
+    (and-gate a1 a2 b)
+    (inverter b output)
+    'ok))
+
+(define (or-gate-via a1 a2 output)
+  (let ((na1 (make-wire)) (na2 (make-wire)))
+    (inverter a1 na1)
+    (inverter a2 na2)
+    (nand-gate na1 na2 output)
+    'ok))
+
+; The or-gate has three inverter delays and one and-gate delay. The first two
+; inverters can run in parallel so if we implement after-delay correct the
+; total delay should only be two inverter delays and one and-gate delay.
+
+(define a (make-wire))
+(define b (make-wire))
+(define out (make-wire))
+;(probe 'out out)
+
+(or-gate-via a b out)
+
+(set-signal! a 1)
+(set-signal! b 1)
+(propagate)
+(assert (get-signal out) 1)
+
+(set-signal! a 0)
+(set-signal! b 0)
+(propagate)
+(assert (get-signal out) 0)
+
+(display "\nex-3.30 - ripple-carry-adder\n")
+
+; Each full-adder has a delay of three or-gates, four and-gates and two
+; inverters. Again, some of chips in the half-adder could run in parallel, so
+; if after-delay is implemented accordingly the time will be shorter. The delay
+; of the ripple-carry-adder is the delay of the full-adder times the number of
+; input signals n.
+
+(define (ripple-carry-adder as bs ss c)
+  (define c-in (make-wire))
+  (define (wire-ripple-carry-adder as bs ss c-in)
+    (let ((ak (car as)) (bk (car bs))
+          (sk (car ss)) (ck (make-wire)))
+      (if (null? (cdr ss))
+        (full-adder ak bk c-in sk c)
+        (begin
+          (full-adder ak bk c-in sk ck)
+          (wire-ripple-carry-adder
+            (cdr as) (cdr bs) (cdr ss) ck)))))
+  (wire-ripple-carry-adder as bs ss c-in))
+
+(let ((a1 (make-wire)) (a2 (make-wire)) (a3 (make-wire))
+      (b1 (make-wire)) (b2 (make-wire)) (b3 (make-wire))
+      (s1 (make-wire)) (s2 (make-wire)) (s3 (make-wire))
+      (co (make-wire)))
+  (ripple-carry-adder (list a1 a2 a3) (list b1 b2 b3) (list s1 s2 s3) co)
+  (set-signal! a1 1)
+  (set-signal! a2 1)
+  (set-signal! a3 1)
+  (set-signal! b1 1)
+  (set-signal! b2 1)
+  (set-signal! b3 0)
+  (propagate)
+  (assert (get-signal s1) 0)
+  (assert (get-signal s2) 1)
+  (assert (get-signal s3) 0)
+  (assert (get-signal co) 1))
+
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+; (probe 'sum sum)
+; (probe 'carry carry)
+
+(half-adder input-1 input-2 sum carry)
+(set-signal! input-1 1)
+(set-signal! input-2 1)
+(propagate)
+
+(assert (get-signal sum) 0)
+(assert (get-signal carry) 1)
+
+(display "\nex-3.31\n")
 
-(display "\nex-3.28\n")
 
diff --git a/misc/agenda.scm b/misc/agenda.scm
new file mode 100644
index 0000000..ef7319d
--- /dev/null
+++ b/misc/agenda.scm
@@ -0,0 +1,72 @@
+(define (make-time-segment time queue)
+  (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+
+(define (make-agenda) (list 0))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+  (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+  (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+
+(define (empty-agenda? agenda)
+  (null? (segments agenda)))
+
+(define (add-to-agenda! time action agenda)
+  (define (belongs-before? segments)
+    (or (null? segments)
+        (< time (segment-time (car segments)))))
+  (define (make-new-time-segment time action)
+    (let ((q (make-queue)))
+      (insert-queue! q action)
+      (make-time-segment time q)))
+  (define (add-to-segments! segments)
+    (if (= (segment-time (car segments)) time)
+        (insert-queue! (segment-queue (car segments))
+                       action)
+        (let ((rest (cdr segments)))
+          (if (belongs-before? rest)
+              (set-cdr!
+               segments
+               (cons (make-new-time-segment time action)
+                     (cdr segments)))
+              (add-to-segments! rest)))))
+  (let ((segments (segments agenda)))
+    (if (belongs-before? segments)
+        (set-segments!
+         agenda
+         (cons (make-new-time-segment time action)
+               segments))
+        (add-to-segments! segments))))
+
+(define (remove-first-agenda-item! agenda)
+  (let ((q (segment-queue (first-segment agenda))))
+    (delete-queue! q)
+    (if (empty-queue? q)
+        (set-segments! agenda (rest-segments agenda)))))
+
+(define (first-agenda-item agenda)
+  (if (empty-agenda? agenda)
+      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+      (let ((first-seg (first-segment agenda)))
+        (set-current-time! agenda (segment-time first-seg))
+        (front-queue (segment-queue first-seg)))))
+
+(define (after-delay delay action)
+  (add-to-agenda! (+ delay (current-time the-agenda))
+                  action
+                  the-agenda))
+
+(define (propagate)
+  (if (empty-agenda? the-agenda)
+      'done
+      (let ((first-item (first-agenda-item the-agenda)))
+        (first-item)
+        (remove-first-agenda-item! the-agenda)
+        (propagate))))
+
+'agenda-loaded
diff --git a/picture_language/draw.scm b/misc/draw.scm
similarity index 91%
rename from picture_language/draw.scm
rename to misc/draw.scm
index 02518da..5de55c0 100644
--- a/picture_language/draw.scm
+++ b/misc/draw.scm
@@ -1,5 +1,5 @@
 (define (draw-to-py painter name)
-  (define py-name (string-append "picture_language/" name ".py"))
+  (define py-name (string-append "misc/" name ".py"))
   (define img-name (string-append name ".png"))
   (define head (string-append
     "from PIL import Image, ImageDraw\n"
diff --git a/misc/queue.scm b/misc/queue.scm
new file mode 100644
index 0000000..0988b43
--- /dev/null
+++ b/misc/queue.scm
@@ -0,0 +1,33 @@
+; Queue implementation from 3.21
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+
+(define (empty-queue? queue) (null? (front-ptr queue)))
+
+(define (make-queue) (cons '() '()))
+(define (front-queue queue)
+  (if (empty-queue? queue)
+      (error "FRONT called with an empty queue" queue)
+      (car (front-ptr queue))))
+
+(define (insert-queue! queue item)
+  (let ((new-pair (cons item '())))
+    (cond ((empty-queue? queue)
+           (set-front-ptr! queue new-pair)
+           (set-rear-ptr! queue new-pair)
+           queue)
+          (else
+           (set-cdr! (rear-ptr queue) new-pair)
+           (set-rear-ptr! queue new-pair)
+           queue))))
+
+(define (delete-queue! queue)
+  (cond ((empty-queue? queue)
+         (error "DELETE! called with an empty queue" queue))
+        (else
+         (set-front-ptr! queue (cdr (front-ptr queue)))
+         queue)))
+
+'queue-loaded