數字電路的模擬

;基本功能塊
;延時:
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
;inverter
(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 x) (- 1 x))
;and-gate
(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 a b)
  (* a b))
;3.28
;or-gate
(define (or-gate a1 a2 output)
  (define (or-gate-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-gate-procedure)
  (add-action! a2 or-gate-procedure)
  'ok)
(define (logical-or a b)
  (if (>= (+ a b) 1)
      1
      0))
;3.29
;or-gate-delay = and-gate-delay + 2 * inverter-delay
(define (or-gate-2 a1 a2 output)
  (let ((a (make-wire))
        (b (make-wire))
        (c (make-wire)))
    (inverter a1 a)
    (inverter a2 b)
    (and-gate a b c)
    (inverter c output)
    'ok))
;3.30
(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 c2 c1 c-out)
    'ok))
(define (ripple-carry-adder a b s c)
  (if (null? a)
      (set-signal! c 0)
      (let ((c1 (make-wire)))
        (full-adder (car a) (car b) c1 (car s) c)
        (ripple-carry-adder (cdr a) (cdr b) (cdr s) c1)))
  'ok)
;線路的表示
(define (make-wire)
  (let ((signal-value 0)
        (action-procedures '()))
    (define (set-my-signal! new-value)
      (if (not (= new-value signal-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 "wrong operation type"))))
    dispatch))
(define (call-each action-procedures)
  (if (null? action-procedures)
      'done
      (begin
        ((car action-procedures))
        (call-each (cdr action-procedures)))))
(define (get-signal wire)
  (wire 'get-signal))
(define (set-signal! wire new-value)
    ((wire 'set-signal!) new-value))
(define (add-action! wire proc)
  ((wire 'add-action!) proc))
;待處理表的實現
(define (empty-agenda? agenda)
  (null? (segments 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)
  (let ((segments (segments agenda)))
    (if (null? segments)
        (error "first-segment: no segment")
        (car segments))))
(define (rest-segment agenda)
  (let ((segments (segments agenda)))
    (if (null? segments)
        (error "rest-segment: no segment")
        (cdr segments))))
(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)
      (cons time q)))
  (define (add-to-segments! segments)
    (if (= time (segment-time (car segments)))
        (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)
                              rest))
              (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-segment agenda)))))
(define (first-agenda-item agenda)
  (if (empty-agenda? agenda)
      (error "first-agenda-item: agenda empty")
      (let ((first-seg (first-segment agenda)))
        (set-current-time! agenda (segment-time first-seg))
        (front-queue (segment-queue first-seg)))))
;隊列操作
(define (make-queue)
  (cons '() '()))
(define (front-ptr queue)
  (car queue))
(define (rear-ptr queue)
  (cdr queue))
(define (empty-queue? queue)
  (null? (front-ptr queue)))
(define (set-front-ptr! queue item)
  (set-car! queue item))
(define (set-rear-ptr! queue item)
  (set-cdr! queue item))
(define (front-queue queue)
  (if (empty-queue? queue)
      (error "front-queue:queue empty")
      (car (front-ptr queue))))
(define (insert-queue! queue item)
  (let ((new-pair (list 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-queue!:queue empty"))
        (else (set-front-ptr! queue (cdr (front-ptr queue)))
              queue)))

;待處理表
(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))))
;實例:監視器
(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 the-agenda (make-agenda))
(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)
(propagate)
(set-signal! input-2 1)
(propagate)
;級聯進位全加器檢查
;注意結果可能會發生多次變化，因爲不同的線路時延不同
(define the-agenda (make-agenda))
(define (generate-operand n)
  (if (= n 0)
      '()
      (let ((wire (make-wire)))
        (cons wire (generate-operand (- n 1))))))
(define (set-operand! wires operand)
  (if (null? wires)
      'done
      (begin
        (set-signal! (car wires) (car operand))
        (set-operand! (cdr wires) (cdr operand)))))
(define (add-probe s)
  (if (null? s)
      'done
      (begin
        (probe 'sum (car s))
        (add-probe (cdr s)))))
(define a (generate-operand 4))
(define b (generate-operand 4))
(define s (generate-operand 4))
(probe 'sum4 (car s))
(probe 'sum3 (cadr s))
(probe 'sum2 (caddr s))
(probe 'sum1 (cadddr s))
(define c (make-wire))
(probe 'carry c)
(ripple-carry-adder a b s c)
(set-operand! a '(0 0 1 1))
(set-operand! b '(0 1 0 1))
(propagate)