Ex: 3.53 - 3.62

;some code from book
(define (stream-enumerate-interval low high)
 (if (> low high)
     the-empty-stream
     (cons-stream
      low
      (stream-enumerate-interval (+ low 1) high))))
(define (display-stream s)
 (stream-for-each display-line s))
(define (display-line x)
 (newline)
 (display x))
(define (add-streams s1 s2)
 (stream-map + s1 s2))
(define (integers-starting-from n)
 (cons-stream n (integers-starting-from (+ n 1))))
(define integers (integers-starting-from 1))
(define (scale-stream stream factor)
 (stream-map (lambda (x) (* x factor)) stream))

Ex 3.53
Given definition defines a stream whose first term is 1, and next terms are calculated by adding previous term to itself. So the resulting stream is..
1,2,4,8,16...
Lets Verify...

(define s (cons-stream 1 (add-streams s s)))
1 ]=> (stream-ref s 0)
;Value: 1
1 ]=> (stream-ref s 1)
;Value: 2
1 ]=> (stream-ref s 2)
;Value: 4
1 ]=> (stream-ref s 3)
;Value: 8
1 ]=> (stream-ref s 4)
;Value: 16
1 ]=> (stream-ref s 5)
;Value: 32

Ex - 3.54

(define (mul-streams s1 s2)
 (stream-map * s1 s2))
(define factorials (cons-stream 1 (mul-streams integers factorials)))

Ex-3.55
Partial-sums of a stream is a stream whose first term is that of the input stream and next terms are calculated by adding next term of the input stream and previous term of the Partial-sums of the stream.

(define (partial-sums s)
 (cons-stream (stream-car s)
              (add-streams (stream-cdr s) (partial-sums s))))

;Verify
(define s (partial-sums integers))
1 ]=> (stream-ref s 0)
;Value: 1
1 ]=> (stream-ref s 1)
;Value: 3
1 ]=> (stream-ref s 2)
;Value: 6
1 ]=> (stream-ref s 3)
;Value: 10
1 ]=> (stream-ref s 4)
;Value: 15
1 ]=> (stream-ref s 5)
;Value: 21

Ex-3.56

(define (merge 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 s2car (merge s1 (stream-cdr s2))))
     (else
      (cons-stream s1car
                   (merge (stream-cdr s1)
                          (stream-cdr s2)))))))))
(define S (cons-stream 1 (merge
                         (merge (scale-stream s 2) (scale-stream s 3))
                         (scale-stream s 5))))

Ex-3.57



Ex-3.58
first element is (quotient (* num radix) den)
and next elements are calculated recursively from
num = (remainder (* num radix) den) with same radix and den.

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

(expand 1 7 10) should be
1 4 2 8 5 7....

;From the interpreter
1 ]=> (define s (expand 1 7 10))
;Value: s
1 ]=> (stream-ref s 0)
;Value: 1
1 ]=> (stream-ref s 1)
;Value: 4
1 ]=> (stream-ref s 2)
;Value: 2
1 ]=> (stream-ref s 3)
;Value: 8
1 ]=> (stream-ref s 4)
;Value: 5

Ex-3.59

;(a)
;inverted-integers = 1 1/2 1/3 1/4........
(define inverted-integers (stream-map (lambda (x) (/ 1 x)) integers))
(define (integrate-series s)
 (mul-streams s inverted-integers))

;(b)
(define cosine-series
 (cons-stream 1 (integrate-series (stream-map (lambda (x) (- x)) sine-series))))
(define sine-series
 (cons-stream 0 (integrate-series cosine-series)))

Ex-3.60

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

(define one (add-streams
            (mul-series sine-series sine-series)
            (mul-series cosine-series cosine-series)))

;verification, only constant term is 1
;rest all is 0
1 ]=> (stream-ref one 0)
;Value: 1
1 ]=> (stream-ref one 1)
;Value: 0
1 ]=> (stream-ref one 2)
;Value: 0
1 ]=> (stream-ref one 3)
;Value: 0
1 ]=> (stream-ref one 4)
;Value: 0
1 ]=> (stream-ref one 5)
;Value: 0

Ex-3.61

(define (invert-unit-series s)
 (cons-stream 1
              (stream-map (lambda (x) (- x))
                          (mul-series
                           (stream-cdr s)
                           (invert-unit-series s)))))

;Test
;secX = 1/cosX
(define sec-series (invert-unit-series cosine-series))
1 ]=> (stream-ref cosec-series 0)
;Value: 1
1 ]=> (stream-ref cosec-series 1)
;Value: 0
1 ]=> (stream-ref cosec-series 2)
;Value: 1/2
1 ]=> (stream-ref cosec-series 3)
;Value: 0
1 ]=> (stream-ref cosec-series 4)
;Value: 5/24
1 ]=> (stream-ref cosec-series 6)
;Value: 61/720
1 ]=> (stream-ref cosec-series 8)
;Value: 277/8064

Ex-3.62

;one-zeros = 1 0 0 0 0 0........
(define zeros (cons-stream 0 zeros))
(define one-zeros
 (cons-stream 1 zeros))

;s1/s2 = s1.(1/s2)
;we'll have to bring out the constant term from s2 so as
;to make the constant term 1
(define (div-series s1 s2)
              (scale-stream
               (mul-series s1
                           (invert-unit-series
                            (scale-stream s2 (/ 1 (stream-car s2)))))
               (/ (stream-car s2))))
              
;tanX = sinX/cosX
(define tangent-series
 (div-series sine-series cosine-series))

1 ]=> (stream-ref tangent-series 0)
;Value: 0
1 ]=> (stream-ref tangent-series 1)
;Value: 1
1 ]=> (stream-ref tangent-series 2)
;Value: 0
1 ]=> (stream-ref tangent-series 3)
;Value: 1/3
1 ]=> (stream-ref tangent-series 4)
;Value: 0
1 ]=> (stream-ref tangent-series 5)
;Value: 2/15
1 ]=> (stream-ref tangent-series 7)
;Value: 17/315
1 ]=> (stream-ref tangent-series 9)
;Value: 62/2835
1 ]=> (stream-ref tangent-series 11)
;Value: 1382/155925

Ex-3.50 - 3.52

Some code from book to execute the solutions..

(define (stream-enumerate-interval low high)
 (if (> low high)
     the-empty-stream
     (cons-stream
      low
      (stream-enumerate-interval (+ low 1) high))))

(define (stream-ref s n)
 (if (= n 0)
     (stream-car s)
     (stream-ref (stream-cdr s) (- n 1))))

(define (display-stream s)
 (stream-for-each display-line s))
(define (display-line x)
 (newline)
 (display x))

Ex 3.50

(define (stream-map proc . argstreams)
 (if (stream-null? (car argstreams))
     the-empty-stream
     (cons-stream
      (apply proc (map stream-car argstreams))
      (apply stream-map
             (cons proc (map stream-cdr argstreams))))))

;Test
(define s1 (cons-stream 1 (cons-stream 2 the-empty-stream)))
(define s2 (cons-stream 1 (cons-stream 2 the-empty-stream)))
(define s3 (stream-map + s1 s2))
s3 ;Value 12: (2 . #[promise 13])
(display-stream s3) ;(2,4)

Ex-3.51

(define (show x)
 (display-line x)
 x)
(define x (stream-map show (stream-enumerate-interval 0 10)))
(stream-ref x 5)
(stream-ref x 7)

;Results Printed
1 ]=> (stream-ref x 5)

1
2
3
4
5
;Value: 5

1 ]=> (stream-ref x 7)

6
7
;Value: 7

Explaination: (stream-ref x 5) printed 1,2,3,4,5 because all the show calls were done after calling it and memoized values are stored and hence (stream-ref x 7) just displays 6,7

Ex-3.52

(define sum 0)
;sum = 0

(define (accum x)
 (set! sum (+ x sum))
 sum)
;sum = 0

(define seq (stream-map accum (stream-enumerate-interval 1 20)))
;sum = 1 , only one call to accum is evaluated to get first element of seq

(define y (stream-filter even? seq))
;sum = 6 ; only calls to accum are evaluated to get first element even element in seq  which is 6

(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
                        seq))
;sum = 10 , only calls to accum are evaluated to get first element in seq that is divisible by 5

(stream-ref y 7)
;Value: 136
;sum = 136 ,only calls to accum upto calculating 7th element in y are evaluated

(display-stream z)
;(10 15 45 55 105 120 190 210)
;sum = 210 ,all the calls are evaluated

No, If we do not use memoization then these results will not stay the same as same accum calls will be evaluated multiple times and hence modifying sum multiple times for the same accum calls.

Ex-3.47

A mutex is an object that supports two operations - aquire and release. Once a mutex is aquired, no other process can aquire it unless it has been released. mutex is implemented using an *atomic* operation test-and-set! that tests value in a cell, returns true if cell value is already set to true or else sets the cell value to true and returns false.

A semaphore (of size n) is a generalization of a mutex. Like a mutex, a semaphore supports acquire and release operations, but it is more general in that up to n processes can acquire it concurrently. Additional processes that attempt to acquire the semaphore must wait for release operations.

(a) - semaphore implementation using mutex

(define (make-semaphore n)
(let ((m (make-mutex))
   (count 0)
   (result false))
(define (aquire)
 (m 'aquire)
 (if (> count 0)
     (set! count (- count 1)))
 (m 'release))
(define (dispatch msg)
 (cond
  ((eq? msg 'aquire) (aquire))
  ((eq? msg 'release) (release))
  (else "Unknown msg to SEMAPHORE: " msg)))
dispatch))

(b) - semaphore implementation using test-and-set

(define (clear! cell)
(set-car! cell false))

(define (make-semaphore n)
;makes a list of n cells
(define (make-cells n)
  (define (iter n a)
    (if (= n 0) a
        (iter (- n 1) (cons (list false) a))))
  (iter n '()))

(let ((cells (make-cells n)))
  (define (aquire)
    (define (iter cells)
      (cond
       ((null? cells) (aquire))
       ((not (test-and-set! (car cells)))
        true)
       (else (iter (cdr cells)))))
    (iter cells))
  (define (release)
    (define (iter cells)
      (cond
       ((null? cells)
        ;all the cells are already in released state
        ;nothing to do
        'ok)
       ((caar cells)
        (clear! (car cells)) 'ok)
       (else (iter (cdr cells)))))
    (iter cells))
  (define (dispatch msg)
    (cond
     ((eq? msg 'aquire) (aquire))
     ((eq? msg 'release) (release))
     (else "Unknown msg to SEMAPHORE: " msg)))
  dispatch))

Ex-3.46

Let say 2 processes try to aquire the mutex simultaneously when its in released state

(define (test-and-set! cell)
  (if (car cell)
      true
      (begin (set-car! cell true)
             false)))

Let P1 denote the event of first process calling (car cell) and P2 denote the event of first process calling (set-car! cell true). Similarly let Q1 denote the event of second process calling (car cell) and Q2 denote the event of second process calling (set-car! cell true).

Since test-and-set! is not atomic, so following interleaved execution sequence is possible...

P1 Q1 P2 Q2

With this sequence both the processes will aquire the mutex and mutex symantics that only one can aquire it at one time is broken.

Serializer Implementation..

Serializer is implemented in terms of another primitive called "mutex", that has two operations to "aquire" and "release" it. At one time only one process can aquire the mutex, other processes trying to aquire it at that time will block untill the mutex is released by the process that has the mutex aquired.
BTW, if multiple processes were waiting for the mutex to be released.. which of those processes get to aquire the mutex depends upon a component called scheduler.

Ex-3.45

There will be a deadlock. Here is why...

(serialized-exchange account1 account2)
...
...
(serializer1 (serializer2 exchange) account1 account2)
...
Notice, call to exchange is serialized in both the
serializers, so they won't let any other serialized
procedure run unless this call completes.

exchange makes following call..
(- (account1 'balance) (account2 'balance))
...
(account1 'balance)
This is a serialized call with the given code in the 
problem and will be blocked because serializer1 is still 
waiting for exchange call to complete.

Ex-3.44

No, given implementation of transfer is fine. Its different from exchange because in exchange, difference between the balance of two accounts is calculated without any serialization constraints and transfer doesn't have it.

Ex-3.42

It is safe and there is no difference.

Ex-3.41

No, checking the balance is a read-only operation and doesn't result in any anomalous behavior even when unserialized. Serializing it will just hamper the performance for no good.

Ex-3.40

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

Let P, Q represent both procedures and Pk/Qk denotes accessing value of x the kth time then following possibilities are possible..

x = 1000000: P1, P2, P sets x, Q1, Q2, Q3, Q sets x
x = 1000000: Q1, Q2, Q3, Q sets x, P1, P2, P sets x
x = 10000: P1, Q1, Q2, Q3, Q sets x, P2, P sets x
x = 100: P1, P2, Q1, Q2, Q3, Q sets x, P sets x
x = 100000: Q1, P1, P2 ,P sets x, Q2, Q3, Q sets x
x = 10000: Q1, Q2, P1, P2, P sets x, Q3, Q sets x
x = 1000: Q1, Q2, Q3, P1, P2, P sets X, Q sets x

.... There are other execution sequences possible also, but all the possible values that x can take after the execution are {100, 1000, 10000, 100000, 1000000}

In the next case when P, Q are serialized. After the execution, x can only be 1000000.

In general, This phenomenon when multiple threads/processes are modifying the same resource and final value of the resource could be different depending upon the interleaving is called "Race Condition"

Ex-3.39

Following 3 possibilities remain..

101: P1 sets x to 100 and then P2 increments x to 101.
121: P2 increments x to 11 and then P1 sets x to x times x.
100: P1 accesses x (twice), then P2 sets x to 11, then P1 sets x.

Ex-3.38

;Ex-3.38 a
Without interleaving there are 6(Fact(3) ways in which they can do their transactions) cases possible.

1. Peter, Paul, Mary .. balance: $45
2. Paul, Peter, Mary .. balance: $45
3. Peter, Mary, Paul .. balance: $35
4. Paul, Mary, Peter .. balance: $50
5. Mary, Peter, Paul .. balance: $40
6. Mary, Paul, Peter .. balance: $40

;Ex-3.38b
deposit/withdraw of Peter/Paul can be divided in 2 steps
(set! balance (+/ balance amt))
1. Access the current balance
2. Calculating (+/- balance amt) and setting balance to the calculated value.

Let us denote these 2 steps for both person's transactions as Peter-1, Peter-2, and Paul-1, Paul-2.

withdraw of Mary can be divided in 3 steps
(set! balance (- balance (/ balance 2)))
Mary-1: Access the balance for calculating (/ balance 2)
Mary-2: Access the balance for calculating (- balance (/..
Mary-3: Setting balance to value calculated in step Mary-2


One of the possible execution sequence could be....

Peter-1 Paul-1 Mary-1 Peter-2 Paul-2 Mary-2 Mary-3

..with this sequence the final balance would be... $30

Ex-3.35

code from book for constraint network.

(define (squarer a b)
  (define (process-new-value)
    (if (has-value? b)
        (if (< (get-value b) 0)
            (error "square less than 0 -- SQUARER" (get-value b))
            (set-value! a (sqrt (get-value b)) 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)

;;tests
(define A (make-connector))
(define B (make-connector))
(probe "A" A)
(probe "B" B)

(squarer A B)

(set-value! A 3 'user)
;Probe: B = 9
;Probe: A = 3
;Value: done

(forget-value! A 'user)
;Probe: B = ?
;Probe: A = ?
;Value: done

(set-value! B 25 'user)
;Probe: A = 5
;Probe: B = 25
;Value: done 

Ex-3.34

code from book for constraint network.

;;Lets Experiment
(define (squarer a b)
 (multiplier a a b))
(define A (make-connector))
(define B (make-connector))
(Probe "A" A)
(Probe "B" B)
(squarer a b)

(set-value! A 5 'user)
;Probe: A = 5
;Probe: B = 25
;Value: done

(forget-value! A 'user)
;Probe: A = ?
;Probe: B = ?
;Value: done

(set-value! B 16 'user)
;Probe: B = 16
;Value: done 

Case-I: Setting value in A ,B doesn't have a value yet.
It works - No issue.

Case-II: Setting value in B, A doesn't have a value yet.
It does *NOT* work.
Reason:
On setting the value in B, when multiplier will be informed about value.. no cond clause are applicable because two of the three connectors does not have any value(as two connectors are same) and the call is simply ignored.

Ex-3.33

code from book for constraint network.

(define (averager a1 a2 av)
(define (process-new-value)
  (cond ((and (has-value? a1) (has-value? a2))
         (set-value! av
                     (/
                      (+ (get-value a1) (get-value a2))
                      2) me))
        ((and (has-value? a1) (has-value? av))
         (set-value! a2
                     (- (* 2 (get-value av)) (get-value a1))
                     me))
        ((and (has-value? a2) (has-value? av))
         (set-value! a1
                     (- (* 2 (get-value av)) (get-value a2))
                     me))))
(define (process-forget-value)
  (forget-value! av 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 -- AVERAGER" request))))
(connect a1 me)
(connect a2 me)
(connect av me)
me)

;;Test
(define A (make-connector))
(define B (make-connector))
(define C (make-connector))
(probe "A" A)
(probe "B" B)
(probe "C" C)
(averager A B C)

(set-value! A 2 'user)
;Probe: A = 2
;Value: done
(set-value! B 4 'user)
;Probe: C = 3
;Probe: B = 4
;Value: done
(forget-value! A 'user)
;Probe: C = ?
;Probe: A = ?
;Value: done
(set-value! C 8 'user)
;Probe: A = 12
;Probe: C = 8
;Value: done
(forget-value! B 'user)
;Probe: A = ?
;Probe: B = ?
;Value: done
(forget-value! C 'user)
;Probe: C = ?
;Value: done
(set-value! A 4 'user)
;Probe: A = 4
;Value: done
(ser-value! C 10 'user)
;Probe: B = 16
;Probe: C = 10
;Value: done

section-3.3.5 Propagation of Constraint code

Just pasting the code for Constraint Networks from book here to run and interact with it...

;;========CONNECTOR============
;;connector implementation
(define (make-connector)
  (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))
            ((not (= value newval))
             (error "Contradiction" (list value newval)))
            (else 'ignored)))
    (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))
      'done)
    (define (me request)
      (cond ((eq? request 'has-value?)
             (if informant true false))
            ((eq? request '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 (for-each-except exception procedure list)
  (define (loop items)
    (cond ((null? items) 'done)
          ((eq? (car items) exception) (loop (cdr items)))
          (else (procedure (car items))
                (loop (cdr items)))))
  (loop list))

;;connector interface
(define (has-value? connector)
  (connector 'has-value?))
(define (get-value connector)
  (connector 'value))
(define (set-value! connector new-value informant)
  ((connector 'set-value!) new-value informant))
(define (forget-value! connector retractor)
  ((connector 'forget) retractor))
(define (connect connector new-constraint)
  ((connector 'connect) new-constraint))

;;==========CONSTRAINTS================

;;generic constraint interface
(define (inform-about-value constraint)
  (constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
  (constraint 'I-lost-my-value))

;;adder constraint implementation
(define (adder a1 a2 sum)
  (define (process-new-value)
    (cond ((and (has-value? a1) (has-value? a2))
           (set-value! sum
                       (+ (get-value a1) (get-value a2))
                       me))
          ((and (has-value? a1) (has-value? sum))
           (set-value! a2
                       (- (get-value sum) (get-value a1))
                       me))
          ((and (has-value? a2) (has-value? 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)

;;multiplier constraint implementation
(define (multiplier m1 m2 product)
  (define (process-new-value)
    (cond ((or (and (has-value? m1) (= (get-value m1) 0))
               (and (has-value? m2) (= (get-value m2) 0)))
           (set-value! product 0 me))
          ((and (has-value? m1) (has-value? m2))
           (set-value! product
                       (* (get-value m1) (get-value m2))
                       me))
          ((and (has-value? product) (has-value? m1))
           (set-value! m2
                       (/ (get-value product) (get-value m1))
                       me))
          ((and (has-value? product) (has-value? m2))
           (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)

;;constant constraint implementation
(define (constant value connector)
  (define (me request)
    (error "Unknown request -- CONSTANT" request))
  (connect connector me)
  (set-value! connector value me)
  me)



;; Probe
(define (probe name connector)
  (define (print-probe value)
    (newline)
    (display "Probe: ")
    (display name)
    (display " = ")
    (display value))
  (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)

;;====== 9C = 5(F - 32) Relation Simulation ========
(define (celsius-fahrenheit-converter c f)
  (let ((u (make-connector))
        (v (make-connector))
        (w (make-connector))
        (x (make-connector))
        (y (make-connector)))
    (multiplier c w u)
    (multiplier v x u)
    (adder v y f)
    (constant 9 w)
    (constant 5 x)
    (constant 32 y)
    'ok))

(define C (make-connector))
(define F (make-connector))
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)

(celsius-fahrenheit-converter C F)
(set-value! C 25 'user)
;Probe: Celsius temp = 25
;Probe: Fahrenheit temp = 77
;done

(set-value! F 212 'user)
;Error! Contradiction (77 212)

(forget-value! C 'user)
;Probe: Celsius temp = ?
;Probe: Fahrenheit temp = ?
;done

(set-value! F 212 'user)
;Probe: Fahrenheit temp = 212
;Probe: Celsius temp = 100
;done

event-driven simulation

In section 3.3.4, SICP presents a digital circuit simulator that implements it using a design called event-driven programming. In such designs basically actions("events") triggers further events that happen at a later time and those in turn trigger further events and so on.
To be particular about the example given in the book, Wire is the main object where we can set signal and can add any number of events(no-arg procedures). Whenever a signal changes(event of signal change happens), it triggers all the events added to it and those events when happen change signal on other wires which in turn trigger more events and so on... that is how the signal propagates.

I also wrote a port of this example in scala here.

functions and relations

Usually, we create programs that do one directional computations, which performs operations on given quantities to produce desired output. In some models, we don't have such one directional operations but we know the relation among quantities like the relation between celsius and fahrenheit, 9C = 5(F - 32). Translating this equation into a traditional computer language will force us to calculate one in terms of another instead of specifying the relation and measuring one when other changes. Programming paradigm where we can specify relations is called logic programming.

Ex-3.28 - 3.32

Some code from the book that is needed to run the various solutions..

;queue impl
(define (front-ptr queue) (car queue))
(define (rear-ptr queue) (cdr queue))
(define (set-front-ptr! queue item) (set-car! queue item))
(define (set-rear-ptr! queue item) (set-cdr! queue item))
(define (empty-queue? queue) (null? (front-ptr queue)))
(define (make-queue) (cons '() '()))
(define (front-queue queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue" queue)
      (car (front-ptr queue))))
(define (insert-queue! queue item)
  (let ((new-pair (cons item '())))
    (cond ((empty-queue? queue)
           (set-front-ptr! queue new-pair)
           (set-rear-ptr! queue new-pair)
           queue)
          (else
           (set-cdr! (rear-ptr queue) new-pair)
           (set-rear-ptr! queue new-pair)
           queue))))
(define (delete-queue! queue)
  (cond ((empty-queue? queue)
         (error "DELETE! called with an empty queue" queue))
        (else
         (set-front-ptr! queue (cdr (front-ptr queue)))
         queue)))

;agenda
(define (make-time-segment time queue)
  (cons time queue))
(define (segment-time s) (car s))
(define (segment-queue s) (cdr s))
(define (make-agenda) (list 0))
(define (current-time agenda) (car agenda))
(define (set-current-time! agenda time)
  (set-car! agenda time))
(define (segments agenda) (cdr agenda))
(define (set-segments! agenda segments)
  (set-cdr! agenda segments))
(define (first-segment agenda) (car (segments agenda)))
(define (rest-segments agenda) (cdr (segments agenda)))
(define (empty-agenda? agenda)
  (null? (segments agenda)))
(define (add-to-agenda! time action agenda)
  (define (belongs-before? segments)
    (or (null? segments)
        (< time (segment-time (car segments)))))
  (define (make-new-time-segment time action)
    (let ((q (make-queue)))
      (insert-queue! q action)
      (make-time-segment time q)))
  (define (add-to-segments! segments)
    (if (= (segment-time (car segments)) time)
        (insert-queue! (segment-queue (car segments))
                         action)
        (let ((rest (cdr segments)))
          (if (belongs-before? rest)
              (set-cdr!
                segments
                (cons (make-new-time-segment time action)
                      (cdr segments)))
              (add-to-segments! rest)))))
  (let ((segments (segments agenda)))
    (if (belongs-before? segments)
        (set-segments!
         agenda
         (cons (make-new-time-segment time action)
                segments))
        (add-to-segments! segments))))
(define (remove-first-agenda-item! agenda)
  (let ((q (segment-queue (first-segment agenda))))
    (delete-queue! q)
    (if (empty-queue? q)
        (set-segments! agenda (rest-segments agenda)))))
(define (first-agenda-item agenda)
  (if (empty-agenda? agenda)
      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
      (let ((first-seg (first-segment agenda)))
        (set-current-time! agenda (segment-time first-seg))
        (front-queue (segment-queue first-seg)))))

(define the-agenda (make-agenda))
(define (after-delay delay action)
  (add-to-agenda! (+ delay (current-time the-agenda))
                  action
                  the-agenda))
(define (propagate)
  (if (empty-agenda? the-agenda)
      'done
      (let ((first-item (first-agenda-item the-agenda)))
        (first-item)
        (remove-first-agenda-item! the-agenda)
        (propagate))))
;wire
(define (make-wire)
  (let ((signal-value 0) (action-procedures '()))
    (define (set-my-signal! new-value)
      (if (not (= signal-value new-value))
          (begin (set! signal-value new-value)
                  (call-each action-procedures))
          'done))
    (define (accept-action-procedure! proc)
      (set! action-procedures (cons proc action-procedures))
      (proc))
    (define (dispatch m)
      (cond ((eq? m 'get-signal) signal-value)
            ((eq? m 'set-signal!) set-my-signal!)
            ((eq? m 'add-action!) accept-action-procedure!)
            (else (error "Unknown operation -- WIRE" m))))
    dispatch))
(define (call-each procedures)
  (if (null? procedures)
      'done
      (begin
        ((car procedures))
        (call-each (cdr procedures)))))
(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))

;adders
(define (half-adder a b s c)
  (let ((d (make-wire)) (e (make-wire)))
    (or-gate a b d)
    (and-gate a b c)
    (inverter c e)
    (and-gate d e s)
    'ok))
(define (full-adder a b c-in sum c-out)(let ((s (make-wire))
      (c1 (make-wire))
      (c2 (make-wire)))
  (half-adder b c-in s c1)
  (half-adder a s sum c2)
  (or-gate c1 c2 c-out)
  'ok))

;gates
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(define (inverter input output)
  (define (invert-input)
    (let ((new-value (logical-not (get-signal input))))
       (after-delay inverter-delay
                     (lambda ()
                       (set-signal! output new-value)))))
  (add-action! input invert-input)
  'ok)
(define (logical-not s)
  (cond ((= s 0) 1)
         ((= s 1) 0)
         (else (error "Invalid signal" s))))

(define (and-gate a1 a2 output)
  (define (and-action-procedure)
    (let ((new-value
            (logical-and (get-signal a1) (get-signal a2))))
       (after-delay and-gate-delay
                    (lambda ()
                      (set-signal! output new-value)))))
  (add-action! a1 and-action-procedure)
  (add-action! a2 and-action-procedure)
  'ok)
(define (logical-and s1 s2)
  (cond ((and (= s1 1) (= s2 1)) 1)
 ((or
   (and (= s1 1) (= s2 0))
   (and (= s1 0) (= s2 0))
   (and (= s1 0) (= s2 1))) 0)
 (else (error "Invalid signal" s1 s2))))

;probe
(define (probe name wire)
  (add-action! wire
               (lambda ()
                 (newline)
                 (display name)
                 (display " ")
                 (display (current-time the-agenda))
                 (display " New-value = ")
                 (display (get-signal wire)))))

Ex-3.28

(define (or-gate a1 a2 output)
  (define (or-action-procedure)
    (let ((new-value
            (logical-or (get-signal a1) (get-signal a2))))
       (after-delay or-gate-delay
                    (lambda ()
                      (set-signal! output new-value)))))
  (add-action! a1 or-action-procedure)
  (add-action! a2 or-action-procedure)
  'ok)
(define (logical-or s1 s2)
  (cond ((and (= s1 0) (= s2 0)) 0)
 ((or
   (and (= s1 1) (= s2 0))
   (and (= s1 1) (= s2 1))
   (and (= s1 0) (= s2 1))) 1)
 (else (error "Invalid signal" s1 s2))))

;;test
> (define a (make-wire))
> (define b (make-wire))
> (define c (make-wire))
> (or-gate a b c)
ok
> (get-signal c)
0
> (set-signal! a 1)
done
> (propagate)
done
> (get-signal c)
1
> 

Ex-3.29

;A OR B  = -(-A AND -B)
(define (or-gate a1 a2 output)
  (let ((not-a1 (make-wire))
 (not-a2 (make-wire))
 (not-a1-and-not-a2 (make-wire)))
    (inverter a1 not-a1)
    (inverter a2 not-a2)
    (and-gate not-a1 not-a2 not-a1-and-not-a2)
    (inverter not-a1-and-not-a2 output)))

;delay in this case would be
;inverter-delay + and-gate-delay + inverter-delay 

Ex-3.30

(define (ripple-carry-adder Ak Bk Sk C)
  (if (not (null? Ak))
      (let ((c-in (make-wire)))
 (full-adder (car Ak) (car Bk) c-in (car Sk) C)
 (ripple-carry-adder (cdr Ak) (cdr Bk) (cdr Sk) c-in))))

;test
;adding 11 and 10, result should be 101
(define A1 (make-wire))
(define A2 (make-wire))
(define Ak (list A1 A2))
(define B1 (make-wire))
(define B2 (make-wire))
(define Bk (list B1 B2))
(define S1 (make-wire))
(define S2 (make-wire))
(define Sk (list S1 S2))
(define C (make-wire))
(ripple-carry-adder Ak Bk Sk C)

(set-signal! A1 1)
(set-signal! A2 1)
(set-signal! B1 1)
(set-signal! B2 0)
(propagate)

(get-signal C)  ;should be 1
(get-signal S1) ;should be 0 
(get-signal S2) ;should be 1 

Ex-3.31

(define (make-wire)
  (let ((signal-value 0) (action-procedures '()))
    (define (set-my-signal! new-value)
      (if (not (= signal-value new-value))
          (begin (set! signal-value new-value)
                  (call-each action-procedures))
          'done))
    (define (accept-action-procedure! proc)
      (set! action-procedures (cons proc action-procedures)))
    (define (dispatch m)
      (cond ((eq? m 'get-signal) signal-value)
            ((eq? m 'set-signal!) set-my-signal!)
            ((eq? m 'add-action!) accept-action-procedure!)
            (else (error "Unknown operation -- WIRE" m))))
    dispatch))

(define a (make-wire))
(define b (make-wire))
(define s (make-wire))
(define c (make-wire))

(probe 'a a)
(probe 'b b)
(probe 's s)
(probe 'c c)

(half-adder a b s c)

;proc run for a and b, that sets d
;proc added for a b, that sets c
;proc added for c that sets e
;proc added for d, e that set s 

The initialization is necessary so as to initialize the value of intermediate wires. As in the case of half-adder, due to initialization e gets set to 1. If the initialization calls were not there then e would remain 0 to start with and that will lead to following trouble. Let say you build the half adder circuit with above version of make-wire that doesn't call proc to start with. If you set a to 1, s would still remain 0 though it should be 1 and the reason is following. Here is what will happen when you set a to 1, following procs gets added to the agenda...

(set-signal! d (logical-or 1 0)) ;or of a and b
(set-signal! c (logical-and 1 0)) ;and of a and b

when above are executed, followings get added to the agenda

;and of d and e(NOTICE, e is 0 at this point)
(set-signal! s (logical-and 1 0)) 
(set-signal! e (logical-not 1)) ;not c and s gets set to 1 

Ex-3.32
(a1 a2) change from (0 1) to (1 0)
When signal of a1 changes from 0->1(a2 is still 1) following procedure is added to agenda
(set-signal! output (logical-and 1 1))

and then signal of a2 changes from 1->0(a1 is 1 at this time) following procedure is added to agenda
(set-signal! output (logical-and 1 0))

If above two procedure were run in the lifo order that is
(set-signal! output (logical-and 1 0))
(set-signal! output (logical-and 1 1))
then output is going to be 1, which is wrong. This is why the order is important.

Ex-3.26

This is an implementation of one dimensional table, where (key, value) records are organized in a binary tree.

;here is the binary tree implementation
;constructor
(define (make-tree entry left right)
  (list entry left right))
;selectors
(define (entry tree)
  (car tree))
(define (left-branch tree)
  (cadr tree))
(define (right-branch tree)
  (caddr tree))
;mutator
(define (set-left-branch! tree value)
  (set-car! (cdr tree) value))
(define (set-right-branch! tree value)
  (set-car! (cddr tree) value))


;here is the one dimensional table impl
;using above interface

;assume there is a compare procedure for the set
;of keys, that returs -1,0,+1 if key1 is less than key2,
;key1 is equal to key2, key1 is greater than key2
;respectively
(define (compare key1 key2) ...)
;for numeric keys following is what the compare will
;look like
(define (compare key1 key2)
  (cond
   ((= key1 key2) 0)
   ((< key1 key2) -1)
   (else 1)))

(define (make-table)
  (cons '*table* nil))
(define (insert! key value table)
  (define (insert-aux! tree)
    (let* ((record (entry tree))
           (index (compare key (car record))))
      (cond
       ((= index 0) (set-cdr! record value))
       ((< index 0)
        (if (null? (left-branch tree))
            (set-left-branch!
             tree
             (make-tree (cons key value) nil nil))
            (insert-aux! (left-branch tree))))
       (else
        (if (null? (right-branch tree))
            (set-right-branch!
             tree
             (make-tree (cons key value) nil nil))
            (insert-aux! (right-branch tree)))))))
  (if (null? (cdr table))
      (set-cdr! table (make-tree (cons key value) nil nil))
      (insert-aux! (cdr table))))
(define (lookup key table)
  (define (lookup-aux tree)
    (if (null? tree) #f
        (let* ((record (entry tree))
               (index (compare key (car record))))
          (cond
           ((= index 0) (cdr record))
           ((< index 0) (lookup-aux (left-branch tree)))
           (else 
            (lookup-aux (right-branch tree)))))))
  (lookup-aux (cdr table)))

Ex-3.25

(define (make-table) (list '*table*))

(define (insert! value table . keys)
  (if (not (null? keys))
      (let ((record (assoc (car keys) (cdr table))))
        (if (not record)
            (begin
              (set! record (cons (car keys) nil))
              (set-cdr! table (cons record (cdr table)))))
        (if (null? (cdr keys))
            (set-cdr! record value)
            (apply insert!
                   (cons value
                         (cons record (cdr keys))))))))

(define (lookup table . keys)
  (if (null? keys) #f
      (let ((record (assoc (car keys) (cdr table))))
        (if record
            (if (null? (cdr keys))
                (cdr record)
                (apply lookup (cons record (cdr keys))))
            #f)))) 

Ex-3.24

I just had to add a local definition of assoc to implement it to the given code for local tables.

(define (make-table same-key?)
  ;just adding a local definition of assoc that
  ;uses same-key? to compare keys instead of equal?
  (define (assoc 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 key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  false))
            false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch)) 

Ex-3.23

I'm implementing the deque using a doubly linked list of nodes, where node is a simple data structure that has two pointers, prev-ptr & next-ptr, pointing to previous node & next node in the list respectively and node contains data value for the item queued.

;node data structure
;node is basically a triplet so that we can store
;next as well as previous in the doubly linked list
;while pair stores 2 things only
(define (make-node prev value next)
  (cons prev (cons value next)))
(define (set-prev-ptr! node item)
  (set-car! node item))
(define (set-next-ptr! node item)
  (set-cdr! (cdr node) item))
(define (set-value! node item)
  (set-car! (cdr node) item))
(define (prev-ptr node)
  (car node))
(define (next-ptr node)
  (cddr node))
(define (value node)
  (cadr node))

;deque
;deque is again pair of front pointer
;and rear pointer
(define (front-ptr deque) (car deque))
(define (rear-ptr deque) (cdr deque))
(define (set-front-ptr! deque item) (set-car! deque item))
(define (set-rear-ptr! deque item) (set-cdr! deque item))

(define (make-deque)
  (cons nil nil))
(define (empty-deque? dq)
  (null? (front-ptr dq)))
(define (front-deque dq)
  (if (empty-deque? dq)
      (error "FRONT-DEQUE! deque is empty")
      (value (front-ptr dq))))
(define (rear-deque dq)
  (if (empty-deque? dq)
      (error "REAR-DEQUE! deque is empty")
      (value (rear-ptr dq))))
(define (front-insert-deque! dq item)
  (let ((new-node (make-node nil item nil)))
    (cond ((empty-deque? dq)
           (set-front-ptr! dq new-node)
           (set-rear-ptr! dq new-node))
          (else
           (set-next-ptr! (rear-ptr dq) new-node)
           (set-prev-ptr! new-node (rear-ptr dq))
           (set-rear-ptr! dq new-node)))))
(define (rear-insert-deque! dq item)
  (let ((new-node (make-node nil item nil)))
    (cond ((empty-deque? dq)
           (set-front-ptr! dq new-node)
           (set-rear-ptr! dq new-node))
          (else
           (set-next-ptr! new-node (front-ptr dq))
           (set-prev-ptr! (front-ptr dq) new-node)
           (set-front-ptr! dq new-node)))))
(define (delete-front-deque! dq)
  (cond
   ((empty-deque? dq)
    (error "DELETE-FRONT-DEQUE! deque is empty"))
   (else 
    (set-front-ptr! dq (next-ptr (front-ptr dq)))
    ;if front-ptr is nil that means there was
    ;only one item in dq
    (if (not (null? (front-ptr dq)))
        (set-prev-ptr! (front-ptr dq) nil)
        (set-rear-ptr! dq nil)))))
(define (delete-rear-deque! dq)
  (cond
   ((empty-deque? dq)
    (error "DELETE-REAR-DEQUE! deque is empty"))
   (else
    (set-rear-ptr! dq (prev-ptr (rear-ptr dq)))
    ;if rear-ptr is nil that means there was
    ;only one item in dq
    (if (not (null? (rear-ptr dq)))
        (set-next-ptr! (rear-ptr dq) nil)
        (set-front-ptr! dq nil)))))

;for debugging
(define (print-deque-forward dq)
  (define (print-deque-aux node)
    (display (value node))
    (display " ")
    (if (not (null? (next-ptr node)))
        (print-deque-aux (next-ptr node))))
  (if (not (empty-deque? dq))
      (begin
        (print-deque-aux (front-ptr dq))
        (newline))))
(define (print-deque-backward dq)
  (define (print-deque-aux node)
    (display (value node))
    (display " ")
    (if (not (null? (prev-ptr node)))
        (print-deque-aux (prev-ptr node))))
  (if (not (empty-deque? dq))
      (begin
        (print-deque-aux (rear-ptr dq))
        (newline))))

Ex-3.22

(define (make-queue)
  (let ((front-ptr nil)
        (rear-ptr nil))
    (define (empty-queue?)
      (null? front-ptr))
    (define (front-queue)
      (if (empty-queue?)
          (error "FRONT called with an empty queue" front-ptr)
          (car front-ptr)))
    (define (insert-queue! item)
      (let ((new-pair (cons item '())))
        (cond
         ((empty-queue?)
          (set! front-ptr new-pair)
          (set! rear-ptr new-pair))
         (else
          (set-cdr! rear-ptr new-pair)
          (set! rear-ptr new-pair))))
      front-ptr)
    (define (delete-queue!)
      (cond
       ((empty-queue?)
        (error "DELETE! called with an empty queue" front-ptr))
       (else
        (set! front-ptr (cdr front-ptr))
        front-ptr))) 
    (define (dispatch m . args)
      (cond
       ((eq? m 'empty-queue?) (empty-queue?))
       ((eq? m 'front-queue) (front-queue))
       ((eq? m 'insert-queue!) (insert-queue! (car args)))
       ((eq? m 'delete-queue!) (delete-queue!))))
    dispatch))

(define (empty-queue? q)
  (q 'empty-queue?))
(define (front-queue q)
  (q 'front-queue))
(define (insert-queue! q item)
  (q 'insert-queue! item))
(define (delete-queue! q)
  (q 'delete-queue!))

Ex-3.21

Eva Lu is trying to say that for scheme standard print procedure its not a special data structure called queue but just another pair that contains other pairs. So, print simply prints what is inside the queue *pair*.

(define (print-queue queue)
  (display (front-ptr queue))) 

Ex-3.19

Method-1:
We basically keep on visiting next pair in the list. Whenever we visit a pair, we tag it saying that it was visited before. Moreover when we visit a pair, we check if it is already visited and if we find an already visited pair before reaching the list end then it is cyclic. The issue with this algorithm is that it is destructive in nature that is it will change the input list.

(define (visit-car list)
  (set-car! list (cons '*visited* (car list))))
(define (visited? x)
  (and (pair? x) (eq? (car x) '*visited*)))
(define (has-cycle? list)
  (cond
   ((null? list) #f)
   ((visited? (car list)) #t)
   (else (visit-car list)
         (has-cycle? (cdr list))))) 

Method-2:
This is a partial implementation of idea of Floyd's cycle finding algorithm aka tortoise and the hare algorithm, where we maintain two pointers(tortoise, hare), second(hare) moving twice as fast the first(tortoise) one and keep comparing them in each iteration. List has cycles if pointers become equal before encountering end of list.

(define (has-cycle? list)
  (define (has-cycle-aux? l1 l2)
    (cond
     ((eq? l1 l2) #t)
     (else
      (if (not (pair? (cdr l2))) #f
          (has-cycle-aux? (cdr l1) (cddr l2))))))
  (if (null? list) #f
      (has-cycle-aux? list (cdr list)))) 

Ex-3.18

(define (has-cycle? list)
  (define (already-in-list? x l)
    (cond
     ((null? l) #f)
     ((eq? (car l) x) #t)
     (else (already-in-list? x (cdr l)))))
  (let ((cache nil))
    (define (has-cycle-aux? list)
      (cond
       ((null? list) #f)
       ((already-in-list? (car list) cache)
        #t)
       (else
        (set! cache (cons (car list) cache))
        (has-cycle-aux? (cdr list)))))
    (has-cycle-aux? list))) 

Ex-3.17

(define (count-pairs x)
  (define (stored-in-list? x l)
    (cond
     ((null? l) #f)
     ((eq? (car l) x) #t)
     (else (stored-in-list? x (cdr l)))))
  (let ((cache nil))
    (define (count-pairs-aux x)
      (cond
       ((not (pair? x)) 0)
       ((stored-in-list? x cache)
        (+ (count-pairs-aux (car x))
           (count-pairs-aux (cdr x))))
       (else
        (set! cache (cons x cache))
        (+ (count-pairs-aux (car x))
           (count-pairs-aux (cdr x))
           1))))
    (count-pairs-aux x))) 

Ex-3.16

;returns 3
(define l1 (cons 1 (cons 2 (cons 3 nil))))

;returns 4
(define p (cons 1 2))
(define l2 (cons p (cons p 3)))

;returns 5
(define p (cons 1 2))
(define l3 (cons p (cons p p)))

;returns 7
(define p (cons 1 2))
(define p1 (cons p p))
(define l4 (cons p1 p1))

;never return at all
(define p (cons 1 2))
(define l5 (cons 1 (cons 2 p)))
(set-cdr! p l5)

Ch3, Section - 3.2 , some notes

Here I noticed two important things...

1. Once we introduce assignment, we can't consider a variable simply a name for a value, instead a variable must somehow designate a *place* where value is stored and with assignment value stored at that place can change.
For this reason, there is a difference between defining a variable and binding it to a value(storing value in the *place*).. in some languages like Oz, variables can exist without a binding and are called *unbound* variables.. and dataflow variables are another special variables which can be bound only once and if unbound then the calling thread waits unless that variable gets a binding.

2. A scheme procedure consists of 3 parts. A parameter list, code in the body and a pointer to the environment where its created. When it is applied *this* is the environment that is extended with bindings for parameters to arguments and not the one in which execution is happening.

Ex-3.8

(define y 1)
(define (f x)
  (set! y (* y x))
  y)
;trying on MIT/GNU Scheme      
1 ]=> (+ (f 0) (f 1))
;Value: 1

;so arguments are evaluated right to left

We need to set y back to 1 if we want to re-run.

Ex-3.7

(define (make-joint acc passwd another-passwd)
  ;check if passwd is correct
  (if (equal? "Incorrect Password" ((acc passwd 'deposit) 0))
      "Incorrect Password"
      (lambda (p m)
         (if (eq? p another-passwd)
             (acc passwd m) "Incorrect Password")))) 

Chapter-3 prologue

I found this very interesting...

When we design a large program, its dictated by our perception of the system to be modeled. And, there are two organization strategies arising from two different world views of the system.
The first concentrates on objects, viewing a large system as collection of objects changing with time. For each object we create a corresponding computational object and for each action a symbolic operation in our computational model.
The second strategy concentrates upon the streams of information that flow in the system.

In fact this chapter is all about representing the "change" and hence time in computations. And, the two views described above result in two different programming paradigms to deal with time called object oriented programming and stream based programming.


A friend often says, as these are just two views of the system so it should be possible to look at any system using any one of the two views and that in turn means that we should be able to take a system modeled with collection of objects and remodel it using the streams and viceversa.

Ex-3.6

(define rand-init 10)
(define rand
  (let ((next rand-init))
    (define (dispatch msg)
      (cond
       ((eq? msg 'generate)
        (set! next (rand-update init))
        next)
       ((eq? msg 'reset)
        (lambda (new-val) (set! next new-val)))
       (else (error "message not recognized"))))
    dispatch)) 

Ex-3.5

(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (random range))))
(define (estimate-integral p x1 x2 y1 y2 n)
  (define (experiment)
    (let ((x (random-in-range x1 x2))
          (y (random-in-range y1 y2)))
      (p x y)))
  (* (monte-carlo n experiment) (* (- x2 x1) (- y2 y1))))

;procedure that creates a predicate to test whether
;given point lies in a circle
(define (make-in-circle-proc centreX centreY radius)
  ;for (x,y) to lie in the circle, distance
  ;between centre and (x,y) should be < radius
  (lambda (x y)
    (<= (+ (square (- centreX x))
          (square (- centreY y)))
       (square radius))))
    

;measuring PI by measuring area of unit circle  
1 ]=> (exact->inexact
 (estimate-integral
  (make-in-circle-proc 0 0 1)
  -1 1 -1 1 1000))
;Value: 3.032

1 ]=> (exact->inexact
 (estimate-integral
  (make-in-circle-proc 0 0 1)
  -1 1 -1 1 1000))
;Value: 3.008

1 ]=> (exact->inexact
 (estimate-integral
  (make-in-circle-proc 0 0 1)
  -1 1 -1 1 1000))
;Value: 2.964

1 ]=> (exact->inexact
 (estimate-integral
  (make-in-circle-proc 0 0 1)
  -1 1 -1 1 1000))
;Value: 2.952

1 ]=> (exact->inexact
 (estimate-integral
  (make-in-circle-proc 0 0 1)
  -1 1 -1 1 1000))
;Value: 3.036

1 ]=> (exact->inexact
 (estimate-integral
  (make-in-circle-proc 0 0 1)
  -1 1 -1 1 1000))
;Value: 2.948 

Ex-3.4

(define (make-account balance secret-passwd)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (let ((counter 0))
    (define (dispatch p m)
      (if (eq? p secret-passwd)
          (begin
            (cond 
             ((eq? m 'withdraw) withdraw)
             ((eq? m 'deposit) deposit)
             (else (error "Unknown request -- MAKE-ACCOUNT"
                        m)))
            (set! counter 0))
          (begin
            (set! counter (+ counter 1))
            (if (> counter 7) "Call the cops"
                "Incorrect Password"))))
    dispatch)) 

Ex-3.3

(define (make-account balance secret-passwd)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (dispatch p m)
    (if (eq? p secret-passwd)
        (cond 
         ((eq? m 'withdraw) withdraw)
         ((eq? m 'deposit) deposit)
         (else (error "Unknown request -- MAKE-ACCOUNT"
                      m)))
        "Incorrect Password"))
  dispatch)

Ex-3.2

(define (make-monitored f)
  (let ((count 0))
    (lambda (x)
      (cond
       ((eq? x 'how-many-calls) count)
       ((eq? x 'reset-count) (set! count 0))
       (else
        (set! count (+ count 1))
        (f x))))))

Ex-3.1

(define (make-accumulator x)
  (lambda (n)
    (set! x (+ x n))
    x))

Section-2.5.3 - passed

passed

Section-2.5.2; Ex-2.81-2.86

Ex-2.81
a; It will fall into a recursive loop. Why, here is the reason

 1(define (apply-generic op . args)
 2  (let ((type-tags (map type-tag args)))
 3    (let ((proc (get op type-tags)))
 4      (if proc
 5          (apply proc (map contents args))
 6          (if (= (length args) 2)
 7              (let ((type1 (car type-tags))
 8                    (type2 (cadr type-tags))
 9                    (a1 (car args))
10                    (a2 (cadr args)))
11               (let ((t1->t2 (get-coercion type1 type2))
12                      (t2->t1 (get-coercion type2 type1)))
13                  (cond (t1->t2
14                         (apply-generic op (t1->t2 a1) a2))
15                        (t2->t1
16                         (apply-generic op a1 (t2->t1 a2)))
17                        (else
18                         (error "No method for these types"
19                                (list op type-tags))))))
20              (error "No method for these types"
21                     (list op type-tags)))))))

(exp x y) ;x and y are complex numbers
(apply-generic 'exp x y) 

Now since there is no operation called exp is defined for type (complex complex), proc obtained at line 3 will be nil and we'll come to line 6 in above code. At line 11 t1->t2 will again be x and we'll recursively end up calling (apply-generic 'exp x y) again and will never exit.

b;If proc at line 3 is not nil then there is absolutely no issue. But if its nil then apply-generic will unnecessarily try to do the coercion. So, the conclusion is, it will work as is but will try to do the useless coercion.

c;

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (if (eq? type1 type2)
                    (error "No method for these types"
                                (list op type-tags))
                    (let ((t1->t2 (get-coercion type1 type2))
                          (t2->t1 (get-coercion type2 type1)))
                      (cond (t1->t2
                             (apply-generic op (t1->t2 a1) a2))
                            (t2->t1
                             (apply-generic op a1 (t2->t1 a2)))
                            (else
                             (error "No method for these types"
                                    (list op type-tags)))))))
                (error "No method for these types"
                       (list op type-tags)))))))

Ex-2.82
This strategy will fail in following situation, let say we call a generic procedure on two arguments whose types are integer and real. Since there is no direct coercion between mentioned types so it'll basically fail even though in reality it is possible to coerce integer into real following the route integer->rational->real.

Ex-2.83

(define (raise x)
  (apply-generic 'raise x))

(define (raise-integer x)
  (make-rational (contents x) 1))
(put 'raise '(integer) raise-integer)
(define (raise-rational x)
  (make-complex-from-real-imag
   (exact->inexact (/ (numer x) (denom x))) 0))
(put 'raise '(rational) raise-rational)

Ex-2.84-

;;we can represent the tower with a list
(define tower '(scheme-number rational  complex))
;;checks if type1 is at lower level in the tower than
;;type2
;;todo: impl this
(define (before-in-tower type1 type2)
  (< (listref type1 tower)))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (cond
                 ((before-in-tower type1 type2)
                  (apply-generic op (raise a1) a2))
                 ((before-in-tower type2 type1)
                  (apply-generic op a1 (raise a2)))
                 (else (error "No method for these types"
                              (list op type-tags)))))
              (error "No method for these types"
                     (list op type-tags)))))))

Ex-2.85- passed
Ex-2.86- passed

section-2.5.1, Ex-2.77-2.80

Ex-2.77
(magnitude z)
(apply-generic 'magnitude z)
(apply (get 'magnitude '(complex)) (list (contents z)))
Now let say content of z is z1 wihch is a complex number in polar notation and
(magnitude polar-z)
(apply-generic 'magnitude polar-z)
(apply (get 'magnitude '(polar)) (list (contents polar-z)))
This will find the concrete magnitude procedure to get magnitude of a complex number in polar representation. apply-generic is called two times as we have two level of abstraction. Number->Complex->Polar(or Rectangular).

Ex-2.78

(define (attach-tag type-tag contents)
  (if (number? contents) contents
      (cons type-tag contents)))
(define (type-tag datum)
  (cond
   ((number? datum) 'scheme-number)
   ((pair? datum) (car datum))
   (else (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond
   ((number? datum) datum)
   ((pair? datum) (cdr datum))
   (else (error "Bad tagged datum -- CONTENTS" datum)))) 

Ex-2.79

(define (equ? x y)
  (apply-generic 'equ? x y))

(define (equ-scheme-number? x y)
  (= x y))
(put 'equ? '(scheme-number scheme-number) equ-scheme-number?)

(define (equ-rational-number? x y)
  (and (= (numer x) (numer y))
       (= (denom x) (denom y))))
(put 'equ? '(rational rational) equ-rational-number?)

(define (equ-complex-number? x y) 
  (and (= (real-part x) (real-part y))
       (= (imag-part x) (imag-part y))))
(put 'equ? '(complex complex) equ-complex-number?) 

Ex-2.80

(define (=zero? x)
  (apply-generic '=zero? x))

(put '=zero? '(scheme-numer)
     (lambda (x) (= x 0)))

(put '=zero? '(rational)
     (lambda (x) (= (numer x) 0)))

(put '=zero? '(complex)
     (lambda (x) (and
                  (= (real-part x) 0)
                  (= (imag-part x) 0)))) 

Ex-2.76

I'm going to present views on all three strategies with respect to adding new data type and operations.

Explicit dispatch programming:
Adding new Data Type:
We must put appropriate code to support new data type in *all* generic operation definitions and write constructor for it.
Adding new Operation:
Implement it for all data types and We must create a generic operation for it that does type dispatch on all the data types.

Data directed programming:
Adding new Data Type:
No change to generic operation, but need to put all the operations for this data type into operation-type table.
Adding new Operation:
Put the new operation definitions for all data types into operation-type table and Need to create a generic operation which is very simple in this case, that will just do a get on the table to find appropriate procedure.

Message passing style programming:
Adding new Data Type:
We just need to create a new constructor for it(that returns dispatch procedure).
Adding new Operation:
We have to modify all the constructors to include this new operations.

Most appropriate organization for frequent addition of new data types would be the message passing style and same for frequent addition of operations would be data directed programming.

Ex-2.75

(define (make-from-mag-ang mag ang)
  (define (dispatch op)
    (cond ((eq? op 'real-part)
           (* mag (cos ang)))
          ((eq? op 'imag-part)
           (* mag (sin ang)))
          ((eq? op 'magnitude) mag)
          ((eq? op 'angle) ang)
          (else
           (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch) 

Ex-2.74

a:We can give each division's personnel record file a tag and that is the division's name itself.
(

define (get-record file employee-name)
  ((get 'get-record (get-division file))
   file employee-name)) 

b:Each employee record is also given a tag and that is the the division's name itself.

(define (get-salary employee-record)
  ((get 'get-salary (get-division employee-record))
   employee-record)) 

c:

(define (find-employee-record files name)
  (cond
   ((null? files) nil)
   ((null? (get-record (car files) name))
    (find-employee-record (cdr files) name))
   (else
    (get-record (car files) name)))) 

d:A new division needs to be added with its appropriate procedures into the type-operations table.

Ex-2.73

a:
We moved from dispatch on type way of programming to data directed programming that helps bring modularity into the program that is it makes easier to change one part of the program independent of the others. We can't put number, variable into same data directed dispatch as they really don't have type tags and can't be put in operation-type table.

b:

(define (deriv-sum exp)
  (make-sum (deriv (addend exp) var)
            (deriv (augend exp) var)))
(define (deriv-product exp)
  (make-sum
   (make-product (multiplier exp)
                 (deriv (multiplicand exp) var))
   (make-product (deriv (multiplier exp) var)
                 (multiplicand exp))))
;aux code to put them in table
(put 'deriv '(+) deriv-sum)
(put 'deriv '(*) deriv-product)

c:

(define (deriv-exponent exp)
  (make-product
   (exponent exp)
   (make-product
    (make-exponentiation (base exp)
                         (- (exponent exp) 1))
    (deriv (base exp) var))))
(put 'deriv '(**) deriv-exponent) 

d: none

Section-2.3.4; Ex-2.67-2.72

Ex 2.67
1 ]=> (decode sample-message sample-tree)
;Value 1: (a d a b b c a)

Ex-2.68

(define (encode-symbol symbol tree)
  (define (iter tree-or-leaf result)
    (cond
     ((leaf? tree-or-leaf)
      (if (eq? symbol (symbol-leaf tree-or-leaf))
          result
          (error "symbol is not in given tree")))
     ((memq symbol (symbols tree-or-leaf))
      (if (memq symbol (symbols (left-branch tree-or-leaf)))
          (iter (left-branch tree-or-leaf) (cons 0 result))
          (iter (right-branch tree-or-leaf) (cons 1 result))))
     (else (error "symbol is not in given tree"))))
  (reverse (iter tree '())))

1 ]=> (encode '(a d a b b c a) sample-tree)
;Value 3: (0 1 1 0 0 1 0 1 0 1 1 1 0)
1 ]=> (equal? (encode '(a d a b b c a)
                      sample-tree)
              sample-message)
;Value: #t 

Ex-2.69

(define (successive-merge leafs)
  (cond
   ((null? leafs) nil)
   ((= (length leafs) 1)
    (make-code-tree (car leafs) nil))
   ((= (length leafs) 2)
    (make-code-tree (cadr leafs) (car leafs)))
   (else
    (successive-merge
     (cons (make-code-tree (cadr leafs) (car leafs))
           (cddr leafs)))))) 

Ex-2.70

(define rock-pairs '((na 16)
                (yip 9)
                (sha 3)
                (job 2)
                (get 2)
                (a 2)
                (boom 1)
                (wah 1)))
(define encoded-message
  (encode
   '(Get a job
         Sha na na na na na na
         na na Get a job Sha na
         na na na na na na na
         Wah yip yip yip yip yip 
         yip yip yip yip
         Sha boom)
   (generate-huffman-tree rock-pairs)))

;number of bits used
1 ]=> (length encoded-message)
;Value: 87 

For fixed length encoding:
there are 8 distinct symbols, so we need atleast 3 bits for each symbol, and message has 36 symbols, so for fixed-length code we would need
3 X 36 = 108 bits

Ex-2.71
For most frequent symbol we need just 1 bit for any value of n.
For least frequent symbol:
number of bits needed =
depth of the generated tree =
(ceiling (log n)) ;where base=2 in log

Ex-2.72 - todo

Ex-2.66

(define (look-up given-key set)
  (cond
   ((null? set) #f)
   ((= given-key (key (car set))) #t)
   ((< given-key (key (car set)))
    (look-up given-key (left-branch set)))
   ((> given-key (key (car set)))
    (look-up given-key (right-branch set)))))

Ex-2.65

;set1, set2 are ordered lists
(define (union-set-aux set1 set2)
  (cond
   ((null? set1) set2)
   ((null? set2) set1)
   ((< (car set1) (car set2))
    (cons (car set1) (union-set-aux (cdr set1) set2)))
   ((= (car set1) (car set2))
    (cons (car set1) (union-set-aux (cdr set1) (cdr set2))))
   (else
    (union-set-aux set2 set1))))
;set1, set2 are binary trees
(define (union-set set1 set2)
  (list->tree
   (union-set-aux
    (tree->list-2 set1)
    (tree->list-2 set2)))) 

Ex-2.64

;a
Once again, this demonstrates the power of wishful thinking. (partial-tree elt n) assumes that a left-sub-tree with first (quotien (- n 1) 2) elements of elt and a right-sub-tree of last (- n (+ left-size 1)) elements of elt is available and then it just constructs the tree using left-sub-tree, right-sub-tree and this-entry(the middle entry thats not included in any of the sub-trees).

1 ]=> (list->tree '(1 3 5 7 9 11))
;Value 19: (5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))

;b
t(n) = 2t(n/2), hence O(n)

Ex-2.63

;a
Both procedures do in-order traversal of the tree to create the list, hence both produce the same results.

;List produced for figures of 2.16 is same
(define tree-1 '(7 (3 (1 () ()) (5 () ()))
                   (9 () (11 () ()))))
(define tree-2 '(3 (1 () ())
                   (7 (5 () ()) (9 () (11 () ())))))
(define tree-3 '(5 (3 (1 () ()) ())
                   (9 (7 () ()) (11 () ()))))
;which is (1 3 5 7 9 11) 

;b

For tree->list-1
t(n) = steps-to-append + t(n/2) + t(n/2)
     = a + bn + 2t(n/2)
solving above recurrance equation will get
its O(nlogn)

For tree->list-2
t(n) = 2t(n/2)
its O(n)

clearly tree->list-1 is slower version.

Ex-2.62

(define (union-set set1 set2)
  (cond
   ((null? set1) set2)
   ((null? set2) set1)
   ((< (car set1) (car set2))
    (cons (car set1) (union-set (cdr set1) set2)))
   ((= (car set1) (car set2))
    (cons (car set1) (union-set (cdr set1) (cdr set2))))
   (else
    (union-set set2 set1))))

Ex-2.61

(define (adjoin-set x set)
  (cond
   ((null? set) (list x))
   ((< x (car set)) (cons x set))
   (else
    (cons (car set) (adjoin-set x (cdr set)))))) 

Ex-2.60

;element-of-set? stays the same and
; is O(n) operation

;adjoin-set
;its a O(1) operation now
(define (adjoin-set x set)
  (cons x set))

;union-set
;its a O(n) operation now
(define (union-set set1 set2)
  (append set1 set2))

;intersection-set stays the same and
;is O(n^2) operation 

Ex-2.59

(define (union-set set1 set2)
  (if (null? set1) set2
      (adjoin-set
       (car set1)
       (union-set (cdr set1) set2))))

Section-2.3.2;Ex-2.56,2.57,2.58

This section is dedicated to create a symbolic differentiation program that demonstrates the concept of data-abstraction. The main derivation algorithm works on the abstract objects such as sum, variable and product with no knowledge of how they are represented, so we can change their representation any time without touching derivation algorithm.
Another thing to notice is the power of the lisp-notation, author first describes the rules of derivation and then translates them into scheme using cond and that translation into scheme just looks straight forward. What I'm saying is that how easy it was to convert math rules into working scheme program.

;code from book  to run the examples
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (make-sum a1 a2) (list '+ a1 a2))
(define (make-product m1 m2) (list '* m1 m2))
(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))
(define (addend s) (cadr s))
(define (augend s) (caddr s))
(define (product? x)
  (and (pair? x) (eq? (car x) '*)))
(define (multiplier p) (cadr p))
(define (multiplicand p) (caddr p))
(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (list '+ a1 a2))))
(define (=number? exp num)
  (and (number? exp) (= exp num)))
(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (list '* m1 m2)))) 

;Ex-2.56

(define (make-exponentiation base exponent)
  (cond
   ((= exponent 0) 1)
   ((= exponent 1) base)
   (else
    (list '** base exponent))))
(define (exponentiation? exp)
  (eq? (car exp) '**))
(define (base exp)
  (cadr exp))
(define (exponent exp)
  (caddr exp))

(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp)
         (if (same-variable? exp var) 1 0))
        ((sum? exp)
         (make-sum (deriv (addend exp) var)
                   (deriv (augend exp) var)))
        ((product? exp)
         (make-sum
          (make-product (multiplier exp)
                        (deriv (multiplicand exp) var))
          (make-product (deriv (multiplier exp) var)
                        (multiplicand exp))))
        ((exponentiation? exp)
         (make-product
          (exponent exp)
          (make-product
           (make-exponentiation (base exp)
                                (- (exponent exp) 1))
           (deriv (base exp) var))))
        (else
         (error "unknown expression type -- DERIV" exp))))

;Ex-2.57

(define (make-sum a1 a2 . a)
  ;find sum of all the numbers in given args
  (define (number-sum args sum)
    (cond
     ((null? args) sum)
     ((number? (car args))
      (number-sum (cdr args) (+ sum (car args))))
     (else (number-sum (cdr args) sum))))
  ;list only the symbols from given list of args
  (define (symbols-only args)
    (filter (lambda (x) (not (number? x))) args))
  
  (let ((sum (number-sum (cons a1 (cons a2 a)) 0))
        (symbols (symbols-only (cons a1 (cons a2 a)))))
    (cond
     ((and (= 0 sum)
           (= 0 (length symbols))) 0)
     ((and (= 0 sum)
           (= 1 (length symbols))) (car symbols))
     ((and (= 0 sum)
           (apply list (cons '+ symbols))))
     ((= (length symbols) 0) sum)
     (else (apply list (cons '+ (cons sum symbols)))))))

(define (addend exp)
  (cadr exp))
(define (augend exp)
  (if (> (length (cddr exp)) 1)
      (apply make-sum (cddr exp))
      (caddr exp)))
;tests for make-sum
(make-sum 1 2) ;3
(make-sum 1 'a) ;(+ 1 a)
(make-sum 1 -1 'a) ;a
(make-sum 1 -1) ;0
(make-sum 1 -2 'a 'b)  ;(+ -1 a b)
(make-sum 1 'a 'b 'c '3) ;(+ 4 a b c)

(define (make-product a1 a2 . a)
  ;find sum of all the numbers in given args
  (define (number-prod args prod)
    (cond
     ((null? args) prod)
     ((number? (car args))
      (number-prod (cdr args) (* prod (car args))))
     (else (number-prod (cdr args) prod))))
  ;list only the symbols from given list of args
  (define (symbols-only args)
    (filter (lambda (x) (not (number? x))) args))
  
  (let ((prod (number-prod (cons a1 (cons a2 a)) 1))
        (symbols (symbols-only (cons a1 (cons a2 a)))))
    (cond
     ((= prod 0) 0)
     ((and (= 1 prod)
           (= 0 (length symbols))) 1)
     ((and (= 1 prod)
           (= 1 (length symbols))) (car symbols))
     ((and (= 1 prod)
           (apply list (cons '* symbols))))
     ((= 0 (length symbols)) prod)
     (else
      (apply list (cons '* (cons prod symbols)))))))

(define (multiplier exp)
  (cadr exp))
(define (multiplicand exp)
  (if (> (length (cddr exp)) 1)
      (apply make-product (cddr exp))
      (caddr exp)))
;tests for make-product
(make-product 1 2) ;2
(make-product 1 'a) ;a
(make-product 1 -1 'a) ;(* -1 a)
(make-product 1 -1 'a 'b) ;(* -1 a b)
(make-product 1 'a 'b 'c 3) ;(* 3 a b c)
(make-product 1 'a 'b 'c 3 0) 0 

;Ex-2.58
;a

(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (list a1 '+ a2))))
(define (=number? exp num)
  (and (number? exp) (= exp num)))
(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (list m1 '* m2))))
(define (sum? x)
  (and (pair? x)
       (pair? (cdr x))
       (eq? (cadr x) '+)))
(define (addend s) (car s))
(define (augend s) (caddr s))
(define (product? x)
  (and (pair? x)
       (pair? (cdr x))
       (eq? (cadr x) '*)))
(define (multiplier p) (car p))
(define (multiplicand p) (caddr p))

;b - TODO

Ex-2.55

Internally 'abc translates to (quote abc).

(car ''abracadabra)
(car '(quote abracadabra))
quote => first element of (list 'quote 'abracadabra)

Ex-2.54

(define (equal? o1 o2)
  (cond
   ((and (pair? o1) (pair? o2))
    (and (eq? (car o1) (car o2))
         (equal? (cdr o1) (cdr o2))))
   ((or (pair? o1) (pair? o2)) #f)
   (else (eq? o1 o2))))

Ex-2.43

passed

Ex-2.42

;positions on the board are represented using pair
;(row col) where 1<=row,col<= board-size
(define empty-board '())
(define (adjoin-position row col rest-of-queens)
  (cons (cons row col) rest-of-queens))
(define (safe? k positions)
  ;returns #t if a pos is safe with respect to other
  ;positions
  (define (safe-position? pos positions)
    (if (null? positions) true
        (and (safe-two-positions? pos (car positions))
             (safe-position? pos (cdr positions)))))

  ;returns #t if two positions are safe for each other
  (define (safe-two-positions? pos1 pos2)
    (cond
     ((= (car pos1) (car pos2)) #f)
     ((= (cdr pos1) (cdr pos2)) #f)
     ((same-diagonal? pos1 pos2) #f)
     (else #t)))

  ;returns #t if two positions are on same diagonal
  (define (same-diagonal? pos1 pos2)
    (= (abs (- (car pos1) (car pos2)))
       (abs (- (cdr pos1) (cdr pos2)))))

  ;here we made the assumption that first position
  ;in given positions is the one which has queen
  ;on k'th column, this holds true because of the
  ;way code written in procedure queens, this is
  ;not really right assumption to make but then we
  ;can change that anytime.
  (safe-position? (car positions) (cdr positions)))

Ex-2.40,2.41

2.40

(define (unique-pairs n)
  (accumulate
   (lambda (x y) 
     (append (map (lambda (z)
            (cons x z)) (enumerate-interval 1 (- x 1))) y))
   nil (enumerate-interval 1 n)))

(define (prime-sum-pairs n)
  (filter prime-sum?
          (map
           (lambda (x)
             (list (car x) (cdr x) (+ (car x) (cdr x))))
           (unique-pairs n))))

2.41

;this generates ordered triples of distinct positive
;integers i, j, and k less than or equal to a given
;integer n

(define (enumerate-all-triplets n)
  (flatmap (lambda (x) x)
   (map
    (lambda (x)
      (map (lambda (y)
             (list y (car x) (cdr x)))
           (enumerate-interval (+ (car x) 1) n)))
    (unique-pairs n))))

(define (triplet-with-sum-s n s)
  (filter (lambda (x)
            (= s
               (+ (car x) (cadr x) (caddr x))))
          (enumerate-all-triplets n))) 

Ex-2.39

(define (reverse sequence)
  (fold-right (lambda (x y) (append y (list x))) nil sequence))
(define (reverse sequence)
  (fold-left (lambda (x y) (cons y x)) nil sequence))

Ex-2.38

Result from fold-left and fold-right is same only when op is such that (op x y) is equal to (op y x), mathematically its called the commutative property.

Ex-2.37

(define (matrix-*-vector m v)
  (map
   (lambda (w)
     (dot-product v w)) m))
(define (transpose mat)
  (accumulate-n
   (lambda (x y) (cons x y))
   '() mat))
(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map
     (lambda (v)
       (map (lambda (w) (dot-product v w)) cols))
     m)))

Ex-2.36

(define (accumulate-n op init seqs)
  (if (or (null? seqs) (null? (car seqs)))
      '()
      (cons (accumulate op init
                        (map (lambda (x) (car x)) seqs))
            (accumulate-n op init
                          (map (lambda (x) (cdr x)) seqs)))))

Ex-2.35

basically with map we create a flat list containing number of leaves in each subtree and then accumulate is used to sum them up.

(define (count-leaves t)
  (accumulate
   + 0 
   (map (lambda (x)
          (if (pair? x)
              (count-leaves x) 1)) t))) 

Ex-2.34

(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms)
                (+ this-coeff (* higher-terms x)))
              0
              coefficient-sequence))

Ex-2.33

(define (map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) nil sequence))
(define (append seq1 seq2)
  (accumulate cons seq2 seq1))
(define (length sequence)
  (accumulate (lambda (x y) (+ y 1)) 0 sequence)) 

Ex-2.32

(define (subsets s)
  (if (null? s)
      (list '())
      (let ((rest (subsets (cdr s))))
        (append rest
                (map (lambda (x)
                       (cons (car s) x)) rest)))))

Why it works?
Wishful thinking :)
we assumed that we got subsets of (cdr s), now all we need to think is how to get additional subsets of s that contain (car s) and the answer is simply to include (car s) in all the subsets of (cdr s).

Ex-2.31

(define (tree-map proc tree)
  (map
   (lambda (x)
     (if (pair? x)
         (tree-map proc x) (proc x))) tree))
(define (square-tree tree)
  (tree-map square tree))

Ex-2.30

;without using any higher order procedures
(define (square-tree tree)
  (cond
   ((null? tree) '())
   ((list? (car tree))
    (append (list (square-tree (car tree)))
            (square-tree (cdr tree))))
   (else
    (cons (square (car tree))
          (square-tree (cdr tree))))))

;using higher order procedures
(define (square-tree tree)
  (map
   (lambda (x)
     (if (pair? x)
         (square-tree x) (square x))) tree))

Ex-2.29

;a

(define (left-branch m)
  (car m))
(define (right-branch m)
  (cadr m))
(define (branch-length b)
  (car b))
(define (branch-structure b)
  (cadr b))

;b

;total weight of a mobile
(define (total-weight m)
  (+ (branch-total-weight (left-branch m))
     (branch-total-weight (right-branch m))))


;find total weight of a branch
(define (branch-total-weight b)
  (if (pair? (branch-structure b))
             (total-weight (branch-structure b))
             (branch-structure b)))

;test
(define b1 (make-branch 1 2))
(define b2 (make-branch 1 3))
(define m1  (make-mobile b1 b2))
(define b3 (make-branch 1 5))
(define b4 (make-branch 1 m1))
(define m (make-mobile b3 b4))
(total-weight m)
;Value: 10 

;c

(define (balanced? m)
  (let ((lb (left-branch m))
        (rb (right-branch m)))
    (and
     (branch-balanced? lb)
     (branch-balanced? rb)
     (=
      (* (branch-length lb) (branch-total-weight lb))
      (* (branch-length rb) (branch-total-weight rb))))))
;see if a branch has a mobile structure and its
;balanced, if it has weight then return true
(define (branch-balanced? b)
  (if (pair? (branch-structure b))
             (balanced? (branch-structure b))
             #t))

;test
(define b1 (make-branch 1 2))
(define b2 (make-branch 1 3))
(define m1  (make-mobile b1 b2))
(define b3 (make-branch 1 5))
(define b4 (make-branch 1 m1))
(define m (make-mobile b3 b4))
(balanced? m)
;Value: #f
(define b2 (make-branch 1 2))
(define m1  (make-mobile b1 b2))
(define b4 (make-branch 1 m1))
(define m (make-mobile b4 b4))
;value: #t 

;d
Since we abstracted out the details of how we select various component of mobile and branch, so only selectors need to change.

(define (left-branch m)
  (car m))
(define (right-branch m)
  (cdr m))
(define (branch-length b)
  (car b))
(define (branch-structure b)
  (cdr b))

Ex-2.28

(define (fringe tree)
  (cond
   ((null? tree) '())
   ((pair? tree)
    (append (fringe (car tree)) (fringe (cdr tree))))
   (else (list tree)))) 

Used wishful thinking here. I thought like this, If we knew the fringes of left and right subtree then the answer would be to just append them and this does the trick :).

Ex-2.27

(define (deep-reverse l)
  (define (iter a r)
    (cond ((null? a) r)
          ((list? (car a))
           (iter (cdr a) (cons (deep-reverse (car a)) r)))  
          (else (iter (cdr a) (cons (car a) r)))))
  (iter l '())) 

Ex-2.26

passed

Ex-2.25

(car (cdaddr '(1 3 (5 7) 9)))
(caar '((7)))
(cadadr (cadadr (cadadr '(1 (2 (3 (4 (5 (6 7)))))))))

Ex-2.24

1 ]=> (list 1 (list 2 (list 3 4)))
;Value 9: (1 (2 (3 4)))

Ex-2.23

(define (for-each proc l)
  (if (not (null? l))
      (begin (proc (car l))
             (for-each proc (cdr l)))))

Ex-2.22

Why reverse order is obtained?
Let us see the execution of iter...
(iter '(1 2 3 4) '())
(iter '(2 3 4) '(1))
(iter '(3 4) '(4 1))
(iter '(4) '(9 4 1))
(iter '() '(16 9 4 1))
'(16 9 4 1)

After trying to "fix" here is what the execution of iter looks like..
(iter '(1 2) '())
(iter '(2) (cons '() 1))
(iter '() (cons (cons '() 1) 4))
(cons (cons '() 1) 4) => this is not (list 1 4)

Ex-2.21

(define (square-list items)
  (if (null? items)
      '()
      (cons (square (car items)) (square-list (cdr items)))))
(define (square-list items)
  (map (lambda (x) (square x)) items)) 

Ex-2.20

(define (same-parity x . r)
  (let ((proc (if (even? x) even? odd?)))
    (cons x
          (filter proc r))))

Ex-2.19

(define (cc amount coin-values)
  (cond ((= amount 0) 1)
        ((or (< amount 0) (no-more? coin-values)) 0)
        (else
         (+ (cc amount
                (except-first-denomination coin-values))
            (cc (- amount
                   (first-denomination coin-values))
                coin-values)))))
(define (first-denomination coins)
  (car coins))
(define (no-more? coin-values)
  (= (length coin-values) 0))
(define (except-first-denomination coin-values)
  (cdr coin-values)) 

Order of coin-values doesn't affect the answer produced, because in the cc we're treating coin-values as just a set of values without any assumption of its order.

Ex-2.18

(define (reverse l)
  (define (iter a r)
    (if (null? a) r
        (iter (cdr a) (cons (car a) r))))
  (iter l '()))

Ex-2.17

(define (last-pair l)
  (list (list-ref l (- (length l) 1))))

Ex-2.16

passed

Ex-2.15

Yes, She is right. And the reason is, more the uncertain number is repeated more uncertainity it brings to the system(overall calculation).

Ex-2.14

(define (par1 r1 r2)
  (div-interval (mul-interval r1 r2)
                (add-interval r1 r2)))
(define (par2 r1 r2)
  (let ((one (make-interval 1 1)))
    (div-interval one
                  (add-interval (div-interval one r1)
                                (div-interval one r2))))) 

Indeed the results are different:
1 ]=> (par1 (make-interval 3 4) (make-interval 5 7))
;Value 1: (1.3636363636363638 . 3.5)
1 ]=> (par2 (make-interval 3 4) (make-interval 5 7))
;Value 2: (1.875 . 2.5454545454545454)

with center-percent form also the results are different
1 ]=> (par1 (make-center-percent 5 10) (make-center-percent 10 5))
;Value 4: (2.671875 . 4.125)
1 ]=> (par2 (make-center-percent 5 10) (make-center-percent 10 5))
;Value 5: (3.053571428571429 . 3.609375)