[SICP][Lisp]デジタル回路のシミュレータ

SCIP 3.3.4 ディジタル回路のシミュレータ をCommon Lisp で書いみたので、貼っておこう。
インバータしか作っていないけど、こういうの作っていて楽しいね。

;; SICP Circuit simulator

;;----------------------------------------
;; queue

(defun make-queue ()
  (cons '() '()))

(defun front-ptr (queue)
  (car queue))

(defun rear-ptr (queue)
  (cdr queue))

(defun set-front-ptr! (queue item)
  (rplaca queue item))

(defun set-rear-ptr! (queue item)
  (rplacd queue item))

(defun empty-queue? (queue)
  (null (front-ptr queue)))

(defun front-queue (queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue ~a" queue)
      (car (front-ptr queue))))

(defun 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)
      (t
       (rplacd (rear-ptr queue) new-pair)
       (set-rear-ptr! queue new-pair)
       queue))))

(defun delete-queue! (queue)
  (cond
    ((empty-queue? queue)
     (error "DELETE! called with an empty queue ~a" queue))
    (t
     (set-front-ptr! queue (cdr (front-ptr queue)))
     queue)))

;;----------------------------------------
;; time segment

(defun make-time-segment (time queue)
  (cons time queue))

(defun segment-time (segment)
  (car segment))

(defun segment-queue (segment)
  (cdr segment))

;;----------------------------------------
;; agenda

(defun make-agenda ()
  (list 0))

(defun current-time (agenda)
  (car agenda))

(defun set-current-time! (agenda time)
  (rplaca agenda time))

(defun segments (agenda)
  (cdr agenda))

(defun set-segments! (agenda segments)
  (rplacd agenda segments))

(defun first-segment (agenda)
  (car (segments agenda)))

(defun rest-segment (agenda)
  (cdr (segments agenda)))

(defun empty-agenda? (agenda)
  (null (segments agenda)))

(defun add-to-agenda! (time action agenda)
  (labels
      ((belongs-before? (segments)
  (or (null segments)
      (< time (segment-time (car segments)))))
       (make-new-time-segment (time action)
  (let ((queue (make-queue)))
    (insert-queue! queue action)
    (make-time-segment time queue)))
       (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)
     (rplacd 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)))))

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

(defun first-agenda-item (agenda)
  (if (empty-agenda? agenda)
      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
      (let ((segment (first-segment agenda)))
 (set-current-time! agenda (segment-time segment))
 (front-queue (segment-queue segment)))))

;;----------------------------------------
;; simulator

(defvar *agenda* nil)

(setf *agenda* (make-agenda))

(defun after-delay (delay action)
  (add-to-agenda! (+ delay (current-time *agenda*)) action *agenda*))

(defun propagate ()
  (if (empty-agenda? *agenda*)
      'done
      (let ((first-item (first-agenda-item *agenda*)))
 (funcall first-item)
 (remove-first-agenda-item! *agenda*)
 (propagate))))

(defun call-each (procs)
  (if (null procs)
      'done
      (progn
 (funcall (car procs))
 (call-each (cdr procs)))))

(defun make-wire ()
  (let ((signal-value 0)
 (action-procs '()))
    (labels ((set-signal! (value)
        (if (= value signal-value)
     'done
     (progn
       (setf signal-value value)
       (call-each action-procs))))
      (add-action! (proc)
        (setf action-procs (cons proc action-procs))
        (funcall proc))
      (dispatch (method)
        (case method
   ('get-signal signal-value)
   ('set-signal! #'set-signal!)
   ('add-action! #'add-action!)
   (t (error "Unknown operation ~a -- WIRE" method)))))
      #'dispatch)))

(defun get-signal (wire)
  (funcall wire 'get-signal))

(defun set-signal! (wire value)
  (funcall (funcall wire 'set-signal!) value))

(defun add-action! (wire proc)
  (funcall (funcall wire 'add-action!) proc))

(defun logical-not (value)
  (cond
    ((= value 0) 1)
    ((= value 1) 0)
    (t (error "Invalid signal ~a" value))))

(defvar *inverter-delay* 2)

(defun inverter (input output)
  (add-action! input
        #'(lambda ()
     (let ((new-value (logical-not (get-signal input))))
       (after-delay *inverter-delay*
      #'(lambda ()
          (set-signal! output new-value))))))
  'ok)

(defun probe (name wire)
  (add-action! wire
        #'(lambda ()
     (format t "~a ~a ~a~%"
      (current-time *agenda*)
      name
      (get-signal wire)))))

;;----------------------------------------
;; circuit

(defparameter w1 (make-wire))
(defparameter w2 (make-wire))

(inverter w1 w2)
(probe "w1" w1)
(probe "w2" w2)

動かしてみる。

0 w1 0
0 w2 0
CL-USER> (propagate)
2 w2 1
DONE
CL-USER> (set-signal! w1 1)
2 w1 1
DONE
CL-USER> (propagate)
4 w2 0
DONE
CL-USER>

もう少しいろいろ遊びたいところだけど、先に進もう。