[Clojure] SICP 3.3.4: A Simulator for Digital Circuits

ch3_3_4.clj

(ns sicp.ch3-3-4)

;;; queue
(defn make-queue []
  (let [q (atom [])]
    (letfn [(empty-queue? []
              (empty? @q))
            (front-queue []
              (first @q))
            (insert-queue! [item]
              (reset! q (conj @q item)))
            (delete-queue! []
              (reset! q (rest @q)))
            (queue-items [] @q)]
      (letfn [(dispatch [op]
                (cond
                  (= op 'empty-queue?) empty-queue?
                  (= op 'front-queue) front-queue
                  (= op 'insert-queue!) insert-queue!
                  (= op 'delete-queue!) delete-queue!
                  (= op 'queue-items) queue-items
                  :else (throw (RuntimeException. (str "NoOp")))))]
        dispatch))))
(defn empty-queue? [q] ((q 'empty-queue?)))
(defn insert-queue! [q item] ((q 'insert-queue!) item))
(defn front-queue [q] ((q 'front-queue)))
(defn delete-queue! [q] ((q 'delete-queue!)))
(defn queue-items [q] ((q 'queue-items)))

;;; wire
(defn call-each [procedures]
  (if (empty? procedures)
    'done
    (do
      ((first procedures))
      (call-each (rest procedures)))))
(defn make-wire []
  (let [signal-value      (atom 0)
        action-procedures (atom [])]
    (letfn [(set-my-signal! [new-value]
               (if-not (= @signal-value new-value)
                 (do (reset! signal-value new-value)
                     (call-each @action-procedures))
                 'done))
            (accept-action-procedure! [proc]
              (reset! action-procedures (cons proc @action-procedures))
              (proc))
            (action-items []
              (println @action-procedures))]
      (letfn [(dispatch [m]
                (cond
                  (= m 'get-signal)    @signal-value
                  (= m 'set-signal!)   set-my-signal!
                  (= m 'add-action!)   accept-action-procedure!
                  (= m 'action-items) action-items
                  :else                (throw (RuntimeException. (str "NoOps")))))]
        dispatch))))
(defn get-signal [wire] (wire 'get-signal))
(defn set-signal! [wire new-value] ((wire 'set-signal!) new-value))
(defn add-action! [wire action-procedure] ((wire 'add-action!) action-procedure))
(defn action-items [wire] ((wire 'action-items)))

;;; agenda
(defn make-agenda [] (atom [0]))
(defn current-time [agenda] (first @agenda))
(defn segments [agenda] (second @agenda))
(defn set-current-time! [agenda time]
  (reset! agenda  [time (segments agenda)]))
(defn set-segments! [agenda segments]
  (reset! agenda [(current-time agenda) segments]))
(defn first-segment [agenda] (first (segments agenda)))
(defn rest-segments [agenda] (rest (segments agenda)))
(defn make-time-segment [time queue] [time queue])
(defn segment-time [s] (first s))
(defn segment-queue [s] (second s))
(defn empty-agenda? [agenda]
  (empty? (segments agenda)))
(defn add-to-agenda! [time action agenda]
  (letfn [(belongs-before? [segments]
            (or (empty? segments)
                (< time (segment-time (first segments)))))
          (make-new-time-segment [time action]
            (let [q (make-queue)]
              (insert-queue! q action)
              (make-time-segment time q)))
          (add-to-segments! [segments]
            (if (= (segment-time (first segments)) time)
              (do
                (insert-queue! (segment-queue (first segments))
                               action)
                segments)
              (if (belongs-before? (rest segments))
                (cons (first segments) (cons (make-new-time-segment time action) (rest segments)))
                (cons (first segments) (add-to-segments! (rest segments))))))]
    (let [segs (segments agenda)]
      (if (belongs-before? segs)
        (set-segments! agenda (cons (make-new-time-segment time action) segs))
        (set-segments! agenda (add-to-segments! segs))))))
(defn 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)))))
(defn first-agenda-item [agenda]
  (if (empty-agenda? agenda)
    (throw (RuntimeException. (str "Agenda is empty")))
    (let [first-seg (first-segment agenda)]
      (set-current-time! agenda (segment-time first-seg))
      (front-queue (segment-queue first-seg)))))

;;; the-agenda
(def the-agenda (make-agenda))
(def inverter-delay 2)
(def and-gate-delay 3)
(def or-gate-delay 5)
(defn after-delay [delay action]
  (add-to-agenda! (+ delay (current-time the-agenda))
                  action
                  the-agenda))

(defn propagate []
  (if (empty-agenda? the-agenda)
    'done
    (let [first-item (first-agenda-item the-agenda)]
      (first-item)
      (remove-first-agenda-item! the-agenda)
      (propagate))))
(defn probe [name wire]
  (add-action! wire
               (fn []
                 (print name)
                 (print " ")
                 (print (current-time the-agenda))
                 (print " New-value = ")
                 (println (get-signal wire)))))

;;; function boxes
(defn logical-not [s]
  (cond
    (zero? s) 1
    (= s 1) 0
    :else (throw (RuntimeException. (str "Invalid Signal")))))
(defn inverter [input output]
  (letfn [(invert-input []
            (let [new-value (logical-not (get-signal input))]
              (after-delay inverter-delay
                           (fn [] (set-signal! output new-value)))))]
    (add-action! input invert-input)
    'ok))
(defn logical-and [a b]
  (cond
    (and (= a 1) (= b 1)) 1
    :else 0))
(defn and-gate [a1 a2 output]
  (letfn [(and-action-procedure []
            (let [new-value (logical-and (get-signal a1) (get-signal a2))]
              (after-delay and-gate-delay (fn [] (set-signal! output new-value)))))]
    (add-action! a1 and-action-procedure)
    (add-action! a2 and-action-procedure)))
(defn logical-or [a b]
  (cond
    (or (= a 1) (= b 1)) 1
    :else 0))
(defn or-gate [a1 a2 output]
  (letfn [(or-action-procedure []
             (let [new-value (logical-or (get-signal a1) (get-signal a2))]
               (after-delay or-gate-delay (fn [] (set-signal! output new-value)))))]
    (add-action! a1 or-action-procedure)
    (add-action! a2 or-action-procedure)))
(defn 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))
(defn 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))
(defn ripple-carry-adder [an bn sn c]
  (letfn [(block [an bn sn c-in c-out]
            (let [a (first an) b (first bn) s (first sn)]
              (if (= 1 (count an))
                (full-adder a b c-in s c)
                (do
                  (full-adder a b c-in s c-out)
                  (block (rest an) (rest bn) (rest sn) c-out (make-wire))))))]
    (block an bn sn (make-wire) (make-wire))))

ch3_3_4_test.clj

(ns sicp.ch3-3-4-test
  (:use [clojure.test :refer :all]
        [sicp.ch3-3-4 :refer :all]))

(deftest queue
  (testing "empty-queue?"
    (let [q (make-queue)]
      (is (empty-queue? q))
      (insert-queue! q 1)
      (is (not (empty-queue? q)))))
  (testing "insert-queue!"
    (let [q (make-queue)]
      (insert-queue! q 1)
      (insert-queue! q 2)
      (insert-queue! q 3)
      (is (= [1 2 3] (queue-items q)))))
  (testing "front-queue"
    (let [q (make-queue)]
      (insert-queue! q 1)
      (insert-queue! q 2)
      (is (= 1 (front-queue q)))))
  (testing "delete-queue!"
    (let [q (make-queue)]
      (insert-queue! q 1)
      (delete-queue! q)
      (is (empty-queue? q)))))

(deftest wire
  (testing "call-each"
    (let [count (atom 0)]
      (letfn [(inc! [] (reset! count (inc @count)))]
        (call-each [inc! inc! inc!])
        (is (= 3 @count)))))
  (testing "get-signal"
    (let [w (make-wire)]
      (is (zero? (get-signal w)))
      (set-signal! w 1)
      (is (= 1 (get-signal w)))))
  (testing "set-signal!"
    (let [w (make-wire)]
      (set-signal! w 1)
      (is (= 1 (get-signal w)))))
  (testing "add-action!"
    (let [w (make-wire) count (atom 0)]
      (add-action! w (fn [] (reset! count (inc @count))))
      (is (= 1 @count))
      (set-signal! w 1)
      (is (= 2 @count))
      (set-signal! w 1)
      (is (= 2 @count)))))

(deftest agenda
  (testing "make-agenda"
    (is (= [0] @(make-agenda))))
  (testing "current-time, set-current-time!"
    (let [a (make-agenda)]
      (set-current-time! a 1)
      (is (= 1 (current-time a)))))
  (testing "segments, set-segments!"
    (let [a (make-agenda)]
      (set-segments! a [1 2])
      (= [1 2] (segments a))))
  (testing "add-to-agenda!"
    (testing "add 1 action"
      (let [a (make-agenda)]
        (add-to-agenda! 1 '1 a)
        (is (= 1 (segment-time (first-segment a))))
        (is (= '1 (front-queue (segment-queue (first-segment a)))))))
    (testing "add 2 same-time action"
      (let [a (make-agenda)]
        (add-to-agenda! 1 '1 a)
        (add-to-agenda! 1 '2 a)
        (is (= 1 (segment-time (first-segment a))))
        (is (= ['1 '2] (queue-items (segment-queue (first-segment a)))))))
    (testing "add 2 different-time action"
      (let [a (make-agenda)]
        (add-to-agenda! 1 '1 a)
        (add-to-agenda! 2 '2 a)
        (is (= 2 (segment-time (second (segments a)))))
        (is (= ['2] (queue-items (segment-queue (second (segments a))))))))
    (testing "add 2 different-time action (reverse-order)"
      (let [a (make-agenda)]
        (add-to-agenda! 2 '2 a)
        (add-to-agenda! 1 '1 a)
        (is (= 2 (segment-time (second (segments a)))))
        (is (= ['2] (queue-items (segment-queue (second (segments a))))))))
    (testing "add 3 different-time action"
      (let [a (make-agenda)]
        (add-to-agenda! 1 '1 a)
        (add-to-agenda! 3 '3 a)
        (add-to-agenda! 2 '2 a)
        (remove-first-agenda-item! a)
        (is (= 2 (segment-time (first (segments a)))))
        (is (= ['2] (queue-items (segment-queue (first (segments a))))))
        (is (= 3 (segment-time (second (segments a)))))
        (is (= ['3] (queue-items (segment-queue (second (segments a)))))))))
  (testing "remove-first-agenda-item!"
    (let [a (make-agenda)]
      (add-to-agenda! 1 '1 a)
      (add-to-agenda! 2 '2 a)
      (remove-first-agenda-item! a)
      (is (= 2 (segment-time (first-segment a))))
      (is (= '2 (front-queue (segment-queue (first-segment a)))))))
  (testing "front-agenda-item"
    (let [a (make-agenda)]
      (add-to-agenda! 1 '1 a)
      (is (= '1 (first-agenda-item a))))))

(deftest function-boxes
  (testing "inverter"
    (let [in (make-wire) out (make-wire)]
      (inverter in out)
      (propagate)
      (is (= 1 (get-signal out)))
      (set-signal! in 1)
      (propagate)
      (is (zero? (get-signal out)))))
  (testing "and-gate"
    (let [a1 (make-wire) a2 (make-wire) out (make-wire)]
      (and-gate a1 a2 out)
      (propagate)
      (is (zero? (get-signal out)))
      (set-signal! a1 1)
      (propagate)
      (is (zero? (get-signal out)))
      (set-signal! a2 1)
      (propagate)
      (is (= 1 (get-signal out)))))
  (testing "or-gate"
    (let [a1 (make-wire) a2 (make-wire) out (make-wire)]
      (or-gate a1 a2 out)
      (propagate)
      (is (zero? (get-signal out)))
      (set-signal! a1 1)
      (propagate)
      (is (= 1 (get-signal out)))
      (set-signal! a2 1)
      (propagate)
      (is (= 1 (get-signal out)))))
  (testing "half-adder"
    (let [a (make-wire) b (make-wire) s (make-wire) c (make-wire)]
      (half-adder a b s c)
      (propagate)
      (is (zero? (get-signal s)))
      (is (zero? (get-signal c)))
      (set-signal! a 1)
      (propagate)
      (is (= 1 (get-signal s)))
      (is (zero? (get-signal c)))
      (set-signal! b 1)
      (propagate)
      (is (zero? (get-signal s)))
      (is (= 1 (get-signal c)))))
  (testing "full-adder"
    (let [a (make-wire) b (make-wire) c-in (make-wire) s (make-wire) c-out (make-wire)]
      (full-adder a b c-in s c-out)
      (propagate)
      (is (zero? (get-signal s)))
      (is (zero? (get-signal c-out)))
      (set-signal! a 1)
      (propagate)
      (is (= 1 (get-signal s)))
      (is (zero? (get-signal c-out)))
      (set-signal! b 1)
      (propagate)
      (is (zero? (get-signal s)))
      (is (= 1 (get-signal c-out)))
      (set-signal! c-in 1)
      (propagate)
      (is (= 1 (get-signal s)))
      (is (= 1 (get-signal c-out)))))
  (testing "ripple-carry-adder"
    (testing "1-bit"
      (let [a (make-wire) b (make-wire) s (make-wire) c-out (make-wire)]
        (ripple-carry-adder [a] [b] [s] c-out)
        (propagate)
        (is (zero? (get-signal s)))
        (is (zero? (get-signal c-out)))
        (set-signal! a 1)
        (set-signal! b 1)
        (propagate)
        (is (zero? (get-signal s)))
        (is (= 1 (get-signal c-out)))))
    (testing "3-bits"
      (letfn [(wire-gen [num]
                (if (= num 0)
                  []
                  (cons (make-wire) (wire-gen (dec num)))))]
        (let [an (wire-gen 3) bn (wire-gen 3) sn (wire-gen 3) c-out (make-wire)]
          (ripple-carry-adder an bn sn c-out)
          (propagate)
          (is (zero? (get-signal (first sn))))
          (is (zero? (get-signal c-out)))
          (set-signal! (first an) 1)
          (set-signal! (second an) 1)
          (set-signal! (first bn) 1)
          (set-signal! (second bn) 1)
          (propagate)
          (is (zero? (get-signal (first sn))))
          (is (= 1 (get-signal (second sn))))
          (is (= 1 (get-signal (second (rest sn)))))
          (is (zero? (get-signal c-out)))
          (set-signal! (second (rest an)) 1)
          (set-signal! (second (rest bn)) 1)
          (propagate)
          (is (zero? (get-signal (first sn))))
          (is (= 1 (get-signal (second sn))))
          (is (= 1 (get-signal (second (rest sn)))))
          (is (= 1 (get-signal c-out))))))))