[sicp] Finish chapter 3

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)))))