Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

for best-known algorithms

  • Loading branch information...
commit 3fac99727f08aacda94c579b543a3deee8e0acea 1 parent 6c619f1
@creasyw authored
Showing with 112 additions and 0 deletions.
  1. +112 −0 misc/digital-circuits.scm
View
112 misc/digital-circuits.scm
@@ -0,0 +1,112 @@
+
+(define (call-each procedures)
+ (if (null? procedures) 'done
+ (begin ((car procedures)) (call-each (cdr procedures)))))
+
+;;; Nutable object template
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-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 "Unknown operation -- WIRE" m))))
+ dispatch))
+
+(define (get-signal wire) (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+
+;;; The agenda for scheduling events
+(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 segment))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segemnts agenda)))
+(define (empty-agenda? agenda) (null? (segments agenda)))
+make-queue
+
+(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)
+ (make-time-segment time q)))
+ (define (add-to
+
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action the-agenda))
+
+;;; Operate the agenda while simulation
+(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 a (make-wire))
+(define b (make-wire))
+(define c (make-wire))
+(define d (make-wire))
+(define e (make-wire))
+(define s (make-wire))
+
+(define (logical-and a b) (if (= a b) 1 0))
+
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (inverter input output)
+ (define (inverter-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay invert-delay
+ (lambda () (set-signal! output new-value)))))
+ (add-action! input inverter-input)
+ 'ok)
+
+(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 (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 c1 c2 c-out)
+ 'ok))
+
+
Please sign in to comment.
Something went wrong with that request. Please try again.