[sicp] Finish chapter 3
This commit is contained in:
parent
18419b2b07
commit
8bce84a8cc
|
|
@ -0,0 +1,922 @@
|
|||
#lang sicp
|
||||
|
||||
; Exercise 3.1
|
||||
(define (make-accumulator value)
|
||||
(lambda (x)
|
||||
(set! value (+ value x))
|
||||
value))
|
||||
|
||||
; Exercise 3.2
|
||||
(define (make-monitored f)
|
||||
(let ((count 0))
|
||||
(lambda (input)
|
||||
(cond ((eq? input 'how-many-calls?) count)
|
||||
((eq? input 'reset-count) (set! count 0))
|
||||
(else (set! count (inc count))
|
||||
(f input))))))
|
||||
|
||||
(define (make-account balance)
|
||||
(define (withdraw amount)
|
||||
(if (>= balance amount)
|
||||
(begin (set! balance (- balance amount))
|
||||
balance)
|
||||
"Insufficient funds"))
|
||||
(define (deposit amount)
|
||||
(set! balance (+ balance amount))
|
||||
balance)
|
||||
(lambda (request)
|
||||
(cond ((eq? request 'withdraw) withdraw)
|
||||
((eq? request 'deposit) deposit)
|
||||
((eq? request 'balance) balance)
|
||||
(else (error "Unknown request: MAKE-ACCOUNT" request)))))
|
||||
|
||||
; Exercise 3.4
|
||||
(define (make-secure account correct-password)
|
||||
(let ((trials 7))
|
||||
(lambda (password request)
|
||||
(cond ((eq? password correct-password)
|
||||
(set! trials 7)
|
||||
(account request))
|
||||
((= trials 0) (lambda (a) "I'm calling the cops"))
|
||||
(else (set! trials (dec trials))
|
||||
(lambda (a) "Incorrect password"))))))
|
||||
|
||||
(define rand-update
|
||||
(let ((a 2017)
|
||||
(b 5)
|
||||
(m 31))
|
||||
(lambda (x) (modulo (+ (* a x) b) m))))
|
||||
(define rand
|
||||
(let ((x 208))
|
||||
(lambda ()
|
||||
(set! x (rand-update x))
|
||||
x)))
|
||||
|
||||
(define (monte-carlo trials experiment)
|
||||
(define (iter trials-remaining trials-passed)
|
||||
(cond ((= trials-remaining 0) (/ trials-passed trials))
|
||||
((experiment) (iter (dec trials-remaining) (inc trials-passed)))
|
||||
(else (iter (dec trials-remaining) trials-passed))))
|
||||
(iter trials 0))
|
||||
(define (cesaro-test)
|
||||
(= (gcd (random 100) (random 100)) 1))
|
||||
(define (estimate-pi trials)
|
||||
(sqrt (/ 6 (monte-carlo trials cesaro-test))))
|
||||
|
||||
; Exercise 3.5
|
||||
(define (random-in-range low high)
|
||||
(+ low (* (random (- high low)))))
|
||||
(define (estimate-integral P x1 x2 y1 y2 trials)
|
||||
(monte-carlo trials (lambda () (P (random-in-range x1 x2)
|
||||
(random-in-range y1 y2)))))
|
||||
|
||||
; Exercise 3.7
|
||||
(define (make-joint account old-password new-password)
|
||||
(let ((test ((account old-password 'withdraw) 0)))
|
||||
(if (number? test)
|
||||
(make-secure (lambda (request) (account old-password request))
|
||||
new-password)
|
||||
test)))
|
||||
|
||||
; Exercise 3.12
|
||||
(define (last-pair x)
|
||||
(if (null? (cdr x))
|
||||
x
|
||||
(last-pair (cdr x))))
|
||||
(define (append! x y)
|
||||
(set-cdr! (last-pair x) y)
|
||||
x)
|
||||
|
||||
; Exercise 3.13
|
||||
(define (make-cycle x)
|
||||
(set-cdr! (last-pair x) x)
|
||||
x)
|
||||
|
||||
; Exercise 3.14
|
||||
(define (mystery x)
|
||||
(define (loop x y)
|
||||
(if (null? x)
|
||||
y
|
||||
(let ((temp (cdr x)))
|
||||
(set-cdr! x y)
|
||||
(loop temp x))))
|
||||
(loop x '()))
|
||||
|
||||
; Exercise 3.17
|
||||
(define (count-pairs x)
|
||||
(define (adjoin! element set)
|
||||
(cond ((null? set) (set! set (list element))
|
||||
true)
|
||||
((eq? (car set) element) false)
|
||||
((= (length set) 1) (set-cdr! set (list element))
|
||||
true)
|
||||
(else (adjoin! element (cdr set)))))
|
||||
(define counted '())
|
||||
(define (iter struct)
|
||||
(if (and (pair? struct)
|
||||
(cond ((null? counted) (set! counted (list struct)) true)
|
||||
((adjoin! struct counted) true)
|
||||
(else false)))
|
||||
(begin (iter (car struct))
|
||||
(iter (cdr struct)))))
|
||||
(iter x)
|
||||
(display counted)
|
||||
(newline)
|
||||
(length counted))
|
||||
|
||||
; Exercise 3.18
|
||||
(define (in? x lst)
|
||||
(cond ((null? lst) false)
|
||||
((eq? (car lst) x) true)
|
||||
(else (in? x (cdr lst)))))
|
||||
(define (contain-cycle? lst)
|
||||
(define (iter upper lower)
|
||||
(display lower)
|
||||
(display upper)
|
||||
(newline)
|
||||
(cond ((null? lower) false)
|
||||
((in? lower upper) true)
|
||||
(else (iter (cons lower upper) (cdr lower)))))
|
||||
(iter (list lst) (cdr lst)))
|
||||
|
||||
; Exercise 3.19
|
||||
(define (contains-cycle? lst)
|
||||
(define (iter turtoise hare)
|
||||
(cond ((eq? turtoise hare) true)
|
||||
((or (null? hare)
|
||||
(null? (cdr hare))
|
||||
(null? (cddr hare)))
|
||||
false)
|
||||
(else (iter (cdr turtoise) (cddr hare)))))
|
||||
(iter lst (cdr lst)))
|
||||
|
||||
; Exercise 3.22
|
||||
(define (make-queue)
|
||||
(let ((front-ptr '())
|
||||
(rear-ptr '()))
|
||||
(define (set-front-ptr! item) (set! front-ptr item))
|
||||
(define (set-rear-ptr! item) (set! rear-ptr item))
|
||||
(define (empty?) (null? front-ptr))
|
||||
(define (front)
|
||||
(if (empty?)
|
||||
(error "FRONT called with an empty queue")
|
||||
(car front-ptr)))
|
||||
(define (insert! item)
|
||||
(let ((new-pair (list item)))
|
||||
(if (empty?)
|
||||
(set-front-ptr! new-pair)
|
||||
(set-cdr! rear-ptr new-pair))
|
||||
(set-rear-ptr! new-pair))
|
||||
front-ptr)
|
||||
(define (delete!)
|
||||
(if (empty?)
|
||||
(error "DELETE! called with an empty queue")
|
||||
(begin (set-front-ptr! (cdr front-ptr))
|
||||
front-ptr)))
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'front-ptr) (lambda () front-ptr))
|
||||
((eq? m 'rear-ptr) (lambda () rear-ptr))
|
||||
((eq? m 'empty?) empty?)
|
||||
((eq? m 'front) front)
|
||||
((eq? m 'insert!) insert!)
|
||||
((eq? m 'delete!) delete!)
|
||||
(else (error "Unknown procedure: MAKE-QUEUE" m))))
|
||||
dispatch))
|
||||
|
||||
; Exercise 3.23
|
||||
(define (make-deque) (cons '() '()))
|
||||
(define front-deque car)
|
||||
(define rear-deque cdr)
|
||||
(define set-front-deque! set-car!)
|
||||
(define set-rear-deque! set-cdr!)
|
||||
(define (empty-deque? deque) (null? (front-deque deque)))
|
||||
(define (front-insert-deque! deque item)
|
||||
(if (empty-deque? deque)
|
||||
(let ((new-pair (list (list item))))
|
||||
(set-front-deque! deque new-pair)
|
||||
(set-rear-deque! deque new-pair))
|
||||
(begin (set-front-deque! deque (cons (list item) (front-deque deque)))
|
||||
(set-cdr! (cadr (front-deque deque)) (front-deque deque)))))
|
||||
(define (front-delete-deque! deque)
|
||||
(if (empty-deque? deque)
|
||||
(error "FRONT-DELETE! called with an empty deque")
|
||||
(begin (set-front-deque! deque (cdr (front-deque deque)))
|
||||
(if (empty-deque? deque)
|
||||
(set-rear-deque! deque '())
|
||||
(set-cdr! (car (front-deque deque)) '())))))
|
||||
(define (rear-insert-deque! deque item)
|
||||
(if (empty-deque? deque)
|
||||
(let ((new-pair (list (list item))))
|
||||
(set-front-deque! deque new-pair)
|
||||
(set-rear-deque! deque new-pair))
|
||||
(let ((new-rear (list (cons item (rear-deque deque)))))
|
||||
(set-cdr! (rear-deque deque) new-rear)
|
||||
(set-rear-deque! deque new-rear))))
|
||||
(define (rear-delete-deque! deque)
|
||||
(if (empty-deque? deque)
|
||||
(error "REAR-DELETE! called with an empty deque")
|
||||
(let ((new-rear (cdar (rear-deque deque))))
|
||||
(if (null? new-rear)
|
||||
(begin (set-front-deque! deque '())
|
||||
(set-rear-deque! deque '()))
|
||||
(begin (set-cdr! new-rear '())
|
||||
(set-rear-deque! deque new-rear))))))
|
||||
|
||||
; Exercise 3.24 & 3.25
|
||||
(define (make-table same-key?)
|
||||
(define (find key records)
|
||||
(cond ((null? records) false)
|
||||
((same-key? key (caar records)) (car records))
|
||||
(else (assoc key (cdr records)))))
|
||||
(let ((local-table (list '*table*)))
|
||||
(define (lookup . keys)
|
||||
(define (ref keys records)
|
||||
(if (null? keys)
|
||||
records
|
||||
(let ((record (find (car keys) records)))
|
||||
(if record (ref (cdr keys) (cdr record)) false))))
|
||||
(ref keys (cdr local-table)))
|
||||
(define (insert! value . keys)
|
||||
(define (nested lst)
|
||||
(if (null? (cdr lst))
|
||||
(cons (car lst) value)
|
||||
(list (car lst) (nested (cdr lst)))))
|
||||
(define (assign! keys table)
|
||||
(if (null? keys)
|
||||
(set-cdr! table value)
|
||||
(let ((records (cdr table)))
|
||||
(let ((record (find (car keys) records)))
|
||||
(if record
|
||||
(assign! (cdr keys) record)
|
||||
(set-cdr! table (cons (nested keys) records)))))))
|
||||
(assign! keys local-table))
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup) lookup)
|
||||
((eq? m 'insert!) insert!)
|
||||
(else (error "Unknown operation: TABLE" m))))
|
||||
dispatch))
|
||||
|
||||
(define (make-wire)
|
||||
(define (call-each procedures)
|
||||
(if (null? procedures)
|
||||
'done
|
||||
(begin ((car procedures))
|
||||
(call-each (cdr procedures)))))
|
||||
(let ((signal-value false) (action-procedure '()))
|
||||
(define (set-my-signal! new-value)
|
||||
(if (eq? signal-value new-value)
|
||||
'done
|
||||
(begin (set! signal-value new-value)
|
||||
(call-each action-procedure))))
|
||||
(define (add-my-action! proc)
|
||||
(set! action-procedure (cons proc action-procedure))
|
||||
(proc))
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'get-signal) signal-value)
|
||||
((eq? m 'set-signal!) set-my-signal!)
|
||||
((eq? m 'add-action!) add-my-action!)
|
||||
(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))
|
||||
|
||||
(define (after-delay time procedure)
|
||||
; (sleep time)
|
||||
(procedure))
|
||||
(define (inverter input output)
|
||||
(define inverter-delay 0.2)
|
||||
(define (invert-input)
|
||||
(let ((new-value (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-gate-delay 0.5)
|
||||
(define (add-action-procedure)
|
||||
(let ((new-value (and (get-signal a1) (get-signal a2))))
|
||||
(after-delay and-gate-delay (lambda () (set-signal! output new-value)))))
|
||||
(add-action! a1 add-action-procedure)
|
||||
(add-action! a2 add-action-procedure)
|
||||
'ok)
|
||||
; Exercise 3.28
|
||||
(define (or-gate a1 a2 output)
|
||||
(define or-gate-delay 0.3)
|
||||
(define (add-action-procedure)
|
||||
(let ((new-value (or (get-signal a1) (get-signal a2))))
|
||||
(after-delay or-gate-delay (lambda () (set-signal! output new-value)))))
|
||||
(add-action! a1 add-action-procedure)
|
||||
(add-action! a2 add-action-procedure)
|
||||
'ok)
|
||||
; Exercise 3.29
|
||||
(define (not-and-not-gate a1 a2 output)
|
||||
(let ((b1 (make-wire))
|
||||
(b2 (make-wire))
|
||||
(c (make-wire)))
|
||||
; Delay: (+ (* invert-input 3) and-gate-delay)
|
||||
(inverter a1 b1)
|
||||
(inverter a2 b2)
|
||||
(and-gate b1 b2 c)
|
||||
(inverter c output)))
|
||||
|
||||
; Exercise 3.30
|
||||
(define (ripple-carry-adder ays bees eses c-out)
|
||||
(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)))
|
||||
(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)))
|
||||
(let ((c-in (if (null? (cdr ays))
|
||||
(make-wire)
|
||||
(ripple-carry-adder
|
||||
(cdr ays) (cdr bees) (cdr eses) (make-wire)))))
|
||||
(full-adder (car ays) (car bees) c-in (car eses) c-out))
|
||||
c-out)
|
||||
|
||||
(define (inform-about-value constraints) (constraints 'I-have-a-value))
|
||||
(define (inform-about-no-value constraints) (constraints 'I-lost-my-value))
|
||||
(define (make-connector)
|
||||
(define (for-each-except exception procedure lst)
|
||||
(define (iter items)
|
||||
(if (not (null? items))
|
||||
(begin (if (not (eq? (car items) exception)) (procedure (car items)))
|
||||
(iter (cdr items)))))
|
||||
(iter lst))
|
||||
(let ((value false)
|
||||
(informant false)
|
||||
(constraints '()))
|
||||
(define (set-my-value! newval setter)
|
||||
(cond ((not (has-value? me))
|
||||
(set! value newval)
|
||||
(set! informant setter)
|
||||
(for-each-except setter inform-about-value constraints))
|
||||
((= value newval) 'ignored)
|
||||
(else (error "Contradiction" (list value newval)))))
|
||||
(define (forget-my-value! retractor)
|
||||
(if (eq? retractor informant)
|
||||
(begin (set! informant false)
|
||||
(for-each-except retractor inform-about-no-value constraints))
|
||||
'ignored))
|
||||
(define (connect! new-constraint)
|
||||
(if (not (memq new-constraint constraints))
|
||||
(set! constraints (cons new-constraint constraints)))
|
||||
(if (has-value? me)
|
||||
(inform-about-value new-constraint)))
|
||||
(define (me request)
|
||||
(cond ((eq? request 'has-value?) (if informant true false))
|
||||
((eq? request 'get-value) value)
|
||||
((eq? request 'set-value!) set-my-value!)
|
||||
((eq? request 'forget!) forget-my-value!)
|
||||
((eq? request 'connect) connect!)
|
||||
(else (error "Unknown operation: CONNECTOR" request))))
|
||||
me))
|
||||
(define (has-value? connector) (connector 'has-value?))
|
||||
(define (get-value connector) (connector 'get-value))
|
||||
(define (set-value! connector newval informant)
|
||||
((connector 'set-value!) newval informant))
|
||||
(define (forget-value! connector refractor) ((connector 'forget!) refractor))
|
||||
(define (connect connector new-constraint) ((connector 'connect) new-constraint))
|
||||
|
||||
(define (adder a1 a2 sum)
|
||||
(define (process-new-value)
|
||||
(let ((a1? (has-value? a1))
|
||||
(a2? (has-value? a2))
|
||||
(sum? (has-value? sum)))
|
||||
(cond ((and a1? a2?)
|
||||
(set-value! sum (+ (get-value a1) (get-value a2)) me))
|
||||
((and a1? sum?)
|
||||
(set-value! a2 (- (get-value sum) (get-value a1)) me))
|
||||
((and a2? sum?)
|
||||
(set-value! a1 (- (get-value sum) (get-value a2)) me)))))
|
||||
(define (process-forget-value)
|
||||
(forget-value! sum me)
|
||||
(forget-value! a1 me)
|
||||
(forget-value! a2 me)
|
||||
(process-new-value))
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (error "Unknown request: ADDER" request))))
|
||||
(connect a1 me)
|
||||
(connect a2 me)
|
||||
(connect sum me)
|
||||
me)
|
||||
(define (multiplier m1 m2 product)
|
||||
(define (process-new-value)
|
||||
(let ((m1? (has-value? m1))
|
||||
(m2? (has-value? m2))
|
||||
(product? (has-value? product)))
|
||||
(cond ((or (and m1? (= (get-value m1) 0))
|
||||
(and m2? (= (get-value m2) 0)))
|
||||
(set-value! product 0 me))
|
||||
((and m1? m2?)
|
||||
(set-value! product (* (get-value m1) (get-value m2)) me))
|
||||
((and m1? product?)
|
||||
(set-value! m2 (/ (get-value product) (get-value m1)) me))
|
||||
((and m2? product?)
|
||||
(set-value! m1 (/ (get-value product) (get-value m2)) me)))))
|
||||
(define (process-forget-value)
|
||||
(forget-value! product me)
|
||||
(forget-value! m1 me)
|
||||
(forget-value! m2 me)
|
||||
(process-new-value))
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (error "Unknown request: MULTIPLIER" request))))
|
||||
(connect m1 me)
|
||||
(connect m2 me)
|
||||
(connect product me)
|
||||
me)
|
||||
(define (constant value connector)
|
||||
(define (me request)
|
||||
(error "Unknown request: CONSTANT" request))
|
||||
(connect connector me)
|
||||
(set-value! connector value me)
|
||||
me)
|
||||
(define (probe name connector)
|
||||
(define (print-probe value)
|
||||
(display "Probe: ")
|
||||
(display name)
|
||||
(display " = ")
|
||||
(display value)
|
||||
(newline))
|
||||
(define (process-new-value) (print-probe (get-value connector)))
|
||||
(define (process-forget-value) (print-probe "?"))
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (error "Unknown request: PROBE" request))))
|
||||
(connect connector me)
|
||||
me)
|
||||
|
||||
(define (celsius-fahrenheit-converter c f)
|
||||
(let ((u (make-connector))
|
||||
(v (make-connector))
|
||||
(w (make-connector))
|
||||
(x (make-connector))
|
||||
(y (make-connector)))
|
||||
(constant 9 w)
|
||||
(multiplier c w u)
|
||||
(constant 32 y)
|
||||
(adder v y f) ; i.e. v + y = f or v = f - y = f - 32
|
||||
(constant 5 x)
|
||||
(multiplier v x u))
|
||||
'ok)
|
||||
|
||||
; Exercise 3.33
|
||||
(define (averager a b c)
|
||||
(let ((two (make-connector))
|
||||
(sum (make-connector)))
|
||||
(constant 2 two)
|
||||
(multiplier c two sum)
|
||||
(adder a b sum))
|
||||
'ok)
|
||||
|
||||
; Exercise 3.34
|
||||
(define (square x) (* x x))
|
||||
(define (squarer a b)
|
||||
(define (process-new-value)
|
||||
(if (has-value? b)
|
||||
(let ((bval (get-value b)))
|
||||
(if (< bval 0)
|
||||
(error "square less than 0: SQUARER" bval)
|
||||
(set-value! a (sqrt bval) me)))
|
||||
(if (has-value? a)
|
||||
(set-value! b (square (get-value a)) me))))
|
||||
(define (process-forget-value)
|
||||
(forget-value! a me)
|
||||
(forget-value! b me)
|
||||
(process-new-value))
|
||||
(define (me request)
|
||||
(cond ((eq? request 'I-have-a-value) (process-new-value))
|
||||
((eq? request 'I-lost-my-value) (process-forget-value))
|
||||
(else (error "Unknown request: SQUARER" request))))
|
||||
(connect a me)
|
||||
(connect b me)
|
||||
me)
|
||||
|
||||
; Exercise 3.37
|
||||
(define (c+ x y)
|
||||
(let ((z (make-connector)))
|
||||
(adder x y z)
|
||||
z))
|
||||
(define (c- x y)
|
||||
(let ((z (make-connector)))
|
||||
(adder y z x)
|
||||
z))
|
||||
(define (c* x y)
|
||||
(let ((z (make-connector)))
|
||||
(multiplier x y z)
|
||||
z))
|
||||
(define (c/ x y)
|
||||
(let ((z (make-connector)))
|
||||
(multiplier y z x)
|
||||
z))
|
||||
(define (cv val)
|
||||
(let ((z (make-connector)))
|
||||
(constant val z)
|
||||
z))
|
||||
(define (c2f x) (c+ (c* (c/ (cv 9) (cv 5)) x) (cv 32)))
|
||||
|
||||
(define parallel-execute for-each) ; so that test can be run
|
||||
(define (test-and-set! cell)
|
||||
(if (car cell)
|
||||
true
|
||||
(begin (set-car! cell true) false)))
|
||||
(define (make-mutex)
|
||||
(let ((cell (list false)))
|
||||
(define (the-mutex m)
|
||||
(cond ((eq? m 'acquire) (if (test-and-set! cell)
|
||||
(the-mutex 'acquire)))
|
||||
((eq? m 'release) (set-car! cell false))))
|
||||
the-mutex))
|
||||
(define (make-serializer)
|
||||
(let ((mutex (make-mutex)))
|
||||
(lambda (p)
|
||||
(lambda args
|
||||
(mutex 'acquire)
|
||||
(let ((val (apply p args)))
|
||||
(mutex 'release)
|
||||
val)))))
|
||||
|
||||
; Exercise 3.47
|
||||
(define (make-semaphore n)
|
||||
(define (test-n-set! cell)
|
||||
(if (> (car cell) 0)
|
||||
true
|
||||
(begin (set-car! cell (dec (car cell)))
|
||||
false)))
|
||||
(let ((cell (list n)))
|
||||
(define (the-semaphore m)
|
||||
(cond ((eq? m 'acquire) (if (test-n-set! cell)
|
||||
(the-semaphore 'acquire)))
|
||||
((eq? m 'release) (set-car! cell n))))
|
||||
the-semaphore))
|
||||
|
||||
; Exercise 3.48
|
||||
(define (make-account-maker)
|
||||
(let ((next-id 0))
|
||||
(lambda (balance)
|
||||
(define (withdraw amount)
|
||||
(if (>= balance amount)
|
||||
(begin (set! balance (- balance amount))
|
||||
balance)
|
||||
"Insufficient funds"))
|
||||
(define (deposit amount)
|
||||
(set! balance (+ balance amount))
|
||||
balance)
|
||||
(let ((serializer (make-serializer))
|
||||
(id next-id))
|
||||
(define (dispatch request)
|
||||
(cond ((eq? request 'withdraw) withdraw)
|
||||
((eq? request 'deposit) deposit)
|
||||
((eq? request 'balance) balance)
|
||||
((eq? request 'serializer) serializer)
|
||||
((eq? request 'id) id)
|
||||
(else (error "Unknown request: MAKE-ACCOUNT" request))))
|
||||
(set! next-id (inc id))
|
||||
dispatch))))
|
||||
(define (serialized-exchange older newer)
|
||||
(define (exchange acc0 acc1)
|
||||
(let ((diff (- (acc0 'balance) (acc1 'balance))))
|
||||
((acc0 'withdraw) diff)
|
||||
((acc1 'deposit) diff)))
|
||||
(let ((old (older 'id))
|
||||
(new (newer 'id)))
|
||||
(cond ((< old new)
|
||||
(let ((old-serializer (older 'serializer))
|
||||
(new-serializer (newer 'serializer)))
|
||||
((new-serializer (old-serializer exchange)) older newer)))
|
||||
((> old new) (serialized-exchange newer older)))))
|
||||
|
||||
(define stream-car car)
|
||||
(define (stream-cdr stream) (force (cdr stream)))
|
||||
(define (stream-ref s n)
|
||||
(if (= n 0)
|
||||
(stream-car s)
|
||||
(stream-ref (stream-cdr s) (dec n))))
|
||||
(define (stream-map proc s)
|
||||
(if (stream-null? s)
|
||||
the-empty-stream
|
||||
(cons-stream (proc (stream-car s))
|
||||
(stream-map proc (stream-cdr s)))))
|
||||
(define (stream-for-each proc s)
|
||||
(if (not (stream-null? s))
|
||||
(begin (proc (stream-car s))
|
||||
(stream-for-each proc (stream-cdr s)))))
|
||||
(define (stream-range . args)
|
||||
(define (iter start stop step)
|
||||
(if (< start stop)
|
||||
(cons-stream start (iter (+ start step) stop step))
|
||||
the-empty-stream))
|
||||
(let ((n (length args)))
|
||||
(cond ((= n 1) (iter 0 (car args) 1))
|
||||
((= n 2) (iter (car args) (cadr args) 1))
|
||||
((= n 3) (apply iter args))
|
||||
(else the-empty-stream))))
|
||||
(define (stream-filter pred stream)
|
||||
(cond ((stream-null? stream) the-empty-stream)
|
||||
((pred (stream-car stream))
|
||||
(cons-stream (stream-car stream)
|
||||
(stream-filter pred (stream-cdr stream))))
|
||||
(else (stream-filter pred (stream-cdr stream)))))
|
||||
|
||||
; Exercise 3.50
|
||||
(define (filter pred lst)
|
||||
(cond ((null? lst) '())
|
||||
((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
|
||||
(else (filter pred (cdr lst)))))
|
||||
(define (not-empty streams)
|
||||
(filter (lambda (s) (not (stream-null? s))) streams))
|
||||
(define (stream-multimap proc . streams)
|
||||
(if (null? streams)
|
||||
the-empty-stream
|
||||
(cons-stream
|
||||
(apply proc (map stream-car streams))
|
||||
(apply stream-multimap
|
||||
(cons proc (not-empty (map stream-cdr streams)))))))
|
||||
|
||||
(define (integers-starting-from n)
|
||||
(cons-stream n (integers-starting-from (inc n))))
|
||||
(define (sieve stream)
|
||||
(let ((first (stream-car stream)))
|
||||
(cons-stream
|
||||
first
|
||||
(sieve (stream-filter (lambda (x) (not (= (remainder x first) 0)))
|
||||
(stream-cdr stream))))))
|
||||
(define primes (sieve (integers-starting-from 2)))
|
||||
(define ones (cons-stream 1 ones))
|
||||
(define (add-streams s1 s2) (stream-multimap + s1 s2))
|
||||
(define positive-integers (cons-stream 1 (add-streams ones positive-integers)))
|
||||
(define fibs
|
||||
(cons-stream 0 (cons-stream 1 (add-streams (stream-cdr fibs) fibs))))
|
||||
(define (scale-stream stream factor)
|
||||
(stream-map (lambda (x) (* x factor)) stream))
|
||||
|
||||
; For debugging purposes
|
||||
(define (list->stream lst)
|
||||
(if (null? lst)
|
||||
the-empty-stream
|
||||
(cons-stream (car lst) (list->stream (cdr lst)))))
|
||||
(define (print-1st-elements n stream)
|
||||
(if (or (< n 1) (stream-null? stream))
|
||||
(newline)
|
||||
(begin (display (stream-car stream))
|
||||
(display " ")
|
||||
(print-1st-elements (dec n) (stream-cdr stream)))))
|
||||
|
||||
; Exercise 3.54
|
||||
(define (mul-streams s1 s2) (stream-multimap * s1 s2))
|
||||
(define factorials
|
||||
(cons-stream 1 (mul-streams (integers-starting-from 2) factorials)))
|
||||
|
||||
; Exercise 3.55
|
||||
(define (partial-sums s)
|
||||
(define sums (cons-stream (stream-car s) (add-streams (stream-cdr s) sums)))
|
||||
sums)
|
||||
|
||||
; Exercise 3.56
|
||||
(define (merge s1 s2)
|
||||
(cond ((stream-null? s1) s2)
|
||||
((stream-null? s2) s1)
|
||||
(else (let ((a1 (stream-car s1))
|
||||
(a2 (stream-car s2)))
|
||||
(cond ((< a1 a2) (cons-stream a1 (merge (stream-cdr s1) s2)))
|
||||
((> a1 a2) (cons-stream a2 (merge s1 (stream-cdr s2))))
|
||||
(else (cons-stream a1 (merge (stream-cdr s1)
|
||||
(stream-cdr s2)))))))))
|
||||
(define hamming-sequence
|
||||
(cons-stream 1 (merge (merge (scale-stream hamming-sequence 2)
|
||||
(scale-stream hamming-sequence 3))
|
||||
(scale-stream hamming-sequence 5))))
|
||||
|
||||
; Exercise 3.58: rational number num/den in base radix
|
||||
(define (expand num den radix)
|
||||
(let ((product (* num radix)))
|
||||
(cons-stream (quotient product den)
|
||||
(expand (remainder product den) den radix))))
|
||||
|
||||
; Exercise 3.59
|
||||
(define (integrate-series coef-stream)
|
||||
(stream-multimap / coef-stream positive-integers))
|
||||
(define exp-series (cons-stream 1 (integrate-series exp-series)))
|
||||
(define cosine-series
|
||||
(cons-stream 1 (scale-stream (integrate-series sine-series) -1)))
|
||||
(define sine-series (cons-stream 0 (integrate-series cosine-series)))
|
||||
|
||||
; Exercise 3.60
|
||||
(define (mul-series s1 s2)
|
||||
(if (stream-null? s2)
|
||||
the-empty-stream
|
||||
(add-streams (cons-stream 0 (mul-series s1 (stream-cdr s2)))
|
||||
(scale-stream s1 (car s2)))))
|
||||
|
||||
; Exercise 3.61 modified: compute 1/S
|
||||
(define (invert-series s)
|
||||
(let ((c (stream-car s)))
|
||||
(define x (cons-stream (/ 1 c)
|
||||
(mul-series (scale-stream (stream-cdr s) (/ -1 c)) x)))
|
||||
x))
|
||||
|
||||
; Exercise 3.62
|
||||
(define (div-series s1 s2)
|
||||
(cond ((stream-null? (stream-cdr s2)) (scale-stream s1 (/ 1 (stream-car s2))))
|
||||
((and (= (stream-car s1) 0) (= (stream-car s2) 0))
|
||||
(div-series (stream-cdr s1) (stream-cdr s2)))
|
||||
(else (mul-series s1 (invert-series s2)))))
|
||||
|
||||
(define (pi-summands n)
|
||||
(cons-stream (/ 1.0 n) (stream-map - (pi-summands (+ n 2)))))
|
||||
(define pi-stream
|
||||
(scale-stream (partial-sums (pi-summands 1)) 4))
|
||||
(define (euler-transform s)
|
||||
(let ((s0 (stream-car s))
|
||||
(s1 (stream-ref s 1))
|
||||
(s2 (stream-ref s 2)))
|
||||
(cons-stream (/ (- (* s0 s2) (square s1)) (+ s0 (* -2 s1) s2))
|
||||
(euler-transform (stream-cdr s)))))
|
||||
(define (make-tableau transform s)
|
||||
(cons-stream s (make-tableau transform (transform s))))
|
||||
(define (accelerated-sequence transform s)
|
||||
(stream-map stream-car (make-tableau transform s)))
|
||||
|
||||
; Exercise 3.64
|
||||
(define (average x y) (/ (+ x y) 2))
|
||||
(define (sqrt-stream x)
|
||||
(define (sqrt-improve guess) (average guess (/ x guess)))
|
||||
(define guesses (cons-stream 1.0 (stream-map sqrt-improve guesses)))
|
||||
guesses)
|
||||
(define (stream-limit stream tolerance)
|
||||
(let* ((d (stream-cdr stream))
|
||||
(ad (stream-car d)))
|
||||
(if (< (abs (- (stream-car stream) ad)) tolerance)
|
||||
ad
|
||||
(stream-limit d tolerance))))
|
||||
(define (sqrt-acc x tolerance)
|
||||
(stream-limit (sqrt-stream x) tolerance))
|
||||
|
||||
; Exercise 3.65
|
||||
(define (ln2-summands n)
|
||||
(cons-stream (/ 1.0 n) (stream-map - (ln2-summands (inc n)))))
|
||||
(define ln2-stream (partial-sums (ln2-summands 1)))
|
||||
|
||||
; Exercise 3.67
|
||||
(define (pairs s t)
|
||||
(let ((as (stream-car s))
|
||||
(dt (stream-cdr t)))
|
||||
(cons-stream (cons as (stream-car t))
|
||||
(interleave (stream-map (lambda (x) (cons as x)) dt)
|
||||
(pairs (stream-cdr s) dt)))))
|
||||
(define (all-pairs stream)
|
||||
(let ((a (stream-car stream)))
|
||||
(let ((new-pairs (cons-stream a (all-pairs (stream-cdr stream))))
|
||||
(aa (car a))
|
||||
(da (cdr a)))
|
||||
(if (= aa da)
|
||||
new-pairs
|
||||
(cons-stream (cons da aa) new-pairs)))))
|
||||
|
||||
; Exercise 3.69 extended: pick any number of streams
|
||||
(define (interleave . streams)
|
||||
(if (null? streams)
|
||||
the-empty-stream
|
||||
(let ((a (car streams))
|
||||
(d (cdr streams)))
|
||||
(cons-stream
|
||||
(stream-car a)
|
||||
(apply interleave (not-empty (append d (list (stream-cdr a)))))))))
|
||||
(define (pick weigh . streams) ; modified for exercise 3.70
|
||||
(define (merge-weighted weigh streams)
|
||||
(define (min-weight streams)
|
||||
(let ((a (car streams))
|
||||
(d (cdr streams)))
|
||||
(if (null? d)
|
||||
(list a)
|
||||
(let ((next (min-weight d)))
|
||||
(if (< (weigh (stream-car a)) (weigh (stream-car (car next))))
|
||||
(cons a next)
|
||||
(cons (car next) (cons a (cdr next))))))))
|
||||
(if (null? streams)
|
||||
the-empty-stream
|
||||
(let ((m (min-weight (not-empty streams))))
|
||||
(cons-stream (stream-car (car m))
|
||||
(merge-weighted
|
||||
weigh
|
||||
(if (null? (stream-cdr (car m)))
|
||||
(cdr m)
|
||||
(cons (stream-cdr (car m))
|
||||
(cdr m))))))))
|
||||
(define (heads lst)
|
||||
(if (null? lst)
|
||||
'()
|
||||
(cons '()
|
||||
(map (lambda (l) (cons (car lst) l))
|
||||
(heads (cdr lst))))))
|
||||
(define (iter cars cdrs)
|
||||
(if (null? cdrs)
|
||||
'()
|
||||
(cons (stream-map (lambda (l) (append (car cars) l))
|
||||
(apply pick (cons weigh cdrs)))
|
||||
(iter (cdr cars) (cdr cdrs)))))
|
||||
(if (null? streams)
|
||||
the-empty-stream
|
||||
(let ((cars (map stream-car streams))
|
||||
(cdrs (map stream-cdr streams)))
|
||||
(cons-stream cars (merge-weighted weigh (iter (heads cars) cdrs))))))
|
||||
(define (sum lst) (apply + lst))
|
||||
(define pythagorean-triples
|
||||
(stream-filter
|
||||
(lambda (l) (apply (lambda (i j k) (= (+ (* i i) (* j j)) (* k k))) l))
|
||||
(pick sum positive-integers positive-integers positive-integers)))
|
||||
|
||||
; Exercise 3.70
|
||||
(define sorted-by-sum (pick sum positive-integers positive-integers))
|
||||
(define (stream-append s1 s2)
|
||||
(if (stream-null? s1)
|
||||
s2
|
||||
(cons-stream (stream-car s1) (stream-append (stream-cdr s1) s2))))
|
||||
(define bacon-seq ; i.e. neither Ham(ming) nor sausages
|
||||
(stream-append (list->stream (list 1 7 11 13 17 19 23))
|
||||
(cons-stream 29 (stream-map (lambda (x) (+ x 30)) bacon-seq))))
|
||||
(define bacons
|
||||
(pick (lambda (l) (if (null? (cdr l))
|
||||
(car l)
|
||||
(apply (lambda (i j) (+ i i j j j (* 5 i j))) l)))
|
||||
bacon-seq bacon-seq))
|
||||
|
||||
; Exercise 3.71
|
||||
(define (cube-sum lst) (sum (map (lambda (x) (* x x x)) lst)))
|
||||
(define (inf-sorted-duplicates stream inits)
|
||||
(let ((a (stream-car stream))
|
||||
(d (stream-cdr stream)))
|
||||
(if (apply = (cons a inits))
|
||||
(cons-stream a (inf-sorted-duplicates d (append (cdr inits) (list a))))
|
||||
(inf-sorted-duplicates d (append (cdr inits) (list a))))))
|
||||
(define ramanujan
|
||||
(inf-sorted-duplicates
|
||||
(stream-map cube-sum (pick cube-sum positive-integers positive-integers))
|
||||
(list 0)))
|
||||
|
||||
; Exercise 3.72
|
||||
(define (square-sum lst) (sum (map square lst)))
|
||||
(define three-sums
|
||||
(inf-sorted-duplicates
|
||||
(stream-map square-sum (pick square-sum positive-integers positive-integers))
|
||||
(list 0 0)))
|
||||
|
||||
; Exercise 3.73
|
||||
(define (integral integrand initial-value dt)
|
||||
(define int (cons-stream initial-value
|
||||
(add-streams (scale-stream integrand dt) int)))
|
||||
int)
|
||||
(define (RC R C dt)
|
||||
(lambda (currents init-voltage)
|
||||
(add-streams (integral (scale-stream currents (/ 1 C)) init-voltage dt)
|
||||
(scale-stream currents R))))
|
||||
|
||||
; Exercise 3.74
|
||||
(define (sign-change-detector n p)
|
||||
(cond ((and (< p 0) (not (< n 0))) 1)
|
||||
((and (not (< p 0)) (< n 0)) -1)
|
||||
(else 0)))
|
||||
;(define zero-crossings
|
||||
; (stream-multimap sign-change-detector
|
||||
; (stream-cdr sense-data)
|
||||
; sense-data))
|
||||
|
||||
; Exercise 3.76
|
||||
(define (smooth stream) (stream-multimap average stream (stream-cdr stream)))
|
||||
(define (make-zero-crossings input-stream last-value)
|
||||
(cons-stream (sign-change-detector (stream-car input-stream)
|
||||
last-value)
|
||||
(make-zero-crossings (stream-cdr input-stream)
|
||||
(stream-car input-stream))))
|
||||
|
||||
; Exercise 3.81
|
||||
(define (rand-stream requests init updater)
|
||||
(let ((a (stream-car requests)))
|
||||
(let ((updated (cond ((eq? (car a) 'generate) (updater init))
|
||||
((eq? (car a) 'reset) (cdr a))
|
||||
(else (error "Unknown request: RAND-STREAM"
|
||||
(car a))))))
|
||||
(cons-stream updated (rand-stream (stream-cdr requests)
|
||||
updated updater)))))
|
||||
|
||||
; Exercise 3.82
|
||||
(define (monte-carlo-stream experiment)
|
||||
(define (try) (cons-stream (if (experiment) 1 0) (try)))
|
||||
(stream-multimap / (partial-sums (try)) positive-integers))
|
||||
(define (estimate-integral-stream P x1 x2 y1 y2)
|
||||
(monte-carlo-stream (lambda () (P (random-in-range x1 x2)
|
||||
(random-in-range y1 y2)))))
|
||||
Loading…
Reference in New Issue