Skip to content

Instantly share code, notes, and snippets.

@zxymike93

zxymike93/digital-circuit.rkt

Created April 29, 2020 16:25
Show Gist options
  • Save zxymike93/549611439e4de722cb42efdfc12265a7 to your computer and use it in GitHub Desktop.
Save zxymike93/549611439e4de722cb42efdfc12265a7 to your computer and use it in GitHub Desktop.
Download ZIP
Digital circuit simulator sample code from sicp.
Raw
digital-circuit.rkt
#lang sicp
(define (call-each procs)
(if (not (null? procs))
(begin ((car procs))
(call-each (cdr procs)))))
;; QUEUE
;; (make-queue) -> queue
;; (empty-queue? queue) -> bool
;; (front-queue queue) -> obj
;; (insert-queue! queue obj)
;; (delete-queue! queue)
(define (front-ptr queue)
(car queue))
(define (rear-ptr queue)
(cdr queue))
(define (set-front-ptr! queue item)
(set-car! queue item))
(define (set-rear-ptr! queue item)
(set-cdr! queue item))
(define (make-queue)
(cons '() '()))
(define (empty-queue? queue)
(null? (front-ptr queue)))
(define (front-queue queue)
(if (empty-queue? queue)
(error "FRONT-QUEUE: empty queue")
(car (front-ptr queue))))
;; Add new item at the end of the queue.
(define (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))
(else
(set-cdr! (rear-ptr queue) new-pair)
(set-rear-ptr! queue new-pair)))))
;; Delete front item of the queue.
(define (delete-queue! queue)
(cond ((empty-queue? queue)
(error "DELETE-QUEUE: empty queue"))
(else
(set-front-ptr! queue
(cdr (front-ptr queue))))))
;; WIRE
;; signal: 0/1
;; actions: list of procs
;; (make-wire) -> wire
;; (get-signal wire) -> signal
;; (set-signal! wire signal)
;; (add-action! wire procs)
;; Returns an wire object
(define (make-wire)
(let ((signal 0)
(actions '()))
;; Set local signal to new-value
(define (set-signal! new-value)
(if (not (= signal new-value))
(begin (set! signal new-value)
(call-each actions))))
;; Add new-action to local actions list
(define (add-action! new-action)
(set! actions (cons new-action actions))
(new-action))
(define (dispatch msg)
(cond ((eq? msg 'get-signal) signal)
((eq? msg 'set-signal!) set-signal!)
((eq? msg 'add-action!) add-action!)
(else (error "WIRE: unknown operation " msg))))
dispatch))
(define (get-signal wire) (wire 'get-signal))
(define (set-signal! wire value) ((wire 'set-signal!) value))
(define (add-action! wire action) ((wire 'add-action!) action))
;; SEGMENT: (time, queue)
;; (make-segment time queue) -> segment
;; (create-segment time proc) -> segment
;; (segment-time segment) -> time
;; (segment-queue segment) -> queue
(define (make-segment time queue)
(cons time queue))
(define (create-segment time proc)
(let ((q (make-queue)))
(insert-queue! q proc)
(make-segment time q)))
(define (segment-time s)
(car s))
(define (segment-queue s)
(cdr s))
;; AGENDA: list of segments (starts with a header 0)
;; (make-agenda) -> agenda
;; (current-time agenda) -> time
;; (empty-agenda? agenda) -> boolean
;; (first-agenda agenda) ->
;; (remove-first-agenda! agenda)
;; (add-to-agenda! time proc agenda)
(define (make-agenda)
(list 0))
(define (current-time agenda)
(car agenda))
(define (segments agenda)
(cdr agenda))
(define (set-current-time! agenda time)
(set-car! agenda time))
(define (set-segments! agenda segments)
(set-cdr! agenda segments))
(define (first-segment agenda)
(car (segments agenda)))
(define (rest-segments agenda)
(cdr (segments agenda)))
(define (empty-agenda? agenda)
(null? (segments agenda)))
(define (first-agenda agenda)
(if (empty-agenda? agenda)
(error "FIRST-AGENDA: agenda is empty")
(let ((first (first-segment agenda)))
(set-current-time! agenda (segment-time first))
(front-queue (segment-queue first)))))
(define (remove-first-agenda! agenda)
(let ((q (segment-queue (first-segment agenda))))
(delete-queue! q)
(if (empty-queue? q)
(set-segments! agenda (rest-segments agenda)))))
(define (add-to-agenda! time proc agenda)
;;
(define (belongs-before? ss)
(or (null? ss)
(< time
(segment-time (car ss)))))
;;
(define (add-to-segments! ss)
(if (= (segment-time (car ss)) time)
(insert-queue! (segment-queue (car ss)) proc)
(let ((rest (cdr ss)))
(if (belongs-before? rest)
(set-cdr! ss
(cons (create-segment time proc) rest))
(add-to-segments! rest)))))
;;
(let ((segs (segments agenda)))
(if (belongs-before? segs)
(set-segments! agenda
(cons (create-segment time proc) segs))
(add-to-segments! segs))))
;;
(define (after-delay delay action)
(add-to-agenda! (+ delay (current-time the-agenda))
action
the-agenda))
(define (propagate)
(if (not (empty-agenda? the-agenda))
(let ((first-item (first-agenda the-agenda)))
(first-item)
(remove-first-agenda! the-agenda)
(propagate))))
;; GATE: procs
;; (inverter wire wire)
;; (and-gate wire wire wire)
;; (or-gate wire wire wire)
;; Convert 0 to 1, 1 to 0.
(define (inverter input output)
(define (logical-not s)
(cond ((= s 0) 1)
((= s 1) 0)
(else (error "Invalid signal " s))))
(define (invert-proc)
(let ((new-value (logical-not (get-signal input))))
(after-delay inverter-delay
(lambda () (set-signal! output new-value)))))
(add-action! input invert-proc))
;; Takes two inputs, if both 1 ouputs 1, else 0.
(define (and-gate a1 a2 output)
(define (logical-and s1 s2)
(cond ((and (= s1 1) (= s2 1)) 1)
((or (= s1 0) (= s2 0)) 0)
(else (error "Invalid signal " s1 s2))))
(define (and-proc)
(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-proc)
(add-action! a2 and-proc))
;; Takes two inputs, if either 1 ouputs 1, else 0.
(define (or-gate o1 o2 output)
(define (logical-or s1 s2)
(cond ((or (= s1 1) (= s2 1)) 1)
((and (= s1 0) (= s2 0)) 0)
(else (error "Invalid signal " s1 s2))))
(define (or-proc)
(let ((new-value (logical-or (get-signal o1) (get-signal o2))))
(after-delay or-gate-delay
(lambda () (set-signal! output new-value)))))
(add-action! o1 or-proc)
(add-action! o2 or-proc))
(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)))
;; sample
(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 inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(define a (make-wire))
(define b (make-wire))
(define sum (make-wire))
(define carry (make-wire))
(probe 'sum sum)
(probe 'carry carry)
(half-adder a b sum carry)
;; 0 0 -> 0 0
;(set-signal! a 0)
;(set-signal! b 0)
;; 1 0 -> 0 1
;(set-signal! a 1)
;(set-signal! b 0)
;; 0 1 -> 0 1
;(set-signal! a 0)
;(set-signal! b 1)
;; 1 1 -> 1 0
;(set-signal! a 1)
;(set-signal! b 1)
(propagate)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment