Implement till 3.30
parent
d46585c55b
commit
51f723f386
|
|
@ -1,4 +1,3 @@
|
|||
old_ch2
|
||||
# ---> Scheme
|
||||
*.py
|
||||
*.png
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@
|
|||
(make-line 0.6 0.65 0.65 0.8)
|
||||
(make-line 0.65 0.8 0.6 1.0))))
|
||||
|
||||
(load "picture_language/draw.scm")
|
||||
(load "misc/draw.scm")
|
||||
|
||||
(draw-to-py (painter-diamond simple-frame) "wave")
|
||||
|
||||
|
|
|
|||
218
ex-3_28-xx.scm
218
ex-3_28-xx.scm
|
|
@ -1,4 +1,220 @@
|
|||
(load "util.scm")
|
||||
(load "misc/agenda.scm")
|
||||
(load "misc/queue.scm")
|
||||
|
||||
(display "\nexample - simulator of digital circuits\n")
|
||||
|
||||
(define (call-each procedures)
|
||||
(if (null? procedures)
|
||||
'done
|
||||
(begin
|
||||
((car procedures))
|
||||
(call-each (cdr procedures)))))
|
||||
|
||||
(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 (probe name wire)
|
||||
(add-action! wire
|
||||
(lambda ()
|
||||
(newline)
|
||||
(display name)
|
||||
(display " ")
|
||||
(display (current-time the-agenda))
|
||||
(display " New-value = ")
|
||||
(display (get-signal wire)))))
|
||||
|
||||
(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))
|
||||
|
||||
(define the-agenda (make-agenda))
|
||||
(define inverter-delay 2)
|
||||
(define and-gate-delay 3)
|
||||
(define or-gate-delay 5)
|
||||
|
||||
(define (logical-not s)
|
||||
(cond ((= s 0) 1)
|
||||
((= s 1) 0)
|
||||
(else (error "NOT - invalid signal" s))))
|
||||
|
||||
(define (logical-and s1 s2)
|
||||
(cond ((and (= s1 0) (= s2 0)) 0)
|
||||
((and (= s1 0) (= s2 1)) 0)
|
||||
((and (= s1 1) (= s2 0)) 0)
|
||||
((and (= s1 1) (= s2 1)) 1)
|
||||
(else (error "AND - invalid signal"))))
|
||||
|
||||
(define (logical-or s1 s2)
|
||||
(cond ((and (= s1 0) (= s2 0)) 0)
|
||||
((and (= s1 0) (= s2 1)) 1)
|
||||
((and (= s1 1) (= s2 0)) 1)
|
||||
((and (= s1 1) (= s2 1)) 1)
|
||||
(else (error "OR - invalid signal"))))
|
||||
|
||||
(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))
|
||||
|
||||
(define (inverter input output)
|
||||
(define (invert-input)
|
||||
(let ((new-value (logical-not (get-signal input))))
|
||||
(after-delay inverter-delay
|
||||
(lambda ()
|
||||
(set-signal! output new-value)))))
|
||||
(add-action! input invert-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)
|
||||
|
||||
(assert (logical-and 1 0) 0)
|
||||
(assert (logical-and 1 1) 1)
|
||||
|
||||
(display "\nex-3.28 - or-gate\n")
|
||||
|
||||
(define (or-gate a1 a2 output)
|
||||
(define (or-action-procedure)
|
||||
(let ((new-value
|
||||
(logical-or (get-signal a1) (get-signal a2))))
|
||||
(after-delay or-gate-delay
|
||||
(lambda ()
|
||||
(set-signal! output new-value)))))
|
||||
(add-action! a1 or-action-procedure)
|
||||
(add-action! a2 or-action-procedure)
|
||||
'ok)
|
||||
|
||||
(assert (logical-or 0 1) 1)
|
||||
(assert (logical-or 1 1) 1)
|
||||
|
||||
|
||||
(display "\nex-3.29 - or-gate via and-gate and inverter\n")
|
||||
|
||||
(define (nand-gate a1 a2 output)
|
||||
(let ((b (make-wire)))
|
||||
(and-gate a1 a2 b)
|
||||
(inverter b output)
|
||||
'ok))
|
||||
|
||||
(define (or-gate-via a1 a2 output)
|
||||
(let ((na1 (make-wire)) (na2 (make-wire)))
|
||||
(inverter a1 na1)
|
||||
(inverter a2 na2)
|
||||
(nand-gate na1 na2 output)
|
||||
'ok))
|
||||
|
||||
; The or-gate has three inverter delays and one and-gate delay. The first two
|
||||
; inverters can run in parallel so if we implement after-delay correct the
|
||||
; total delay should only be two inverter delays and one and-gate delay.
|
||||
|
||||
(define a (make-wire))
|
||||
(define b (make-wire))
|
||||
(define out (make-wire))
|
||||
;(probe 'out out)
|
||||
|
||||
(or-gate-via a b out)
|
||||
|
||||
(set-signal! a 1)
|
||||
(set-signal! b 1)
|
||||
(propagate)
|
||||
(assert (get-signal out) 1)
|
||||
|
||||
(set-signal! a 0)
|
||||
(set-signal! b 0)
|
||||
(propagate)
|
||||
(assert (get-signal out) 0)
|
||||
|
||||
(display "\nex-3.30 - ripple-carry-adder\n")
|
||||
|
||||
; Each full-adder has a delay of three or-gates, four and-gates and two
|
||||
; inverters. Again, some of chips in the half-adder could run in parallel, so
|
||||
; if after-delay is implemented accordingly the time will be shorter. The delay
|
||||
; of the ripple-carry-adder is the delay of the full-adder times the number of
|
||||
; input signals n.
|
||||
|
||||
(define (ripple-carry-adder as bs ss c)
|
||||
(define c-in (make-wire))
|
||||
(define (wire-ripple-carry-adder as bs ss c-in)
|
||||
(let ((ak (car as)) (bk (car bs))
|
||||
(sk (car ss)) (ck (make-wire)))
|
||||
(if (null? (cdr ss))
|
||||
(full-adder ak bk c-in sk c)
|
||||
(begin
|
||||
(full-adder ak bk c-in sk ck)
|
||||
(wire-ripple-carry-adder
|
||||
(cdr as) (cdr bs) (cdr ss) ck)))))
|
||||
(wire-ripple-carry-adder as bs ss c-in))
|
||||
|
||||
(let ((a1 (make-wire)) (a2 (make-wire)) (a3 (make-wire))
|
||||
(b1 (make-wire)) (b2 (make-wire)) (b3 (make-wire))
|
||||
(s1 (make-wire)) (s2 (make-wire)) (s3 (make-wire))
|
||||
(co (make-wire)))
|
||||
(ripple-carry-adder (list a1 a2 a3) (list b1 b2 b3) (list s1 s2 s3) co)
|
||||
(set-signal! a1 1)
|
||||
(set-signal! a2 1)
|
||||
(set-signal! a3 1)
|
||||
(set-signal! b1 1)
|
||||
(set-signal! b2 1)
|
||||
(set-signal! b3 0)
|
||||
(propagate)
|
||||
(assert (get-signal s1) 0)
|
||||
(assert (get-signal s2) 1)
|
||||
(assert (get-signal s3) 0)
|
||||
(assert (get-signal co) 1))
|
||||
|
||||
(define input-1 (make-wire))
|
||||
(define input-2 (make-wire))
|
||||
(define sum (make-wire))
|
||||
(define carry (make-wire))
|
||||
; (probe 'sum sum)
|
||||
; (probe 'carry carry)
|
||||
|
||||
(half-adder input-1 input-2 sum carry)
|
||||
(set-signal! input-1 1)
|
||||
(set-signal! input-2 1)
|
||||
(propagate)
|
||||
|
||||
(assert (get-signal sum) 0)
|
||||
(assert (get-signal carry) 1)
|
||||
|
||||
(display "\nex-3.31\n")
|
||||
|
||||
(display "\nex-3.28\n")
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,72 @@
|
|||
(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 segments))
|
||||
(define (first-segment agenda) (car (segments agenda)))
|
||||
(define (rest-segments agenda) (cdr (segments agenda)))
|
||||
|
||||
(define (empty-agenda? agenda)
|
||||
(null? (segments agenda)))
|
||||
|
||||
(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-segments! segments)
|
||||
(if (= (segment-time (car segments)) time)
|
||||
(insert-queue! (segment-queue (car segments))
|
||||
action)
|
||||
(let ((rest (cdr segments)))
|
||||
(if (belongs-before? rest)
|
||||
(set-cdr!
|
||||
segments
|
||||
(cons (make-new-time-segment time action)
|
||||
(cdr segments)))
|
||||
(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))))
|
||||
|
||||
(define (remove-first-agenda-item! agenda)
|
||||
(let ((q (segment-queue (first-segment agenda))))
|
||||
(delete-queue! q)
|
||||
(if (empty-queue? q)
|
||||
(set-segments! agenda (rest-segments agenda)))))
|
||||
|
||||
(define (first-agenda-item agenda)
|
||||
(if (empty-agenda? agenda)
|
||||
(error "Agenda is empty -- FIRST-AGENDA-ITEM")
|
||||
(let ((first-seg (first-segment agenda)))
|
||||
(set-current-time! agenda (segment-time first-seg))
|
||||
(front-queue (segment-queue first-seg)))))
|
||||
|
||||
(define (after-delay delay action)
|
||||
(add-to-agenda! (+ delay (current-time the-agenda))
|
||||
action
|
||||
the-agenda))
|
||||
|
||||
(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))))
|
||||
|
||||
'agenda-loaded
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define (draw-to-py painter name)
|
||||
(define py-name (string-append "picture_language/" name ".py"))
|
||||
(define py-name (string-append "misc/" name ".py"))
|
||||
(define img-name (string-append name ".png"))
|
||||
(define head (string-append
|
||||
"from PIL import Image, ImageDraw\n"
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
; Queue implementation from 3.21
|
||||
(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 (empty-queue? queue) (null? (front-ptr queue)))
|
||||
|
||||
(define (make-queue) (cons '() '()))
|
||||
(define (front-queue queue)
|
||||
(if (empty-queue? queue)
|
||||
(error "FRONT called with an empty queue" queue)
|
||||
(car (front-ptr 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)
|
||||
queue)
|
||||
(else
|
||||
(set-cdr! (rear-ptr queue) new-pair)
|
||||
(set-rear-ptr! queue new-pair)
|
||||
queue))))
|
||||
|
||||
(define (delete-queue! queue)
|
||||
(cond ((empty-queue? queue)
|
||||
(error "DELETE! called with an empty queue" queue))
|
||||
(else
|
||||
(set-front-ptr! queue (cdr (front-ptr queue)))
|
||||
queue)))
|
||||
|
||||
'queue-loaded
|
||||
Loading…
Reference in New Issue