(define (make-wires)
  (define all-wires '())
  (define stable #f)

  (define (set-signals wires)
    (if wires (begin (if (not (= (get-signal (car wires))
				 (get-next-signal (car wires))))
			 (begin (set! stable #f)
				(set-signal (car wires))))
		     (set-signals (cdr wires)))))
	
  (define (dispatch msg)
    (cond ((eq? 'add (car msg))
	   (set! all-wires (cons (cadr msg) all-wires)))
	  ((eq? 'set-signals (car msg))
	   (set! stable #t)
	   (set-signals all-wires))
	  ((eq? 'stable-wires? (car msg)) stable)
	  ((eq? 'set-stable-wires! (car msg)) (set! stable #f))
	  (else (error "MAKE-GATES: unknown message: " msg))))

  dispatch)

(define *all-wires* (make-wires))
(define (add-a-wire wire) (*all-wires* (list 'add wire)))
(define (set-signals) (*all-wires* (list 'set-signals)))

(define *wire-counter* 0)

(define (make-wire)
  (let ((name (string-append "W" (write-to-string *wire-counter*))))
    (set! *wire-counter* (1+ *wire-counter*))
    (make-named-wire name)))

(define (make-named-wire name)
  (define signal 0)
  (define next-signal 0)
  
  (define (dispatch msg)
    (cond ((eq? 'get-name (car msg)) name)
          ((eq? 'get-signal (car msg)) signal)
	  ((eq? 'get-next-signal (car msg)) next-signal)
	  ((eq? 'set-next-signal (car msg))
	   (set! next-signal (cadr msg)))
	  ((eq? 'set-signal (car msg)) (set! signal next-signal))
	  (else (error "MAKE-WIRE: unknown message: " msg))))

  (add-a-wire dispatch)
  dispatch)

(define (get-signal w) (w (list 'get-signal)))
(define (get-next-signal w) (w (list 'get-next-signal)))
(define (set-signal w) (w (list 'set-signal)))
(define (set-next-signal w s) (w (list 'set-next-signal s)))
(define (get-name w) (w (list 'get-name)))

(define (make-gates)
  (define all-gates '())

  (define (propogate gates)
    (if gates (begin ((car gates)) (propogate (cdr gates)))))
	
  (define (dispatch msg)
    (cond ((eq? 'add (car msg))
	   (set! all-gates (cons (cadr msg) all-gates)))
	  ((eq? 'propogate (car msg))
	   (set-signals)
	   (propogate all-gates))
	  (else (error "MAKE-GATES: unknown message: " msg))))

  dispatch)

(define *all-gates* (make-gates))
(define (add-a-gate action) (*all-gates* (list 'add action)))
(define (propogate)
  (if (*all-wires* (list 'stable-wires?))
      (*all-wires* (list 'set-stable-wires!))
      (begin (*all-gates* (list 'propogate))
	     (propogate))))


(define invert-delay 2)
(define and-delay 3)
(define xor-delay 5)
(define or-delay 5)

(define (delay-gate i o)
  (define (action)
    (set-next-signal o (get-signal i)))
  (add-a-gate action)
  'ok)

(define (delayed-gate n o)
  (cond ((= n 1) o)
	((> n 1) (let ((oi (make-wire)))
		   (delay-gate oi o)
		   (delayed-gate (- n 1) oi)))
	(else (error "DELAY-GATES: n = " n))))

(define (logic-not v) (- 1 v))

(define (invert-gate i o)
  (let ((w (delayed-gate invert-delay o)))
    (define (action)
      (set-next-signal w (logic-not (get-signal i))))
    (add-a-gate action)
    'ok))

(define (logic-and v1 v2) (if (= v1 1) v2 0))
(define (and-gate i1 i2 o)
  (let ((w (delayed-gate and-delay o)))
    (define (action)
      (set-next-signal w (logic-and (get-signal i1) (get-signal i2))))
    (add-a-gate action)
    'ok))

(define (logic-xor v1 v2) (if (= v1 1) (- 1 v2) v2))
(define (xor-gate i1 i2 o)
  (let ((w (delayed-gate xor-delay o)))
    (define (action)
      (set-next-signal w (logic-xor (get-signal i1) (get-signal i2))))
    (add-a-gate action)
    'ok))

(define (logic-or v1 v2) (if (= v1 0) v2 1))
(define (or-gate i1 i2 o)
  (let ((w (delayed-gate or-delay o)))
    (define (action)
      (set-next-signal w (logic-or (get-signal i1) (get-signal i2))))
    (add-a-gate action)
    'ok))

(define (probe w)
  (define (action)
    (display (get-name w))
    (display ": ")
    (display "signal = ")
    (display (get-signal w))
    (display "; next signal = ")
    (display (get-next-signal w))
    (display "\n"))
  (add-a-gate action)
  'ok)

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

(define a (make-named-wire "a"))
(define b (make-named-wire "b"))
(define c-in (make-named-wire "c-in"))
(define sum (make-named-wire "sum"))
(define c-out (make-named-wire "c-out"))
(full-adder a b c-in sum c-out)

(probe sum)
(probe c-out)
(probe c-in)
(probe b)
(probe a)