Chapter 03 solution detail

Exercise 3.1

#!scheme
(define (make-accumulator value)
  (lambda (amount)
    (begin
      (set! value (+ value amount))
      value)))

(define A (make-accumulator 5))

(A 10)
;Value: 15

(A 10)
;Value: 25

Exercise 3.2

#!scheme
(define (make-monitored f)
  (let ((count 0))
    (lambda (params)
      (cond ((eq? params 'how-many-calls?) count)
        ((eq? params 'reset-count)
         (begin
           (set! count 0)
           "Reset count to zero"))
        (else
         (begin
           (set! count (+ count 1))
           (f params)))))))

(define s (make-monitored sqrt))
(s 100)
;Value: 10
(s 'how-many-calls?)
;Value: 1
(s 300)
;Value: 17.320508075688775
(s 'how-many-calls?)
;Value: 2
(s 'reset-count)
;Value 18: "Reset count to zero"
(s 'how-many-calls?)
;Value: 0

Exercise 3.3

#!scheme
(define (make-account balance passwd)
  (define (withdraw amount)
    (if (>= balance amount)
    (begin
      (set! balance (- balance amount))
      balance)
    "Insufficient funds"))
  (define (deposit amount)
    (begin
      (set! balance (+ balance amount))
      balance))
  (define (dispatch pwd m)
    (if (eq? pwd passwd)
    (cond ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposit)
          (else (error "Unknow operation: MAKE-ACCOUNT" m)))
    (error "Incorrect password")))
  dispatch)

(define acc (make-account 100 'secret-password))

((acc 'secret-password 'withdraw) 40)
;Value: 60
((acc 'some-other-passwd 'deposit) 60)
;Incorrect password

Exercise 3.4

#!scheme
(define (make-account balance passwd)
  (let ((cc 7))
    (define (withdraw amount)
      (if (>= balance amount)
      (begin
        (set! balance (- balance amount))
        balance)
      "Insufficient funds"))
    (define (deposit amount)
      (begin
    (set! balance (+ balance amount))
    balance))
    (define (call-the-cops)
      (error "7 continus error, is you the true owner"))
    (define (dispatch pwd m)
      (if (eq? pwd passwd)
      (begin
        (set! cc 7)
        (cond ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposit)
          (else (error "Unknow operation: MAKE-ACCOUNT" m))))
      (if (= cc 0)
          (call-the-cops)
          (begin
        (set! cc (- cc 1))
        (error "Incorrect password")))))
    dispatch))

(define acc (make-account 100 'secret-password))

((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
((acc 'some-other-passwd 'withdraw) 40)
;7 continus error, is you the true owner

Exercise 3.5

#!scheme
(define (monte-carlo trials experiment)
  (define (iter trials-remaining trials-passed)
    (cond ((= trials-remaining 0) (/ trials-passed trials))
      ((experiment) (iter (- trials-remaining 1) (+ trials-passed 1)))
      (else (iter (- trials-remaining 1) trials-passed))))
  (iter trials 0))

(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (random (* 1.0 range)))))

(define (estimate-integral x1 x2 y1 y2 trials)
  (define (pred)
    (let ((x (random-in-range x1 x2))
      (y (random-in-range y1 y2)))
      (<= (+ (square (- x 5))
         (square (- y 7))) 9)))
  (let ((prob (monte-carlo trials pred)))
    (/ (* prob (- x2 x1) (- y2 y1)) 9.0)))

(estimate-integral 2 8 4 10 100000)
;Value: 3.14996

The precedure random-in-range should change to random float number to get more accurate result. In the scheme I use, (random integer) will only produce integer result, rand (random float) will procedure a float result.

Exercise 3.6

#!scheme
(define rand
  (let ((rand-state 1))
    (define (dispatch proc-name)
      (cond ((eq? proc-name 'generate)
         (begin
           (set! rand-state (+ rand-state 1))
           rand-state))
        ((eq? proc-name 'reset)
         (lambda (new-value)
           (set! rand-state new-value)
           'RESET-DONE))))
    dispatch))

(rand 'generate)

((rand 'reset) 10)

(rand 'generate)

The procedure use a very naive update procedure to update the random state: plus one every time. In a real random system, it will be more complex to generate the next number based on previous sequence.

Exercise 3.7

#!scheme
(define (make-account balance passwd)
  (let ((passwd-list (cons passwd '())))
    (define (withdraw amount)
      (if (>= balance amount)
      (begin
        (set! balance (- balance amount))
        balance)
      "Insufficient funds"))
    (define (deposit amount)
      (begin
    (set! balance (+ balance amount))
    balance))
    (define (join new-passwd)
      (set! passwd-list (cons new-passwd passwd-list))
      'JOINT-ACCOUNT-DONE)
    (define (dispatch pwd m)
      (if (find (lambda (x) (eq? pwd x)) passwd-list)
      (cond ((eq? m 'withdraw) withdraw)
        ((eq? m 'deposit) deposit)
        ((eq? m 'join) join)
        (else (error "Unknow operation: MAKE-ACCOUNT" m)))
      (error "Incorrect password")))
    dispatch))

(define (make-join acc passwd new-passwd)
  (begin
    ((acc passwd 'join) new-passwd)
    acc))


(define peter-acc (make-account 100 'open-sesame))

(define paul-acc (make-join peter-acc 'wrong-passwd 'rosebud))
;Incorrect password

(define paul-acc (make-join peter-acc 'open-sesame 'rosebud))
;Value: paul-acc

((paul-acc 'rosebud 'withdraw) 10)
;Value: 90

We just add a procedure join to the make account and dispatch to it. make-join take an account, the account's password and a new password, and save the new password to the account's password list, and return the account. So we can use paul-acc and the new password to manipulate peter-acc.

Exercise 3.8

#!scheme
(define f
  (let ((s #f)
    (v -1))
    (lambda (val)
      (if s
      v
      (begin
        (set! s #t)
        (set! v (/ val 2))
        v)))))

(+ (f 0) (f 1))
;Value: 1

(f 0)

(+ (f 0) (f 1))
;Value: 0

When we have assignemnt, we can see the evaluate order make sense. If we evalute the (f 0) first, we will get the result 0, but if we evalute (f 1) first, we will get result 1. According to the above experiment, we know that MIT-scheme default evaluate from right to left.

Exercise 3.9

             ______________________________________________________ 
global       |                                                     |    
env   --->   | factorial:------                                    |
             |                |                                    |
             |________________|____________________________________|
                              |   ^
                           ___|___|_
                          |    |    |
                          |____|____|
                            |
                            |
              parameter: n
              body: (if (= n 0) 1 (* n (factorial (- n 1))))

Here I just describe the evaluation procedure under environment model. Take (factorial 3) as example:

The call of (factorial 3) build an Environment E1 binding n to 3 and evaluate the body (if (= 3 0) 1 (* 3 (factorial (- 3 1))))
The body evaluate to (* n (factorial (- 3 1)))
Build an environment E2, which point to E1 and bind n to 2 and evaluate the body
The body evaluate to (* 2 (factorial (- 2 1)))
Build an environment E3, which point to E2 and bind n to 1 and evaluate the body
The body evaluate to (* 1 (factorial (- 1 1)))
Build an environment E4, which point to E3 and bind n to 0 and evaluate the body
The body return 1
Return to environment E3, and evaluate (* 1 1), evaluate to 1
Return to environment E2, and evaluate (* 2 1), evaluate to 2
Return to environment E1, and evaluate (* 3 2), evaluate to 6
Return to global environment the result 6

The factorial-iter do similar, but keep track of the partial answer, and when reach to E4, return the result 6 immediatelly.

Exercise 3.10 - 3.11

Due to the drawing of the answer too troublesome, Leave it for future to fill in.

Exercise 3.12

In fact, the MIT-scheme has build-in append! and last-pair. So we will add prefix my to each of the function.

#!scheme
(define (my-append! x y)
  (set-cdr! (my-last-pair x) y)
  x)

(define (my-last-pair x)
  (if (null? (cdr x)) x (my-last-pair (cdr x))))

(my-append! '(1 2 3 4) '(4 5 5 7))
;Value 17: (1 2 3 4 4 5 5 7)

(define x (list 'a 'b))
(define y (list 'c 'd))
(define z (append x y))
z
(cdr x)
;Value 19: (b)
(define w (my-append! x y))
w
(cdr w)
;Value 19: (b c d)

Exercise 3.13

#!scheme
(define (make-circle x)
  (set-cdr! (my-last-pair x) x)
  x)

(define z (make-circle (list 'a 'b 'c)))
z
;; infinite loop to print a b c

In fact, this is equivelent to the circle list in data structure.

Exercise 3.14

#!scheme
(define (mystery x)
  (define (loop x y)
    (if (null? x)
    y
    (let ((temp (cdr x)))
      (set-cdr! x y)
      (loop temp x))))
  (loop x '()))

(define v (list 'a 'b 'c 'd))

(define w (mystery v))
w
;Value 22: (d c b a)

In fact, mystery is equivelent to the build-in procedure reverse!, which is a mutable version of reverse. It reverse the list by operate on the existing cons cell instead by building up new cons cell.

Exercise 3.16

#!scheme
(define (count-pair x)
  (if (not (pair? x))
      0
      (+ (count-pair (car x)) (count-pair (cdr x)) 1)))

(count-pair '(a b c))
;Value: 3

(define x (list 'a 'b))
(define z1 (cons x '()))
(set-cdr! z1 (cdr x))
(count-pair z1)
;Value: 4

(define p (cons 'a 'b))
(define q (cons p p))
(define z2 (cons q q))
(count-pair z2)
;Value: 7

(define z3 (make-circle (list 'a 'b 'c)))
; (count-pair z3) will infinitive loop

We can show that both '(a b c), z1, z2 and z3 contain 3 cons cell, but this count-pair procedure will return 3, 4, 7 and fall into infinitive loop. make-circle is the procedure defined in Exercise 3.13.

Exercise 3.17

#!scheme
(define (count-pair x)
  (let ((track '()))
    (define (traverse t)
      (if (not (pair? t))
      0
      (if (assoc t track)
          0
          (let ((ans1 (traverse (car t)))
            (ans2 (traverse (cdr t))))
        (begin
          (set! track (cons (list t #t) track))
          (+ 1 ans1 ans2))))))
    (traverse x)))

(count-pair '(a b c))
;Value: 3
(count-pair z1)
;Value: 3
(count-pair z2)
;Value: 3
(count-pair z3)
;Aborting!: maximum recursion depth exceeded

The above code can handle non-circle list correct, for circle list, it can not handle.

Exercise 3.18 - Exercise 3.19

#!scheme
(define (check-circle? x)
  (let ((p1 x)
    (p2 x))
    (define (loop)
      (begin
    (set! p1 (cdr p1))
    (if (pair? (cdr p2))
        (set! p2 (cdr (cdr p2)))
        (set! p2 (cdr p2)))
    (cond ((null? p2) #f)
          ((eq? p1 p2) #t)
          (else (loop)))))
    (loop)))

(define z3 (make-circle (list 'a 'b 'c)))
(check-circle? z3)
;Value: #t

(check-circle? (list 'a 'b 'c))
;Value: #f

I directly give the const extra space solution, we can maintain to point, originally point to the list, every step, p1 forward 1 step and p2 forward 2 step. If the two point once equal, then the list contain circle. Otherwise, when p2 point to null, we can show that it does not contain circle.

Exercise 3.20

#!scheme
(define (my-cons x y)
  (define (set-x! v) (set! x v))
  (define (set-y! v) (set! y v))
  (define (dispatch m)
    (cond ((eq? m 'my-car) x)
      ((eq? m 'my-cdr) y)
      ((eq? m 'my-set-car!) set-x!)
      ((eq? m 'my-set-cdr!) set-y!)
      (else
       (error "Undefined operation: CONS" m))))
  dispatch)

(define (my-car z) (z 'my-car))
(define (my-cdr z) (z 'my-cdr))
(define (my-set-car! z new-value)
  ((z 'my-set-car!) new-value) z)
(define (my-set-cdr! z new-value)
  ((z 'my-set-cdr!) new-value) z)

(define x (my-cons 1 2))
(define z (my-cons x x))
(my-set-car! (my-cdr z) 17)
(my-car x)
;Value: 17

We can see that using the assignment, we can build mutable compound data, just as the build in set-car! and set-cdr!.

Exercise 3.21

#!scheme
(define q1 (make-queue))
(insert-queue! q1 'a)
;Value 13: ((a) a)
(insert-queue! q1 'b)
;Value 13: ((a b) b)
(delete-queue! q1)
;Value 13: ((b) b)
(delete-queue! q1)
;Value 13: (() b)

;; It does not insert the item twice, but print the queue-ptr and the acutal list to represent queue. Since the rear-ptr point to the end of the list, so it seems that the end item is printed twice.

(define (print-queue queue)
  (cond ((empty-queue? queue)
     (display "Empty Queue")
     (newline)
     'DONE)
    (else
     (letrec ((head (front-ptr queue))
          (rear (rear-ptr queue))
          (f (lambda (pointer)
               (if (eq? pointer rear)
               (begin
                 (display (car pointer))
                 (display ")")
                 (newline))
               (begin
                 (display (car pointer))
                 (display ",")
                 (f (cdr pointer)))))))
       (display "(")
       (f head)))))

(print-queue q1)
; Empty Queue
;Value: done

(insert-queue! q1 'a)
(print-queue q1)
;(a)
;Unspecified return value

(insert-queue! q1 'b)
(print-queue q1)
;(a,b)
;Unspecified return value

Exercise 3.22

#!scheme
(define (make-queue)
  (let ((front-ptr '())
    (rear-ptr '()))
    (define (dispatch m)
      (cond ((eq? m 'empty-queue?) (null? front-ptr))
        ((eq? m 'insert-queue!)
         (lambda (item)
           (let ((new-pair (cons item '())))
         (if (null? front-ptr)
             (begin
               (set! front-ptr new-pair)
               (set! rear-ptr new-pair)
               'INSERT-DONE)
             (begin
               (set-cdr! rear-ptr new-pair)
               (set! rear-ptr new-pair)
               'INSERT-DONE)))))
        ((eq? m 'delete-queue!)
         (if (null? front-ptr)
         (error "DELETE on empty queue!")
         (begin
           (set! front-ptr (cdr front-ptr))
           'DELETE-DONE)))
        ((eq? m 'print-queue)
         (letrec ((ptr front-ptr)
              (f (lambda (pointer)
               (if (eq? pointer rear-ptr)
                   (begin
                 (display (car pointer))
                 (display ")")
                 (newline)
                 'DONE)
                   (begin
                 (display (car pointer))
                 (display ",")
                 (f (cdr pointer)))))))
           (begin
         (display "(")
         (f ptr))))))
    dispatch))

(define q2 (make-queue))
(q2 'empty-queue?)
;Value: #t

((q2 'insert-queue!) 'a)
(q2 'print-queue)
; (a)
;Value: done

((q2 'insert-queue!) 'b)
;Value: insert-done
(q2 'print-queue)
;(a,b)
;Value: done

(q2 'delete-queue!)
;Value: delete-done

(q2 'print-queue)
;(b)
;Value: done

Exercise 3.23

The following code implement the deque. The key idear is to use a tuple of 3 element to represent each element (item <prev-ptr> <next-ptr>). When we insert an new item, we record its previous position and it next position, then all the deque operations can be done in O(1) time.

#!scheme
(define (make-deque)
  (cons '() '()))
(define (deque-front deque) (car deque))
(define (deque-rear deque) (cdr deque))

(define (empty-deque? deque)
  (or (null? (deque-front deque))
      (null? (deque-rear deque))))


(define (front-insert-deque! deque item)
  (let ((node (if (empty-deque? deque)
          (list item '() '())
          (list item '() (deque-front deque)))))
    (if (empty-deque? deque)
    (begin (set-car! deque node) (set-cdr! deque node))
    (set-car! deque node))
    deque))

(define (front-delete-deque! deque)
  (if (empty-deque? deque)
      (error "FRONT-DELETE in empty deque" deque)
      (let ((node (deque-front deque)))
    (set-car! deque (caddr node))
    deque)))

(define (rear-insert-deque! deque item)
  (let ((node (if (empty-queue? deque)
          (list item '() '())
          (list item (deque-rear deque) '()))))
    (if (empty-deque? deque)
    (begin (set-car! deque node) (set-cdr! deque node))
    (set-cdr! deque node))
    deque))

(define (rear-delete-deque! deque)
  (if (empty-deque? deque)
      (error "REAR-DELETE in empty deque" deque)
      (let ((node (deque-rear deque)))
    (set-cdr! deque (cadr node))
    deque)))

(define dq (make-deque))

(front-insert-deque! dq 'a)
;Value 15: ((a () ()))

(front-insert-deque! dq 'b)
;Value 16: ((b () (a () ())) a () ())

(rear-insert-deque! dq 'c)
;Value 16: ((b () (a () ())) c (a () ()) ())

(rear-delete-deque! dq)
;Value 16: ((b () (a () ())) a () ())

(front-delete-deque! dq)
;Value 16: ((a () ()) a () ())

Exercise 3.24

#!scheme
(assoc '(a b) '(((a b) . 1) ((c d) . 2)) equal?)
;Value 13: ((a b) . 1)

(assoc '(a b) '(((a b) . 1) ((c d) . 2)) eq?)

The assoc procedure can accept an third parameter, which is a procedure to test equality, so we could pass same-key? to all assoc procedure, and we can done.

Exercise 3.25

We can use (key-list . value) pair to store the record, each pair has a key-list and a value.

#!scheme
(define (make-general-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-list)
      (let ((record (assoc key-list (cdr local-table))))
    (if record
        (cdr record)
        #f)))
    (define (insert! key-list value)
      (let ((record (assoc key-list (cdr local-table))))
    (if record
        (set-cdr! record value)
        (set-cdr! local-table (cons
                   (cons key-list value)
                   (cdr local-table))))
    'OK))
    (define (dispatch m)
      (cond ((eq? m 'lookup) lookup)
        ((eq? m 'insert!) insert!)
        (else (error "1D-TABLE Unknow operation" m))))
    dispatch))

(define gt (make-general-table))
((gt 'insert!) '(a b c) 4)
;Value: ok

((gt 'insert!) '(a b) 5)
;Value: ok

((gt 'lookup) '(a b))
;Value: 5

Exercise 3.26

The above answer use list to store tall record. If we want to speed up the search, we may use binary search tree to store the record. Use the key's order to sorted the binary search tree, and when search, use key-list to judge to goto left subtree or right subtree.

Exercise 3.27

#!scheme
(define (fib n)
  (cond ((= n 0) 0)
    ((= n 1) 1)
    (else (+ (fib (- n 1))
         (fib (- n 2))))))

(fib 30)
;Value: 832040
;About 2 second's for the answer appear

(define memo-fib
  (memoize (lambda (n)
         (cond ((= n 0) 0)
           ((= n 1) 1)
           (else (+ (memo-fib (- n 1))
                (memo-fib (- n 2))))))))

(define (memoize f)
  (let ((table (make-1d-table)))
    (lambda (x)
      (let ((previously-computed-result (1d-table/get table x #f)))
    (or previously-computed-result
        (let ((result (f x)))
          (1d-table/put! table x result)
          result))))))

(memo-fib 30)
;Value: 832040
;Immediately return

The above example, I use the build-in 1d-table structure of MIT-scheme. When without memorize, the time complexity is T(n) = T(n - 1) + T(n - 2). Solve this recursion, we could get exponent growth result.

When adding memorize, because when compute (memo-fib (- n 2)), we record all fib result less or equal to n - 2, so when compute (memo-fib (- n 1)), we could just use two table lookup operation to find the result (fib (- n 3)) & (fib (- n 2)). So the time complexity is T(n) = T(n - 2) + O(1). wich is linear growth.

Exercise 3.38

a. There are totally six order of the execution:

Peter -> Paul -> Mary : Result: $45
Peter -> Mary -> Paul : Result: $35
Paul -> Peter -> Mary : Result: $45
Paul -> Mary -> Peter : Result: $35
Mary -> Peter -> Paul : Result: $40
Mary -> Paul -> Peter : Result: $40

b. If the operation can interleave, other possible value is $90, $60, $30.

Exercise 3.39

#!scheme
(define x 10)
(define s (make-serializer))
(parallel-execute
  (lambda () (set! x ((s (lambda () (* x x))))))
  (s (lambda () (set! x (+ x 1)))))

If we serialize the program like above, so the operation compute (* x x) and (set! x (+ x 1)) must be serialize. So the result 11 and 100 will also remain in the final result. Because if first execute (* x x) but not assign to x, then the (set! x (+ x 1)) still get the old x, and if (set! x (+ x 1)) after the first set, then the result is 11, otherwise the answer is 100.

Exercise 3.40

#!scheme
(define x 10)
(parallel-execute (lambda () (set! x (* x x)))
                  (lambda () (set! x (* x x x))))

If the program like the above, then the result may be 100, 1000, 10^6.

#!scheme
(define x 10)
(define s (make-serializer))
(parallel-execute (s (lambda () (set! x (* x x))))
                  (s (lambda () (set! x (* x x x)))))

If we serialize the program like above, then the result can only be 100 or 1000.

Exercise 3.41

I don't agree with Ben, because check the balance of a account does not change the state of the account, so it is OK for mutiple process to access the account balance concurrently without any problem.

Exercise 3.42

Although it is a safe change to make, but in fact, the serializer of this exercise can only allow serialize access to the whole account instead serialize to the procedure withdraw and deposit.

Exercise 3.43

If the exchange operation run sequentially, then any operation will affect only two account and will exchange the value of the two account, so at last, the three account is some order of $10, $20, $30.

If we use the first version of account exchange, suppose that the three account is a1, a2 and a3, Peter want to exchange a1 and a2, while Paul want to exchange a1 and a3, after Peter calculate the difference, Paul successfully update the a1 account with a3's value. So violate the restrict. But because the first version exchange increase one account's value while decrease another's with the same value, every exchange operation will do that, so the total amount will not change after exchange.

If we do not serialized the deposit and withdraw operation, then if Paul want to withdraw money from a1, and before he successfully set the balance value, another process update the balance of a1, and the Paul's withdraw opeartion will violate the consistency restriction of the account.

Exercise 3.44

Louis is not right. In fact, the transfer problem can use the method Ben proposed as follow:

#!scheme
(define (transfer from-account to-account amount)
  ((from-account 'withdraw) amount)
  ((to-account 'deposit) amount))

The essential difference is that on the transfer problem, the amount will not need to be calculated by the two account,while in the the exchange problem, the amount should be calculated by the two account, and when the difference is calculated, the two account may changed by other operator.

Exercise 3.45

If we still make operations withdraw and deposit automatically serialize, then the operation serialize-exchange will have three serializer wrapper each withdraw and deposit operation, and two of them are same, such as (((s1 (s2 (s1 account)...)))), so the operation can not proceed any further.

Exercise 3.46

If we did not make test-and-set! an atomic operation, then when one process test but not set the mutex, another may also test the mutex and will see the mutex is false, and then the two process both acquire the mutex.

Exercise 3.47

The solution based on mutex

#!scheme
(define (make-sempahore n)
  (let ((count n)
    (mutex (make-mutex)))
    (define (sempahore m)
      (cond ((eq? m 'acquire)
         (mutex 'acquire)
         (if (zero? count)
         (begin
           (mutex 'release)
           (sempahore 'acquire)) ;; semphaore is full
         (begin
           (set! count (- count 1))
           (mutex 'release))))
        ((eq? m 'release)
         (mutex 'acquire)
         (set! count (+ count 1))
         (mutex 'release))))
    sempahore))

The solution based on test-and-set!

#!scheme
(define (test-and-set! cell)
  (if (car cell)
      #t
      (begin
    (set-car! cell true)
    #f)))


(define (make-sempahore n)
  (let ((lock (list #f))
    (count 0))
    (define (sempahore m)
      (cond ((eq? m 'acquire)
         (acquire-lock)
         (if (= count n)
         (begin
           (release-lock)
           (sempahore 'acquire))
         (begin
           (set! count (+ count 1))
           (release-lock))))
        ((eq? m 'release)
         (acquire-lock)
         (set! count (- count 1))
         (release-lock))))
    (define (acquire-lock)
      (if (test-and-set! lock)
      (acquire-lock)))
    (define (clear!)
      (set-car! lock #f))
    semaphore))

Exercise 3.50

#!scheme
(define (my-stream-map2 proc . argstreams)
  (if (null? (car argstreams))
      the-empty-stream
      (my-stream-cons
       (apply proc (map my-stream-car argstreams))
       (apply my-stream-map2
          (cons proc (map my-stream-cdr argstreams))))))

Exercise 3.51

#!scheme
(define (show x)
  (display-line x)
  x)

(define x
  (my-stream-map
   show
   (my-stream-enumerate-interval 0 10)))
;; 10
;; 9
;; 8
;; 7
;; 6
;; 5
;; 4
;; 3
;; 2
;; 1
;; 0
;Value: x


(my-stream-ref x 5)
;Value: 5
(my-stream-ref x 7)
;Value: 7

Exercise 3.52

#!scheme
(define sum 0)
;Value: sum

(define (accum x)
  (set! sum (+ x sum))
  sum)
;Value: accum

(define seq
  (my-stream-map
   accum
   (my-stream-enumerate-interval 1 20)))
;Value: seq

(define y (my-stream-filter even? seq))
;Value: y

(define z
  (my-stream-filter
   (lambda (x)
     (= (remainder x 5) 0)) seq))
;Value: z

(my-stream-ref y 7)
;Value: 90

(display-stream z)
;; 210
;; 200
;; 195
;; 165
;; 155
;; 105
;; 90
;; 20
;; ;Value: done

Without using the optimization provided by memo-proc, the result will be different, since the delay does not remember the evaluate result, the force procedure will have duplicate compute, and since the procedure accum change the state of sum, so duplicate computation will produce different result.

Exercise 3.53

#!scheme
(define s (cons-stream 1 (add-stream s s)))

The stream is the infinite sequence (1 2 4 8 16 ... 2^n ...).

Exercise 3.54

#!scheme
(define (from n)
  (cons-stream n (from (+ n 1))))

(define nats (from 1))

(define (mul-streams s1 s2)
  (stream-map * s1 s2))

(define factorials
  (cons-stream 1 (mul-streams (stream-cdr nats) factorials)))

(stream-head factorials 10)
;Value 15: (1 2 6 24 120 720 5040 40320 362880 3628800)

Exercise 3.55

#!scheme
(define (partial-sum stream)
  (let ((hh (stream-car stream)))
    (cons-stream hh (stream-map (lambda (x) (+ x hh)) (partial-sum (stream-cdr stream))))))

(define rr (partial-sum nats))

(stream-head rr 10)
;Value 23: (1 3 6 10 15 21 28 36 45 55)

Exercise 3.56

#!scheme
(define (scale-stream stream factor)
  (stream-map (lambda (x) (* x factor)) stream))

(define (merge-stream s1 s2)
  (cond ((stream-null? s1) s2)
    ((stream-null? s2) s1)
    (else
     (let ((s1car (stream-car s1))
           (s2car (stream-car s2)))
       (cond ((< s1car s2car) (cons-stream
                   s1car
                   (merge-stream (stream-cdr s1) s2)))
         ((> s1car s2car) (cons-stream
                   s2car
                   (merge-stream s1 (stream-cdr s2))))
         (else (cons-stream s1car (merge-stream
                       (stream-cdr s1)
                       (stream-cdr s2)))))))))

(define S (cons-stream 1 (merge-stream (merge-stream (scale-stream S 2) (scale-stream S 3))
                       (scale-stream S 5))))

(stream-head S 20)
;Value 25: (1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36)

(stream-ref S 1000)
;Value: 51840000

(stream-ref S 100000)   ;; result appear less than one second the first time
;Value: 290237644800000000000000000000000000000

We can see that stream is extreamly useful if there is very simple step at construct the stream, such as add sum number to each element or merge two stream. If there is no case of wrap a new function each time like the sieve example, it is always nice to use stream as infinite sequence.

Exercise 3.57

#!scheme
;; Exercise 3.57
(define fibs
  (cons-stream 0 (cons-stream 1 (add-stream (stream-cdr fibs) fibs))))

(stream-head fibs 10)
;Value 27: (0 1 1 2 3 5 8 13 21 34)

If we use (stream-ref fibs 10000) to see the 10000th fibonacci numbers, it appear almost immediately. It can be show that the number of addition to calculate the nth fibnocci number is O(n). If dealy is implement without memorization, then the number to calculate the nth fibonacci number is O(1.618^n) according to the recursive equation O(n) = O(n - 1) + O(n - 2).

Exercise 3.58

#!scheme
(define (expand num den radix)
  (cons-stream
   (quotient (* num radix) den)
   (expand (remainder (* num radix) den)
       den
       radix)))

(define r (expand 1 7 10))
(stream-head r 10)
;Value 28: (1 4 2 8 5 7 1 4 2 8)

(stream-head (expand 3 8 10) 10)
;Value 29: (3 7 5 0 0 0 0 0 0 0)

The function expand take three number num, den and radix, it compute the quotient of the multiply of num and radix over den, then take the remainder of the result as new num for compute later result. If den and radix are coprime, then the sequence is infinite, otherwise the sequence ends with continously zero.

Exercise 3.59

#!scheme
;;; a

(define (integrate-series stream)
  (define (iter n ss)
    (cons-stream (/ (stream-car ss) n)
         (iter (+ n 1) (stream-cdr ss))))
  (iter 1 stream))


(stream-head (integrate-series nats) 20)
;Value 31: (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)

;;b
(define exp-series
  (cons-stream 1 (integrate-series exp-series)))

(stream-head exp-series 10)
;Value 34: (1 1 1/2 1/6 1/24 1/120 1/720 1/5040 1/40320 1/362880)


(define cosin-series
  (cons-stream 1 (stream-map - (integrate-series sine-series))))

(define sine-series
  (cons-stream 0 (integrate-series cosin-series)))

(stream-head cosin-series 10)
;Value 39: (1 0 -1/2 0 1/24 0 -1/720 0 1/40320 0)

(stream-head sine-series 10)
;Value 40: (0 1 0 -1/6 0 1/120 0 -1/5040 0 1/362880)

Key idear : derivative of sine is cosine, and derivative of cosin is negative of sine.

Exercise 3.60

#!scheme
(define (add-series . args)
  (apply stream-map + args))

(define (mul-series s1 s2)
  (cons-stream (* (stream-car s1) (stream-car s2))
           (add-series (scale-stream (stream-cdr s1) (stream-car s2))
               (scale-stream (stream-cdr s2) (stream-car s1))
               (cons-stream 0 (mul-series (stream-cdr s1) (stream-cdr s2))))))

(define one (add-series (mul-series sine-series sine-series)
            (mul-series cosin-series cosin-series)))

(stream-head one 10)
;Value 54: (1 0 0 0 0 0 0 0 0 0)

Notice the implement of the mul-series.

Exercise 3.61

#!scheme
(define (invert-unit-series stream)
  (cons-stream 1 (stream-map - (mul-series (stream-cdr stream) (invert-unit-series stream)))))

(define exp-invert (invert-unit-series exp-series))

(stream-head exp-invert 10)
;Value 55: (1 -1 1/2 -1/6 1/24 -1/120 1/720 -1/5040 1/40320 -1/362880)

Exercise 3.62

#!scheme
(define (div-series s1 s2)
  (if (= (stream-car s2) 0)
      (error "Division of zero series")
      (let ((inv (invert-unit-series s2)))
    (mul-series s1 inv))))

(define tan-series
  (div-series sine-series cosin-series))

(stream-head tan-series 10)
;Value 56: (0 1 0 1/3 0 2/15 0 17/315 0 62/2835)

Exercise 3.63

#!scheme
(define (naive-sqrt-stream x)
  (cons-stream 1.0 (stream-map (lambda (guess)
                 (sqrt-improve guess x))
                   (naive-sqrt-stream x))))

Louis's version sqrt-stream use functional call to build the stream, while the verion in the book use a binding of guesses to evaluate. The difference is that the text-book's version can use memorize to ensure that every value only evaluate one times, while in Louis's version, since it is a functional call to cons to a stream, everytime there is a functional call, it will expand as normal, so the code can not benefit from the memorization.

If we implement delay and force without using the memorization, the efficience of the two code will be the same.

Exercise 3.64

#!scheme
(define (stream-limit s tolerance)
  (let ((s0 (stream-ref s 0))
    (s1 (stream-ref s 1)))
    (if (< (abs (- s0 s1)) tolerance)
    s1
    (stream-limit (stream-cdr s) tolerance))))

(define (my-sqrt x tolerance)
  (stream-limit (sqrt-stream x) tolerance))

(my-sqrt 2.0 0.0001)
;Value: 1.4142135623746899

Exercise 3.65

#!scheme
(define (ln2-summands n)
  (cons-stream (/ 1.0 n)
           (stream-map - (ln2-summands (+ n 1)))))

(define ln2-stream
  (partial-sum (ln2-summands 1)))

(stream-head ln2-stream 5)
;Value 21: (1. .5 .8333333333333333 .5833333333333333 .7833333333333333)

(stream-head (accelerated-sequence euler-transform ln2-stream) 5)
;Value 23: (1. .7 .6932773109243697 .6931488693329254 .6931471960735491)

Exercise 3.66 TODO

Exercise 3.67

#!scheme
(define (pairs-all s t)
  (cons-stream
   (list (stream-car s) (stream-car s))
   (interleave
    (interleave
     (stream-map (lambda (x) (list (stream-car s) x))
         (stream-cdr t))
     (stream-map (lambda (x) (list x (stream-car s)))
         (stream-cdr s)))
    (pairs-all (stream-cdr s) (stream-cdr t)))))

(stream-head (pairs-all nats nats) 10)
;Value 22: ((0 0) (0 1) (1 1) (1 0) (1 2) (0 2) (2 2) (2 0) (2 1) (0 3))

Exercise 3.68

#!scheme
(define (pairs-louis s t)
  (interleave
   (stream-map (lambda (x) (list (stream-car s) x))
           t)
   (pairs-louis (stream-cdr s) (stream-cdr t))))

(stream-head (pairs-louis nats nats) 10)
;Aborting!: maximum recursion depth exceeded

Because the procedure pairs-louis call interleave immediately, and pair-louis is a recursive call, so it will raise the exceed stack depth problem. The origin version use cons-stream to delay the evaluation of the recursive call, so it does not have such problem.

Exercise 3.69

#!scheme
(define ints (from 1))

(define (triples s t u)
  (let ((s0 (stream-car s))
    (t0 (stream-car t))
    (u0 (stream-car u)))
    (cons-stream
     (list s0 t0 u0)
     (interleave
      (stream-cdr
       (stream-map (lambda (x) (list s0 (car x) (cadr x)))
           (pairs t u)))
      (triples (stream-cdr s) (stream-cdr t) (stream-cdr u))))))

(stream-head (triples nats nats nats) 10)
;Value 25: ((0 0 0) (0 0 1) (1 1 1) (0 1 1) (1 1 2) (0 0 2) (2 2 2) (0 1 2) (1 2 2) (0 0 3))


(stream-head
 (stream-filter (lambda (x)
          (= (+ (square (car x))
            (square (cadr x)))
             (square (caddr x))))
        (triples ints ints ints))
 3)
;Value 28: ((3 4 5) (6 8 10) (5 12 13))

Exercise 3.70

#!scheme
(define (from n)
  (cons-stream n (from (+ n 1))))

(define nats (from 0))

(define (merge-weighted s1 s2 weight)
  (cond ((stream-null? s1) s2)
    ((stream-null? s2) s1)
    ((< (weight (stream-car s1))
        (weight (stream-car s2)))
     (cons-stream (stream-car s1)
              (merge-weighted (stream-cdr s1) s2 weight)))
    (else (cons-stream (stream-car s2)
               (merge-weighted s1 (stream-cdr s2) weight)))))

(define (pairs-weight s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (merge-weighted
    (stream-map (lambda (x) (list (stream-car s) x))
        (stream-cdr t))
    (pairs-weight (stream-cdr s) (stream-cdr t))
    (lambda (x) (apply + x)))))

(stream-head (pairs-weight nats nats) 10)
;Value 14: ((0 0) (0 1) (1 1) (0 2) (1 2) (0 3) (2 2) (1 3) (0 4) (2 3))

(stream-head (pairs nats nats) 10)
;Value 15: ((0 0) (0 1) (1 1) (0 2) (1 2) (0 3) (2 2) (0 4) (1 3) (0 5))

;; problem b
(stream-head
 (pairs-weight
  nats
  nats
  (lambda (pair)
    (let ((x (car pair))
      (y (cadr pair)))
      (+ (* 2 x) (* 3 y) (* 5 x y))))) 10)
;Value 20: ((0 0) (0 1) (0 2) (0 3) (1 1) (0 4) (0 5) (1 2) (0 6) (0 7))

Exercise 3.71

#!scheme
(define (ramanujan-weight pair)
  (let ((x (car pair))
    (y (cadr pair)))
    (+ (* x x x) (* y y y))))

(define (ramanujan-stream s)
  (if (= (ramanujan-weight (stream-car s)) 
     (ramanujan-weight (stream-car (stream-cdr s))))
      (cons-stream
       (ramanujan-weight (stream-car s))
       (ramanujan-stream (stream-cdr s)))
      (ramanujan-stream (stream-cdr s))))

(stream-head
 (ramanujan-stream
  (pairs-weight nats nats ramanujan-weight)) 10)
;Value 22: (1729 4104 13832 20683 32832 39312 40033 46683 64232 65728)

Exercise 3.72

#!scheme
(define (ramanujan-stream-tuple s)
  (if (= (ramanujan-weight (stream-car s))
     (ramanujan-weight (stream-car (stream-cdr s)))
     (ramanujan-weight (stream-car (stream-cdr (stream-cdr s)))))
      (cons-stream
       (ramanujan-weight (stream-car s))
       (ramanujan-stream-tuple (stream-cdr (stream-cdr s))))
      (ramanujan-stream-tuple (stream-cdr s))))

(stream-head
 (ramanujan-stream-tuple
  (pairs-weight nats nats ramanujan-weight)) 2)
;Value 23: (87539319 119824488)

Exercise 3.73

#!scheme
(define (add-streams s t)
  (stream-map + s t))

(define (scale-stream s factor)
  (stream-map (lambda (x) (* x factor)) s))

(define (integral integrand initial-value dt)
  (define int
    (cons-stream initial-value
         (add-stream (scale-stream integrand dt)
                 int)))
  int)

(define (RC R C dt)
  (lambda (s v0)
    (add-streams
     (scale-stream s R)
     (integral (scale-stream s (/ 1.0 C)) v0 dt))))

(define RC1 (RC 5 1 0.5))

(RC1 nats 3)
;Value 26: (3 . #[promise 27])

Exercise 3.74

#!scheme
(define zero-crossings
  (stream-map sign-change-dector
          sense-data
          (cons-stream 0 sense-data)))

Exercise 3.75

#!scheme
(define (make-zero-crossings input-stream last-value last-signal)
  (let ((aptv (/ (+ (stream-car input-stream)
            last-value) 2.0)))
    (cons-stream
     (sign-change-detector aptv last-signal)
     (make-zero-crossings
      (stream-cdr input-stream)
      (stream-car input-stream)
      aptv))))

In fact, this bug rooted at when calculate the news average value of previous signal, when we do that, we only use the previous average, and it is not the last signal of the input stream, so we need to add a argument to store the last signal.

Exercise 3.76

#!scheme
(define (smooth s)
  (cons-stream
   (/ (+ (stream-car s)
     (stream-car (stream-cdr s))) 2.0)
   (smooth (stream-cdr s))))

(stream-head (smooth nats) 10) 
;Value 30: (.5 1.5 2.5 3.5 4.5 5.5 6.5 7.5 8.5 9.5)