diff options
| -rw-r--r-- | sicp/chapter3.rkt | 922 |
1 files changed, 922 insertions, 0 deletions
diff --git a/sicp/chapter3.rkt b/sicp/chapter3.rkt new file mode 100644 index 0000000..4e30393 --- /dev/null +++ b/sicp/chapter3.rkt @@ -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))))) |