An extremely simple, dumb, slow, but wonderfully easy-to-use circuit simulator and verifier in roughly 450 "actual" lines of code.

circ.lisp

; Install lisp:
;; aptitude install sbcl emacs slime

; Open emacs, and load program:
;; M-x slime

; Now play around:
;; (load "path/to/circ.lisp")
;; (example-1)
;; (example-2)
;; (example-3)

; And most importantly:
;; (print "Have fun! :P")

;;;; Misc and utils.

(defun take (n l)
  (do* ((i 0 (1+ i))
	(rev-ret nil (cons (first rest) rev-ret))
	(rest l (cdr rest)))
       ((>= i n)
	(list (nreverse rev-ret) rest))))
(defun bin-p (e) (typep e 'bit))
(defun binlist-p (n list)
  (and (= n (length list))
       (loop for e in list unless (bin-p e) return nil finally (return t))))
(defun power-of-two (n) (or (ash 1 n) 0))
;; (defmacro forward-slots (instance &rest slots)
;;   (let ((sym (gensym)))
;;   `(let ((,sym ,instance))
;;      ,@(loop for slot in slots
;; 	  if (listp slot)
;; 	    collect (destructuring-bind (name predicate) slot
;; 		      `(when ,predicate (setf (slot-value ,sym ',name) ,name)))
;; 	  else collect `(setf (slot-value ,sym ',slot) ,slot))
;;      ,sym)))
(defun aslist (x)
  (etypecase x
    (list x)
    (symbol (list x))))
(defun as-keyword (sym)
  (intern (symbol-name sym) :keyword))
(defmacro define-plain-condition (name (&body slots) lambda-list &body reporting-code)
  `(define-condition ,name (simple-condition)
     ,(loop for slot in slots
	 collect `(,slot :initarg ,(as-keyword slot)))
     (:report (lambda ,lambda-list ,@reporting-code))))

;;;; Interfaces

(defclass circ-element () ()
  (:documentation "Base class of any circuitry element"))
(defgeneric ingrad (circ-element) (:documentation "How many inputs this element takes"))
(defgeneric outgrad (circ-element) (:documentation "How many outputs this element provides"))
(defgeneric cost (circ-element) (:documentation "How many inputs this element takesThe cost of a single element"))
(defgeneric depth (circ-element) (:documentation "The depth, as defined in the lecture SysArch"))
(defgeneric eval-circ (circ-element in) (:documentation "Evaluate the output, for a given circuit and input"))

(defmethod ingrad ((circ-element (eql nil))) (error "Not appliccable to NIL"))
(defmethod outgrad ((circ-element (eql nil))) (error "Not appliccable to NIL"))
(defmethod cost ((circ-element (eql nil))) (error "Not appliccable to NIL"))
(defmethod depth ((circ-element (eql nil))) (error "Not appliccable to NIL"))
(defmethod eval-circ ((circ-element (eql nil)) in) (error "Not appliccable to NIL"))

;;;; Common stuff

(defun get-circ (thing)
  (etypecase thing
    (symbol (or (get thing 'circ-internal)
		(error "Can't resolve symbol ~a to a circuit." thing)))
    (circ-element thing)))
(defun bind-circ (symbol circ)
  (setf (get symbol 'circ-internal) circ))
(defmethod ingrad ((circ-element symbol)) (ingrad (get-circ circ-element)))
(defmethod outgrad ((circ-element symbol)) (outgrad (get-circ circ-element)))
(defmethod cost ((circ-element symbol)) (cost (get-circ circ-element)))
(defmethod depth ((circ-element symbol)) (depth (get-circ circ-element)))
(defmethod eval-circ ((circ-element symbol) in) (eval-circ (get-circ circ-element) in))

(defmethod eval-circ (el (in list))
  (eval-circ el
	     (make-array (length in)
			 :element-type 'bit
			 :initial-contents in)))

(defgeneric circ-p (thing))
(defmethod circ-p (thing) nil)
(defmethod circ-p ((thing circ-element)) t)
(defmethod circ-p ((thing symbol)) (not (not (get thing 'circ-internal))))

(defmacro compute (op in) `(eval-circ ',op ',in))

;;;; Atomic operators

(defclass circ-function (circ-element)
  ((ingrad :initarg :ingrad
       :initform (error "Initarg :ingrad must be provided"))
   (outgrad :initarg :outgrad
	:initform (error "Initarg :outgrad must be provided"))
   (cost :initarg :cost
	:initform (error "Initarg :cost must be provided"))
   (depth :initarg :depth
	:initform (error "Initarg :depth must be provided"))
   (fn :initarg :fn
	  :type function
	  :initform (error "Initarg :fn must be provided"))))
(defmethod initialize-instance :after ((el circ-function) &key &allow-other-keys)
  (with-slots (ingrad outgrad cost depth fn) el
    (assert (>= ingrad 0))
    (assert (>= outgrad 0))
    (assert (>= cost 0))
    (assert (>= depth 0))
    (assert (functionp fn))))
(defmacro defcirc-fn (op fn &key (in 1) (out 1) (cost 1) (depth 1))
  `(bind-circ ,op (make-instance
		   'circ-function
		   :in ,in :out ,out :cost ,cost :depth ,depth :fn ,fn)))
(defmethod ingrad ((el circ-function)) (slot-value el 'ingrad))
(defmethod outgrad ((el circ-function)) (slot-value el 'outgrad))
(defmethod cost ((el circ-function)) (slot-value el 'cost))
(defmethod depth ((el circ-function)) (slot-value el 'depth))
(defmethod eval-circ ((el circ-function) (in bit-vector))
  (with-slots (ingrad fn) el
    (assert (= (length in) ingrad))
    (funcall fn el in)))

;;;; Definition by table

(defun list2int (list)
  (loop with result = 0
     for e in list
     do (setq result (+ (* 2 result) (ecase e (0 0) (1 1))))
     finally (return result)))
(defun vec2int (vector)
  (loop with result = 0
     for e across vector
     do (setq result (+ (* 2 result) (ecase e (0 0) (1 1))))
     finally (return result)))
(defun int2list (int length)
  (loop repeat length
     with result = nil
     for nextint = (ash int -1)
     do (setq result (cons (- int (ash nextint 1)) result))
     do (setq int nextint)
     finally (progn
	       (assert (= 0 int))
	       (return result))))

(defun list-to-table (list ingrad outgrad)
  (let* ((empty-vec (make-array 0 :element-type 'bit))
	 (table-length (power-of-two ingrad))
	 (table (make-array table-length :element-type 'bit-vector
			    :initial-element empty-vec)))
    (assert (= (length list) table-length))
    (loop
       for e in list
       for (from to) = (take ingrad e)
       for from-idx = (list2int from)
       do (symbol-macrolet ((dest (aref table from-idx)))
	    (if (eq dest empty-vec)
		(setf dest (make-array outgrad :element-type 'bit
				       :initial-contents to))
		(error "Duplicate definition for input ~a" from))))
    (loop for i from 0 to (1- table-length)
       when (eq (aref table i) empty-vec)
	 do (error "Missing definition for input ~a" (int2list i ingrad)))
    table))
(defun vector-to-table (vector ingrad outgrad)
  (let ((table-length (power-of-two ingrad)))
    (assert (= (fill-pointer vector) table-length))
    (make-array table-length
		:element-type 'bit-vector
		:initial-contents
		(loop for i from 0 to (1- table-length)
		   collect
		     (make-array outgrad :element-type 'bit
				 :initial-contents (aref vector i))))))

(defun gen-operator
    (given &key (cost 1) (depth 1)
     (ingrad (error "Ingrad must be provided"))
     (outgrad (error "Outgrad must be provided")))
  (assert (>= ingrad 0))
  (assert (>= outgrad 0))
  (let ((table (etypecase given
		 (list (list-to-table given ingrad outgrad))
		 (vector (vector-to-table given ingrad outgrad)))))
    (flet ((lookup (el in)
	     (declare (ignore el))
	     (aref table (vec2int in))))
      (make-instance 'circ-function :ingrad ingrad :outgrad outgrad
		     :cost cost :depth depth :fn #'lookup))))
(defun define-operator (op &rest operator-args)
  (bind-circ op (apply #'gen-operator operator-args)))
(defmacro defop (op (&key (ingrad nil ingrad-p) (outgrad nil outgrad-p)
			  (cost nil cost-p) (depth nil depth-p))
		 &body table)
  (macrolet ((key (sym)
	       (let ((p-sym
		      (intern (concatenate 'string (symbol-name sym) "-P"))))
		 `(when ,p-sym (list ,(as-keyword sym) ,sym)))))
    `(define-operator ',op
	 ,(if (listp table)
	      (list 'quote table)
	      table)
       ,@(key ingrad) ,@(key outgrad) ,@(key cost) ,@(key depth))))

;;;; Combined circuits

(defun var-p (thing &key allow-constants allow-nil)
  (case thing
    ((t) nil)
    ((nil) allow-nil)
    ((0 1) allow-constants)
    (t (typecase thing
	 (symbol t)
	 (number t) ; Allow numbers for "efficiency" :S
	 (t nil)))))
(defun check-var (thing &key allow-constants)
  (or (var-p thing :allow-constants allow-constants)
      (error "Signal name expected, found ~a instead." thing))
  thing)
(defun varlist-p (list &key allow-constants allow-nil)
  (and (listp list)
       (loop for thing in list
	  unless (var-p thing :allow-constants allow-constants
			:allow-nil allow-nil)
	    return nil
	  finally (return t))))
(defun gen-symbol-table ()
  (let ((symbol-table (make-hash-table)))
    ; Table: varname => (depth, position)
    ; inject initial fake signals
    (setf (gethash 0 symbol-table) '(0 0)
	  (gethash 1 symbol-table) '(0 1)
	  (gethash nil symbol-table) '(0 2))
    symbol-table))
(defun allocate-var (symbol-table var depth)
  (assert (var-p var :allow-nil t))
  (if var
    (symbol-macrolet ((dest (gethash var symbol-table nil)))
      (when dest
	(error "Signal ~a already has been defined in this construction!" var))
      (let ((pos (hash-table-count symbol-table)))
	(setf dest (list depth pos))
	pos))
    2))
(defun allocate-varlist (symbol-table varlist depth)
  (loop for var in varlist
     collect (allocate-var symbol-table var depth) into collected
     finally (return (make-array (length varlist)
				 :initial-contents collected
				 :adjustable nil))))
(defun gather-varlist (symbol-table varlist)
  (loop
     with length = (length varlist)
     for var in varlist
     for (var-depth var-pos) = 
       (or (gethash (check-var var :allow-constants t) symbol-table nil)
	   (error "Signal ~a not (yet) defined in this construction!" var))
     maximize var-depth into depth
     collect var-pos into positions
     finally (return (list
		      depth
		      (make-array length
				  :element-type 'integer
				  :initial-contents positions
				  :adjustable nil)))))

(defun parse (symbol-table op op-args instructions)
  (let ((ingrad (ingrad op))
	(outgrad (outgrad op))
	(cost 0)
	in-varlist)
    (labels ((push-in-var (var)
	       (when (>= (length in-varlist) ingrad)
		 (error "Can't digest ~a: Too many in-arguments." var))
	       (unless (var-p var :allow-constants t)
		 (error "Expected variable, not ~a" var))
	       (push var in-varlist))
	     (push-in-complex (sub-op sub-op-args)
	       (let* ((sub-outgrad (outgrad sub-op))
		      (sub-op-out (loop repeat sub-outgrad
				     for var = (gensym)
				     do (push-in-var var)
				     collect var)))
		 (incf cost
		       (parse symbol-table
			      sub-op
			      ; We might be operating on source code.
			      ; => append the source, Luke
			      (append sub-op-args sub-op-out)
			      instructions)))))	       
      (loop until (null op-args)
	 until (>= (length in-varlist) ingrad)
	 for in-arg = (pop op-args)
	 do (if (atom in-arg)
		(push-in-var in-arg)
		(destructuring-bind (sub-op . sub-args) in-arg
		  (push-in-complex sub-op sub-args))))
      (setf in-varlist (nreverse in-varlist))
      (unless (= (length in-varlist) ingrad)
	(error "Expected ~a in-args, found only ~a."
	       ingrad (length in-varlist)))
      (unless (= (length op-args) outgrad)
	(error "Expected ~a out-args, found only ~a."
	       outgrad (length op-args)))
      (destructuring-bind (depth in-posvec)
	  (gather-varlist symbol-table in-varlist)
	(let* ((out-depth (+ depth (depth op)))
	       (out-posvec (allocate-varlist symbol-table op-args out-depth))
	       (instruction (list op in-posvec out-posvec)))
	  (vector-push-extend instruction instructions)))
      (+ cost (cost op)))))

(defun read-bitvector (fromvec posvec)
  (let* ((length (length posvec))
	 (retvec (make-array length :element-type 'bit)))
    (loop for i from 0 to (1- length)
       do (setf (sbit retvec i)
		(sbit fromvec (aref posvec i))))
    retvec))
(defun write-bitvector (fromvec intovec into-posvec)
  (let ((length (length fromvec)))
    (assert (= length (length into-posvec)))
    (loop for i from 0 to (1- length)
       do (setf (sbit intovec (aref into-posvec i))
		(sbit fromvec i)))))

(defun %construct-thunk% (vargrad instructions out-posvec)
  (declare (type (integer 3) vargrad)
	   (type (vector list) instructions))
  (flet ((thunk (el invec)
	   (declare (type bit-vector invec)
		    (ignore el))
	   (let ((varvec (make-array vargrad :element-type 'bit)))
	     (setf (sbit varvec 0) 0
		   (sbit varvec 1) 1)
	     ; 2 = "don't care"-bit
	     (loop for bit across invec
		for var-i from 3
		for in-i from 0
		do (setf (sbit varvec var-i) (sbit invec in-i)))
	     (loop for (op op-in-posvec op-out-posvec) across instructions
		for op-in = (read-bitvector varvec op-in-posvec)
		for op-out = (eval-circ op op-in)
		do (write-bitvector op-out varvec op-out-posvec))
	     (read-bitvector varvec out-posvec))))
    #'thunk))
  
(defun gen-construct (inputs body outputs)
  (assert (varlist-p inputs :allow-nil t))
  (assert (varlist-p outputs :allow-constants t))
  (let ((symbol-table (gen-symbol-table))
	(instructions (make-array 0 :adjustable t :fill-pointer 0))
	(cost 0))
    ; Input
    (allocate-varlist symbol-table inputs 0)
    ; Throughput
    (loop for (op . op-args) in body
       do (incf cost
		(parse symbol-table op op-args instructions)))
    ; Output
    (destructuring-bind (depth out-posvec)
	  (gather-varlist symbol-table outputs)
      ; Build 
      (make-instance 'circ-function
		     :fn (%construct-thunk% (hash-table-count symbol-table)
					    instructions
					    out-posvec)
		     :depth depth
		     :cost cost
		     :ingrad (length inputs)
		     :outgrad (length outputs)))))

(defun define-construct (op inputs body outputs)
  (bind-circ op (gen-construct inputs body outputs)))

(defmacro construct (op (&rest inputs) (&rest outputs) &body body)
  `(define-construct ',op ',inputs ',body ',outputs))

;;;; Verification


(define-plain-condition circ-diff
  (input
   expected-circ expected-number expected-output
   actual-circ actual-number actual-output)
  (condition stream)
  (with-slots
	(input
	 expected-circ expected-number expected-output
	 actual-circ actual-number actual-output)
      condition
    (format stream
"Difference found for input ~a:~%(C#~a) ~a outputs ~a~%(C#~a) ~a outputs ~a"
	    input
	    expected-number expected-circ expected-output
	    actual-number actual-circ actual-output)))

(define-plain-condition circ-diff-grad
    (one-circ one-number one-ingrad one-outgrad
     other-circ other-number other-ingrad other-outgrad)
    (condition stream)
  (with-slots (one-number one-ingrad one-outgrad
	       other-number other-ingrad other-outgrad) condition
    (format stream
"Circuit ~a and circuit ~a have different grads (~a=>~a and ~a=>~a) and are incomparable"
	    one-number other-number one-ingrad one-outgrad other-ingrad other-outgrad)))

(defun circ-equal (circ-1 &rest circs)
  (if (null circs)
    t
    (let ((nbits (ingrad circ-1))
	  (outbits (outgrad circ-1))
	  (issame t))
      (loop for circ in circs for i = 2 then (1+ i)
	 for other-ingrad = (ingrad circ)
	 for other-outgrad = (outgrad circ)
	 unless (and (= other-ingrad nbits) (= other-outgrad outbits))
	     do (progn
		  (signal (make-condition 'circ-diff-grad
					  :one-circ circ-1 :one-number 1
					  :one-ingrad nbits :one-outgrad outbits
					  :other-circ circ :other-number i
					  :other-ingrad other-ingrad :other-outgrad other-outgrad))
		  (setf issame nil)))
      (and
       issame
       (labels ((run-test (input)
		  (let ((expected-output (eval-circ circ-1 input)))
		    (loop for circ in circs for i = 2 then (1+ i)
		       for actual-output = (eval-circ circ input)
		       unless (equal actual-output expected-output)
		           do (progn
				(setf issame nil)
				(signal (make-condition 'circ-diff :input input
							:expected-circ circ-1 :expected-number 1 :expected-output expected-output
							:actual-circ circ :actual-number i :actual-output actual-output))))))
		(rec-test (remaining fixed)
		  (if (> remaining 0)
		      (progn
			(rec-test (1- remaining) (cons 0 fixed))
			(rec-test (1- remaining) (cons 1 fixed)))
		      (run-test fixed))))
	 (rec-test nbits nil)
	 issame)))))

(defun circ-diagnose (&rest circs)
  (let ((errors nil)
	(error-count 0))
    (flet ((report-diag ()
	     (if (null errors)
		 (values "Circuits compute the same function :)" T)
		 (let (messageparts)
		   (loop for e in errors for i = 1 then (1+ i)
		      do (decf error-count)
		      do (setf messageparts (cons (format nil "~a~%" e)
						  messageparts))
		      when (> i 10) return nil)
		   (setf messageparts
			 (cons 
			  (if (> 0 error-count)
			      (format nil "(~a more differences suppressed)" error-count)
			      "No further differences.")
			  messageparts))
		   (values (apply #'concatenate 'string (nreverse messageparts)) nil)))))
      (flet ((notice (condition)
	       (if (< error-count 100000)
		   (setf errors (cons condition errors)
			 error-count (1+ error-count))
		   (return-from circ-diagnose (report-diag)))))
	(handler-bind ((circ-diff-grad #'notice)
		       (circ-diff #'notice))
	  (apply #'circ-equal circs)))
      (report-diag))))

(defmacro verify-same (&rest circs)
  `(circ-diagnose ,@(mapcar #'(lambda (x) (list 'quote x)) circs)))

(defun load-basic ()
  (defop or (:ingrad 2 :outgrad 1 :cost 1 :depth 1)
    (0 0 0) (0 1 1) (1 0 1) (1 1 1))
  (defop and (:ingrad 2 :outgrad 1 :cost 1 :depth 1)
    (0 0 0) (0 1 0) (1 0 0) (1 1 1))
  (defop not (:ingrad 1 :outgrad 1 :cost 1 :depth 1)
    (0 1) (1 0))
  (defop xor (:ingrad 2 :outgrad 1 :cost 1 :depth 1)
    (0 0 0) (0 1 1) (1 0 1) (1 1 0)))

(defun example-1 ()
  (construct my-xor (a b) (out)
    (and (or a b)
	 (not (and a b))
	 out))
  (verify-same xor my-xor)
  (defop magic-half-adder (:ingrad 3 :outgrad 2 :cost 123 :depth 132)
    (0 0 0 0 0)
    (0 0 1 0 1)
    (0 1 0 0 1)
    (0 1 1 1 0)
    (1 0 0 0 1)
    (1 0 1 1 0)
    (1 1 0 1 0)
    (1 1 1 1 1))
  (construct half-adder (a b c) (c-out s)
    (xor a b a-xor-b)
    (or (and a b)
	(and a-xor-b c)
	c-out)
    (xor a-xor-b c s))
  (verify-same magic-half-adder half-adder))

(defun example-2 ()
  (construct alt-or (a b) (c)
    (not (and (not a) (not b))
	 c))
  (verify-same or alt-or))

(defun example-3 ()
  (construct broken-or (a b) (c)
    (or 0 b c))
  ; Results in this text on the console:

  ;; Difference found for input (1 0):
  ;; (C#1) BROKEN-OR outputs #*0
  ;; (C#2) OR outputs #*1
  ;; No further differences.

  (verify-same broken-or or))