Ex-3.28 - 3.32

Some code from the book that is needed to run the various solutions..

;queue impl
(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)))

;agenda
(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 the-agenda (make-agenda))
(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))))
;wire
(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 (call-each procedures)
  (if (null? procedures)
      'done
      (begin
        ((car procedures))
        (call-each (cdr procedures)))))
(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))

;adders
(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))

;gates
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(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 (logical-not s)
  (cond ((= s 0) 1)
         ((= s 1) 0)
         (else (error "Invalid signal" s))))

(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)
(define (logical-and s1 s2)
  (cond ((and (= s1 1) (= s2 1)) 1)
 ((or
   (and (= s1 1) (= s2 0))
   (and (= s1 0) (= s2 0))
   (and (= s1 0) (= s2 1))) 0)
 (else (error "Invalid signal" s1 s2))))

;probe
(define (probe name wire)
  (add-action! wire
               (lambda ()
                 (newline)
                 (display name)
                 (display " ")
                 (display (current-time the-agenda))
                 (display " New-value = ")
                 (display (get-signal wire)))))

Ex-3.28

(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)
(define (logical-or s1 s2)
  (cond ((and (= s1 0) (= s2 0)) 0)
 ((or
   (and (= s1 1) (= s2 0))
   (and (= s1 1) (= s2 1))
   (and (= s1 0) (= s2 1))) 1)
 (else (error "Invalid signal" s1 s2))))

;;test
> (define a (make-wire))
> (define b (make-wire))
> (define c (make-wire))
> (or-gate a b c)
ok
> (get-signal c)
0
> (set-signal! a 1)
done
> (propagate)
done
> (get-signal c)
1
> 

Ex-3.29

;A OR B  = -(-A AND -B)
(define (or-gate a1 a2 output)
  (let ((not-a1 (make-wire))
 (not-a2 (make-wire))
 (not-a1-and-not-a2 (make-wire)))
    (inverter a1 not-a1)
    (inverter a2 not-a2)
    (and-gate not-a1 not-a2 not-a1-and-not-a2)
    (inverter not-a1-and-not-a2 output)))

;delay in this case would be
;inverter-delay + and-gate-delay + inverter-delay 

Ex-3.30

(define (ripple-carry-adder Ak Bk Sk C)
  (if (not (null? Ak))
      (let ((c-in (make-wire)))
 (full-adder (car Ak) (car Bk) c-in (car Sk) C)
 (ripple-carry-adder (cdr Ak) (cdr Bk) (cdr Sk) c-in))))

;test
;adding 11 and 10, result should be 101
(define A1 (make-wire))
(define A2 (make-wire))
(define Ak (list A1 A2))
(define B1 (make-wire))
(define B2 (make-wire))
(define Bk (list B1 B2))
(define S1 (make-wire))
(define S2 (make-wire))
(define Sk (list S1 S2))
(define C (make-wire))
(ripple-carry-adder Ak Bk Sk C)

(set-signal! A1 1)
(set-signal! A2 1)
(set-signal! B1 1)
(set-signal! B2 0)
(propagate)

(get-signal C)  ;should be 1
(get-signal S1) ;should be 0 
(get-signal S2) ;should be 1 

Ex-3.31

(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)))
    (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 a (make-wire))
(define b (make-wire))
(define s (make-wire))
(define c (make-wire))

(probe 'a a)
(probe 'b b)
(probe 's s)
(probe 'c c)

(half-adder a b s c)

;proc run for a and b, that sets d
;proc added for a b, that sets c
;proc added for c that sets e
;proc added for d, e that set s 

The initialization is necessary so as to initialize the value of intermediate wires. As in the case of half-adder, due to initialization e gets set to 1. If the initialization calls were not there then e would remain 0 to start with and that will lead to following trouble. Let say you build the half adder circuit with above version of make-wire that doesn't call proc to start with. If you set a to 1, s would still remain 0 though it should be 1 and the reason is following. Here is what will happen when you set a to 1, following procs gets added to the agenda...

(set-signal! d (logical-or 1 0)) ;or of a and b
(set-signal! c (logical-and 1 0)) ;and of a and b

when above are executed, followings get added to the agenda

;and of d and e(NOTICE, e is 0 at this point)
(set-signal! s (logical-and 1 0)) 
(set-signal! e (logical-not 1)) ;not c and s gets set to 1 

Ex-3.32
(a1 a2) change from (0 1) to (1 0)
When signal of a1 changes from 0->1(a2 is still 1) following procedure is added to agenda
(set-signal! output (logical-and 1 1))

and then signal of a2 changes from 1->0(a1 is 1 at this time) following procedure is added to agenda
(set-signal! output (logical-and 1 0))

If above two procedure were run in the lifo order that is
(set-signal! output (logical-and 1 0))
(set-signal! output (logical-and 1 1))
then output is going to be 1, which is wrong. This is why the order is important.