sicp-3-3-4-the-digital-circuits-simulator-program

#lang racket
(require racket/mpair)

;; CONSTANTS

(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)

;; LOGIC FUNCTIONS

(define (valid-signal? s) (member s '(0 1)))
(define (logical-not s)
  (unless (valid-signal? s) (error "Invalid signal" s))
  (if (zero? s) 1 0))
(define (logical-and s1 s2)
  (unless (valid-signal? s1) (error "Invalid signal" s1))
  (unless (valid-signal? s2) (error "Invalid signal" s2))
  (* s1 s2))
(define (logical-or s1 s2)
  (unless (valid-signal? s1) (error "Invalid signal" s1))
  (unless (valid-signal? s2) (error "Invalid signal" s2))
  (if (positive? (+ s1 s2)) 1 0))

;; LOGIC GATES

(define (inverter input output)
  (define (invert-input)
    (define 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)
    (define 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 (or-gate a1 a2 output)
  (define (or-action-procedure)
    (define 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)

;; ADDERS

(define (half-adder a b s c)
  (define d (make-wire))
  (define 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)
  (define s (make-wire))
  (define c1 (make-wire))
  (define c2 (make-wire))
  (half-adder b c-in s c1)
  (half-adder a s sum c2)
  (or-gate c2 c2 c-out)
  'ok)

(define (ripple-carry-adder as bs ss c)
  ; The book goes from index n to index 1; we go from n - 1 to 0.
  (unless (= (length as)
             (length bs)
             (length ss))
    (error "Lists must be same length -- RIPPLE-CARRY-ADDER" as bs ss))
  (define zero-wire (make-wire))
  (set-signal! zero-wire 0)
  (define (loop i carry)
    (cond [(< i 0) 'ok]
          [else
            ; use c for the last carry
            (define next-carry (if (zero? i) c (make-wire)))
            (full-adder (list-ref as i)
                        (list-ref bs i)
                        carry
                        (list-ref ss i)
                        next-carry)
            (loop (sub1 i) next-carry)]))
  (loop (sub1 (length as))
        zero-wire))

;; WIRES

(define (make-wire)
  (define signal-value 0)
  (define action-procedures empty)
  (define (set-my-signal! new-value)
    (cond [(not (= signal-value new-value))
           (set! signal-value new-value)
           (call-each action-procedures)]
          [else 'done]))
  (define (accept-action-procedure! proc)
    (set! action-procedures (mcons 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)
  (for ([p procedures]) (p))
  'done)

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

;; QUEUES FROM 3.3.2

(define (front-ptr queue) (mcar queue))
(define (rear-ptr queue) (mcdr queue))
(define (set-front-ptr! queue item) (set-mcar! queue item))
(define (set-rear-ptr! queue item) (set-mcdr! queue item))
(define (empty-queue? queue) (null? (front-ptr queue)))
(define (make-queue) (mcons empty empty))
(define (front-queue queue)
  (if (empty-queue? queue)
    (error "FRONT called with an empty queue" queue)
    (mcar (front-ptr queue))))
(define (insert-queue! queue item)
  (define new-pair (mcons item empty))
  (cond [(empty-queue? queue)
         (set-front-ptr! queue new-pair)
         (set-rear-ptr! queue new-pair)
         queue]
        [else
          (set-mcdr! (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 (mcdr (front-ptr queue)))
          queue]))

;; AGENDAS

;; Segments are time, queue pairs.  The queue holds all the actions to be
;; performed at that time.

(define (make-time-segment time queue)
  (mcons time queue))
(define (segment-time s) (mcar s))
(define (segment-queue s) (mcdr s))

;; An agenda is a table of segments sorted by time.  The head of the table is the
;; current time.

(define (make-agenda) (mlist 0))
(define (current-time agenda) (mcar agenda))
(define (set-current-time! agenda time) (set-mcar! agenda time))
(define (segments agenda) (mcdr agenda))
(define (set-segments! agenda segments) (set-mcdr! agenda segments))
(define (first-segment agenda) (mcar (segments agenda)))
(define (rest-segments agenda) (mcdr (segments agenda)))
(define (empty-agenda? agenda) (empty? (segments agenda)))

(define (add-to-agenda! time action agenda)
  (define (belongs-before? segments)
    (or (empty? segments)
        (< time (segment-time (mcar segments)))))
  (define (make-new-time-segment time action)
    (define q (make-queue))
    (insert-queue! q action)
    (make-time-segment time q))
  (define (add-to-segments! segments)
    (cond [(= (segment-time (mcar segments)) time)
           (insert-queue! (segment-queue (mcar segments))
                          action)]
          [else
            (define rest-sgmnts (mcdr segments))
            (if (belongs-before? rest-sgmnts)
              (set-mcdr! segments
                         (mcons (make-new-time-segment time action)
                                (mcdr segments)))
              (add-to-segments! rest-sgmnts))]))
  (define sgmnts (segments agenda))
  (if (belongs-before? sgmnts)
    (set-segments! agenda
                   (mcons (make-new-time-segment time action)
                          sgmnts))
    (add-to-segments! sgmnts)))

(define (remove-first-agenda-item! agenda)
  (define q (segment-queue (first-segment agenda)))
  (delete-queue! q)
  (when (empty-queue? q)
    (set-segments! agenda (rest-segments agenda))))

(define (first-agenda-item agenda)
  (cond [(empty-agenda? agenda)
         (error "Agenda is empty -- FIRST-AGENDA-ITEM")]
        [else
          (define first-seg (first-segment agenda))
          (set-current-time! agenda (segment-time first-seg))
          (front-queue (segment-queue first-seg))]))

;; after-delay, propagate and probe

(define (after-delay delay action)
  (add-to-agenda! (+ delay (current-time the-agenda))
                  action
                  the-agenda))

(define (propagate)
  (cond [(empty-agenda? the-agenda)
         'done]
        [else
          (define first-item (first-agenda-item the-agenda))
          (first-item)
          (remove-first-agenda-item! the-agenda)
          (propagate)]))

(define (probe name wire)
  (add-action! wire
               (lambda ()
                 (printf "~a ~a  New-value = ~a ~n"
                         name
                         (current-time the-agenda)
                         (get-signal wire)))))

;; TEST

;; Use ripple-carry-adder to add 111 to 001 to get 1000.

(define the-agenda (make-agenda))

(define a1 (make-wire))
(define a2 (make-wire))
(define a3 (make-wire))
(set-signal! a1 1)
;; 'done
(set-signal! a2 1)
;; 'done
(set-signal! a3 1)
;; 'done
(define as (list a1 a2 a3))

(define b1 (make-wire))
(define b2 (make-wire))
(define b3 (make-wire))
(set-signal! b1 0)
;; 'done
(set-signal! b2 0)
;; 'done
(set-signal! b3 1)
;; 'done
(define bs (list b1 b2 b3))

(define s1 (make-wire))
(define s2 (make-wire))
(define s3 (make-wire))
(set-signal! s1 0)
;; 'done
(set-signal! s2 0)
;; 'done
(set-signal! s3 0)
;; 'done
(define ss (list s1 s2 s3))

(define c (make-wire))

(probe 's1 s1)
;; s1 0  New-value = 0
(probe 's2 s2)
;; s2 0  New-value = 0
(probe 's3 s3)
;; s3 0  New-value = 0
(probe 'c c)
;; c 0  New-value = 0

(ripple-carry-adder as bs ss c)
;; 'ok

;; Note that all the s wires and the c wire now have probe in their
;; action-procedures lists.  So probe will run any time one of them changes state.

(propagate)
;; s3 8  New-value = 1
;; s2 8  New-value = 1
;; s1 8  New-value = 1
;; s3 16  New-value = 0
;; s2 32  New-value = 0
;; c 48  New-value = 1
;; s1 48  New-value = 0
;; 'done

(probe 's1 s1)
;; s1 48  New-value = 0
(probe 's2 s2)
;; s2 48  New-value = 0
(probe 's3 s3)
;; s3 48  New-value = 0
(probe 'c c)
;; c 48  New-value = 1