path: root/sicp/chapter3.rkt

#lang sicp

; Exercise 3.1
(define (make-accumulator value)
  (lambda (x)
    (set! value (+ value x))
    value))

; Exercise 3.2
(define (make-monitored f)
  (let ((count 0))
    (lambda (input)
      (cond ((eq? input 'how-many-calls?) count)
            ((eq? input 'reset-count) (set! count 0))
            (else (set! count (inc count))
                  (f input))))))

(define (make-account balance)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (lambda (request)
    (cond ((eq? request 'withdraw) withdraw)
          ((eq? request 'deposit) deposit)
          ((eq? request 'balance) balance)
          (else (error "Unknown request: MAKE-ACCOUNT" request)))))

; Exercise 3.4
(define (make-secure account correct-password)
  (let ((trials 7))
    (lambda (password request)
      (cond ((eq? password correct-password)
             (set! trials 7)
             (account request))
            ((= trials 0) (lambda (a) "I'm calling the cops"))
            (else (set! trials (dec trials))
                  (lambda (a) "Incorrect password"))))))

(define rand-update
  (let ((a 2017)
        (b 5)
        (m 31))
    (lambda (x) (modulo (+ (* a x) b) m))))
(define rand
  (let ((x 208))
    (lambda ()
      (set! x (rand-update x))
      x)))

(define (monte-carlo trials experiment)
  (define (iter trials-remaining trials-passed)
    (cond ((= trials-remaining 0) (/ trials-passed trials))
          ((experiment) (iter (dec trials-remaining) (inc trials-passed)))
          (else (iter (dec trials-remaining) trials-passed))))
  (iter trials 0))
(define (cesaro-test)
  (= (gcd (random 100) (random 100)) 1))
(define (estimate-pi trials)
  (sqrt (/ 6 (monte-carlo trials cesaro-test))))

; Exercise 3.5
(define (random-in-range low high)
  (+ low (* (random (- high low)))))
(define (estimate-integral P x1 x2 y1 y2 trials)
  (monte-carlo trials (lambda () (P (random-in-range x1 x2)
                                    (random-in-range y1 y2)))))

; Exercise 3.7
(define (make-joint account old-password new-password)
  (let ((test ((account old-password 'withdraw) 0)))
    (if (number? test)
        (make-secure (lambda (request) (account old-password request))
                     new-password)
        test)))

; Exercise 3.12
(define (last-pair x)
  (if (null? (cdr x))
      x
      (last-pair (cdr x))))
(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

; Exercise 3.13
(define (make-cycle x)
  (set-cdr! (last-pair x) x)
  x)

; Exercise 3.14
(define (mystery x)
  (define (loop x y)
    (if (null? x)
        y
        (let ((temp (cdr x)))
          (set-cdr! x y)
          (loop temp x))))
  (loop x '()))

; Exercise 3.17
(define (count-pairs x)
  (define (adjoin! element set)
    (cond ((null? set) (set! set (list element))
                       true)
          ((eq? (car set) element) false)
          ((= (length set) 1) (set-cdr! set (list element))
                              true)
          (else (adjoin! element (cdr set)))))
  (define counted '())
  (define (iter struct)
    (if (and (pair? struct)
             (cond ((null? counted) (set! counted (list struct)) true)
                   ((adjoin! struct counted) true)
                   (else false)))
        (begin (iter (car struct))
               (iter (cdr struct)))))
  (iter x)
  (display counted)
  (newline)
  (length counted))

; Exercise 3.18
(define (in? x lst)
  (cond ((null? lst) false)
        ((eq? (car lst) x) true)
        (else (in? x (cdr lst)))))
(define (contain-cycle? lst)
  (define (iter upper lower)
    (display lower)
    (display upper)
    (newline)
    (cond ((null? lower) false)
          ((in? lower upper) true)
          (else (iter (cons lower upper) (cdr lower)))))
  (iter (list lst) (cdr lst)))

; Exercise 3.19
(define (contains-cycle? lst)
  (define (iter turtoise hare)
    (cond ((eq? turtoise hare) true)
          ((or (null? hare)
               (null? (cdr hare))
               (null? (cddr hare)))
           false)
          (else (iter (cdr turtoise) (cddr hare)))))
  (iter lst (cdr lst)))

; Exercise 3.22
(define (make-queue)
  (let ((front-ptr '())
        (rear-ptr '()))
    (define (set-front-ptr! item) (set! front-ptr item))
    (define (set-rear-ptr! item) (set! rear-ptr item))
    (define (empty?) (null? front-ptr))
    (define (front)
      (if (empty?)
          (error "FRONT called with an empty queue")
          (car front-ptr)))
    (define (insert! item)
      (let ((new-pair (list item)))
        (if (empty?)
            (set-front-ptr! new-pair)
            (set-cdr! rear-ptr new-pair))
        (set-rear-ptr! new-pair))
      front-ptr)
    (define (delete!)
      (if (empty?)
          (error "DELETE! called with an empty queue")
          (begin (set-front-ptr! (cdr front-ptr))
                 front-ptr)))
    (define (dispatch m)
      (cond ((eq? m 'front-ptr) (lambda () front-ptr))
            ((eq? m 'rear-ptr) (lambda () rear-ptr))
            ((eq? m 'empty?) empty?)
            ((eq? m 'front) front)
            ((eq? m 'insert!) insert!)
            ((eq? m 'delete!) delete!)
            (else (error "Unknown procedure: MAKE-QUEUE" m))))
    dispatch))

; Exercise 3.23
(define (make-deque) (cons '() '()))
(define front-deque car)
(define rear-deque cdr)
(define set-front-deque! set-car!)
(define set-rear-deque! set-cdr!)
(define (empty-deque? deque) (null? (front-deque deque)))
(define (front-insert-deque! deque item)
  (if (empty-deque? deque)
      (let ((new-pair (list (list item))))
        (set-front-deque! deque new-pair)
        (set-rear-deque! deque new-pair))
      (begin (set-front-deque! deque (cons (list item) (front-deque deque)))
             (set-cdr! (cadr (front-deque deque)) (front-deque deque)))))
(define (front-delete-deque! deque)
  (if (empty-deque? deque)
      (error "FRONT-DELETE! called with an empty deque")
      (begin (set-front-deque! deque (cdr (front-deque deque)))
             (if (empty-deque? deque)
                 (set-rear-deque! deque '())
                 (set-cdr! (car (front-deque deque)) '())))))
(define (rear-insert-deque! deque item)
  (if (empty-deque? deque)
      (let ((new-pair (list (list item))))
        (set-front-deque! deque new-pair)
        (set-rear-deque! deque new-pair))
      (let ((new-rear (list (cons item (rear-deque deque)))))
        (set-cdr! (rear-deque deque) new-rear)
        (set-rear-deque! deque new-rear))))
(define (rear-delete-deque! deque)
  (if (empty-deque? deque)
      (error "REAR-DELETE! called with an empty deque")
      (let ((new-rear (cdar (rear-deque deque))))
        (if (null? new-rear)
            (begin (set-front-deque! deque '())
                   (set-rear-deque! deque '()))
            (begin (set-cdr! new-rear '())
                   (set-rear-deque! deque new-rear))))))

; Exercise 3.24 & 3.25
(define (make-table same-key?)
  (define (find key records)
    (cond ((null? records) false)
          ((same-key? key (caar records)) (car records))
          (else (assoc key (cdr records)))))
  (let ((local-table (list '*table*)))
    (define (lookup . keys)
      (define (ref keys records)
        (if (null? keys)
            records
            (let ((record (find (car keys) records)))
              (if record (ref (cdr keys) (cdr record)) false))))
      (ref keys (cdr local-table)))
    (define (insert! value . keys)
      (define (nested lst)
        (if (null? (cdr lst))
            (cons (car lst) value)
            (list (car lst) (nested (cdr lst)))))
      (define (assign! keys table)
        (if (null? keys)
            (set-cdr! table value)
            (let ((records (cdr table)))
              (let ((record (find (car keys) records)))
                (if record
                    (assign! (cdr keys) record)
                    (set-cdr! table (cons (nested keys) records)))))))
      (assign! keys local-table))
    (define (dispatch m)
      (cond ((eq? m 'lookup) lookup)
            ((eq? m 'insert!) insert!)
            (else (error "Unknown operation: TABLE" m))))
    dispatch))

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

(define (after-delay time procedure)
;  (sleep time)
  (procedure))
(define (inverter input output)
  (define inverter-delay 0.2)
  (define (invert-input)
    (let ((new-value (not (get-signal input))))
      (after-delay inverter-delay (lambda () (set-signal! output new-value)))))
  (add-action! input invert-input)
  'ok)
(define (and-gate a1 a2 output)
  (define and-gate-delay 0.5)
  (define (add-action-procedure)
    (let ((new-value (and (get-signal a1) (get-signal a2))))
      (after-delay and-gate-delay (lambda () (set-signal! output new-value)))))
  (add-action! a1 add-action-procedure)
  (add-action! a2 add-action-procedure)
  'ok)
; Exercise 3.28
(define (or-gate a1 a2 output)
  (define or-gate-delay 0.3)
  (define (add-action-procedure)
    (let ((new-value (or (get-signal a1) (get-signal a2))))
      (after-delay or-gate-delay (lambda () (set-signal! output new-value)))))
  (add-action! a1 add-action-procedure)
  (add-action! a2 add-action-procedure)
  'ok)
; Exercise 3.29
(define (not-and-not-gate a1 a2 output)
  (let ((b1 (make-wire))
        (b2 (make-wire))
        (c (make-wire)))
    ; Delay: (+ (* invert-input 3) and-gate-delay)
    (inverter a1 b1)
    (inverter a2 b2)
    (and-gate b1 b2 c)
    (inverter c output)))

; Exercise 3.30
(define (ripple-carry-adder ays bees eses c-out)
  (define (half-adder a b s c)
    (let ((d (make-wire))
          (e (make-wire)))
      (or-gate a b d)
      (and-gate a b c)
      (inverter c e)
      (and-gate d e s)))
  (define (full-adder a b c-in sum c-out)
    (let ((s (make-wire))
          (c1 (make-wire))
          (c2 (make-wire)))
      (half-adder b c-in s c1)
      (half-adder a s sum c2)
      (or-gate c1 c2 c-out)))
  (let ((c-in (if (null? (cdr ays))
                  (make-wire)
                  (ripple-carry-adder
                   (cdr ays) (cdr bees) (cdr eses) (make-wire)))))
    (full-adder (car ays) (car bees) c-in (car eses) c-out))
  c-out)

(define (inform-about-value constraints) (constraints 'I-have-a-value))
(define (inform-about-no-value constraints) (constraints 'I-lost-my-value))
(define (make-connector)
  (define (for-each-except exception procedure lst)
    (define (iter items)
      (if (not (null? items))
          (begin (if (not (eq? (car items) exception)) (procedure (car items)))
                 (iter (cdr items)))))
    (iter lst))
  (let ((value false)
        (informant false)
        (constraints '()))
    (define (set-my-value! newval setter)
      (cond ((not (has-value? me))
             (set! value newval)
             (set! informant setter)
             (for-each-except setter inform-about-value constraints))
            ((= value newval) 'ignored)
            (else (error "Contradiction" (list value newval)))))
    (define (forget-my-value! retractor)
      (if (eq? retractor informant)
          (begin (set! informant false)
                 (for-each-except retractor inform-about-no-value constraints))
          'ignored))
    (define (connect! new-constraint)
      (if (not (memq new-constraint constraints))
          (set! constraints (cons new-constraint constraints)))
      (if (has-value? me)
          (inform-about-value new-constraint)))
    (define (me request)
      (cond ((eq? request 'has-value?) (if informant true false))
            ((eq? request 'get-value) value)
            ((eq? request 'set-value!) set-my-value!)
            ((eq? request 'forget!) forget-my-value!)
            ((eq? request 'connect) connect!)
            (else (error "Unknown operation: CONNECTOR" request))))
    me))
(define (has-value? connector) (connector 'has-value?))
(define (get-value connector) (connector 'get-value))
(define (set-value! connector newval informant)
  ((connector 'set-value!) newval informant))
(define (forget-value! connector refractor) ((connector 'forget!) refractor))
(define (connect connector new-constraint) ((connector 'connect) new-constraint))

(define (adder a1 a2 sum)
  (define (process-new-value)
    (let ((a1? (has-value? a1))
          (a2? (has-value? a2))
          (sum? (has-value? sum)))
      (cond ((and a1? a2?)
             (set-value! sum (+ (get-value a1) (get-value a2)) me))
            ((and a1? sum?)
             (set-value! a2 (- (get-value sum) (get-value a1)) me))
            ((and a2? sum?)
             (set-value! a1 (- (get-value sum) (get-value a2)) me)))))
  (define (process-forget-value)
    (forget-value! sum me)
    (forget-value! a1 me)
    (forget-value! a2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-lost-my-value) (process-forget-value))
          (else (error "Unknown request: ADDER" request))))
  (connect a1 me)
  (connect a2 me)
  (connect sum me)
  me)
(define (multiplier m1 m2 product)
  (define (process-new-value)
    (let ((m1? (has-value? m1))
          (m2? (has-value? m2))
          (product? (has-value? product)))
      (cond ((or (and m1? (= (get-value m1) 0))
                 (and m2? (= (get-value m2) 0)))
             (set-value! product 0 me))
            ((and m1? m2?)
             (set-value! product (* (get-value m1) (get-value m2)) me))
            ((and m1? product?)
             (set-value! m2 (/ (get-value product) (get-value m1)) me))
            ((and m2? product?)
             (set-value! m1 (/ (get-value product) (get-value m2)) me)))))
  (define (process-forget-value)
    (forget-value! product me)
    (forget-value! m1 me)
    (forget-value! m2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-lost-my-value) (process-forget-value))
          (else (error "Unknown request: MULTIPLIER" request))))
  (connect m1 me)
  (connect m2 me)
  (connect product me)
  me)
(define (constant value connector)
  (define (me request)
    (error "Unknown request: CONSTANT" request))
  (connect connector me)
  (set-value! connector value me)
  me)
(define (probe name connector)
  (define (print-probe value)
    (display "Probe: ")
    (display name)
    (display " = ")
    (display value)
    (newline))
  (define (process-new-value) (print-probe (get-value connector)))
  (define (process-forget-value) (print-probe "?"))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-lost-my-value) (process-forget-value))
          (else (error "Unknown request: PROBE" request))))
  (connect connector me)
  me)

(define (celsius-fahrenheit-converter c f)
  (let ((u (make-connector))
        (v (make-connector))
        (w (make-connector))
        (x (make-connector))
        (y (make-connector)))
    (constant 9 w)
    (multiplier c w u)
    (constant 32 y)
    (adder v y f) ; i.e. v + y = f or v = f - y = f - 32
    (constant 5 x)
    (multiplier v x u))
  'ok)

; Exercise 3.33
(define (averager a b c)
  (let ((two (make-connector))
        (sum (make-connector)))
    (constant 2 two)
    (multiplier c two sum)
    (adder a b sum))
  'ok)

; Exercise 3.34
(define (square x) (* x x))
(define (squarer a b)
  (define (process-new-value)
    (if (has-value? b)
        (let ((bval (get-value b)))
          (if (< bval 0)
              (error "square less than 0: SQUARER" bval)
              (set-value! a (sqrt bval) me)))
        (if (has-value? a)
            (set-value! b (square (get-value a)) me))))
  (define (process-forget-value)
    (forget-value! a me)
    (forget-value! b me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-lost-my-value) (process-forget-value))
          (else (error "Unknown request: SQUARER" request))))
  (connect a me)
  (connect b me)
  me)

; Exercise 3.37
(define (c+ x y)
  (let ((z (make-connector)))
    (adder x y z)
    z))
(define (c- x y)
  (let ((z (make-connector)))
    (adder y z x)
    z))
(define (c* x y)
  (let ((z (make-connector)))
    (multiplier x y z)
    z))
(define (c/ x y)
  (let ((z (make-connector)))
    (multiplier y z x)
    z))
(define (cv val)
  (let ((z (make-connector)))
    (constant val z)
    z))
(define (c2f x) (c+ (c* (c/ (cv 9) (cv 5)) x) (cv 32)))

(define parallel-execute for-each) ; so that test can be run
(define (test-and-set! cell)
  (if (car cell)
      true
      (begin (set-car! cell true) false)))
(define (make-mutex)
  (let ((cell (list false)))
    (define (the-mutex m)
      (cond ((eq? m 'acquire) (if (test-and-set! cell)
                                  (the-mutex 'acquire)))
            ((eq? m 'release) (set-car! cell false))))
    the-mutex))
(define (make-serializer)
  (let ((mutex (make-mutex)))
    (lambda (p)
      (lambda args
        (mutex 'acquire)
        (let ((val (apply p args)))
          (mutex 'release)
          val)))))

; Exercise 3.47
(define (make-semaphore n)
  (define (test-n-set! cell)
    (if (> (car cell) 0)
        true
        (begin (set-car! cell (dec (car cell)))
               false)))
  (let ((cell (list n)))
    (define (the-semaphore m)
      (cond ((eq? m 'acquire) (if (test-n-set! cell)
                                  (the-semaphore 'acquire)))
            ((eq? m 'release) (set-car! cell n))))
    the-semaphore))

; Exercise 3.48
(define (make-account-maker)
  (let ((next-id 0))
    (lambda (balance)
      (define (withdraw amount)
        (if (>= balance amount)
            (begin (set! balance (- balance amount))
                   balance)
            "Insufficient funds"))
      (define (deposit amount)
        (set! balance (+ balance amount))
        balance)
      (let ((serializer (make-serializer))
            (id next-id))
        (define (dispatch request)
          (cond ((eq? request 'withdraw) withdraw)
                ((eq? request 'deposit) deposit)
                ((eq? request 'balance) balance)
                ((eq? request 'serializer) serializer)
                ((eq? request 'id) id)
                (else (error "Unknown request: MAKE-ACCOUNT" request))))
        (set! next-id (inc id))
        dispatch))))
(define (serialized-exchange older newer)
  (define (exchange acc0 acc1)
    (let ((diff (- (acc0 'balance) (acc1 'balance))))
      ((acc0 'withdraw) diff)
      ((acc1 'deposit) diff)))
  (let ((old (older 'id))
        (new (newer 'id)))
    (cond ((< old new)
           (let ((old-serializer (older 'serializer))
                 (new-serializer (newer 'serializer)))
             ((new-serializer (old-serializer exchange)) older newer)))
          ((> old new) (serialized-exchange newer older)))))

(define stream-car car)
(define (stream-cdr stream) (force (cdr stream)))
(define (stream-ref s n)
  (if (= n 0)
      (stream-car s)
      (stream-ref (stream-cdr s) (dec n))))
(define (stream-map proc s)
  (if (stream-null? s)
      the-empty-stream
      (cons-stream (proc (stream-car s))
                   (stream-map proc (stream-cdr s)))))
(define (stream-for-each proc s)
  (if (not (stream-null? s))
      (begin (proc (stream-car s))
             (stream-for-each proc (stream-cdr s)))))
(define (stream-range . args)
  (define (iter start stop step)
    (if (< start stop)
        (cons-stream start (iter (+ start step) stop step))
        the-empty-stream))
  (let ((n (length args)))
    (cond ((= n 1) (iter 0 (car args) 1))
          ((= n 2) (iter (car args) (cadr args) 1))
          ((= n 3) (apply iter args))
          (else the-empty-stream))))
(define (stream-filter pred stream)
  (cond ((stream-null? stream) the-empty-stream)
        ((pred (stream-car stream))
         (cons-stream (stream-car stream)
                      (stream-filter pred (stream-cdr stream))))
        (else (stream-filter pred (stream-cdr stream)))))

; Exercise 3.50
(define (filter pred lst)
  (cond ((null? lst) '())
        ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
        (else (filter pred (cdr lst)))))
(define (not-empty streams)
  (filter (lambda (s) (not (stream-null? s))) streams))
(define (stream-multimap proc . streams)
  (if (null? streams)
      the-empty-stream
      (cons-stream
       (apply proc (map stream-car streams))
       (apply stream-multimap
              (cons proc (not-empty (map stream-cdr streams)))))))

(define (integers-starting-from n)
  (cons-stream n (integers-starting-from (inc n))))
(define (sieve stream)
  (let ((first (stream-car stream)))
    (cons-stream
     first
     (sieve (stream-filter (lambda (x) (not (= (remainder x first) 0)))
                           (stream-cdr stream))))))
(define primes (sieve (integers-starting-from 2)))
(define ones (cons-stream 1 ones))
(define (add-streams s1 s2) (stream-multimap + s1 s2))
(define positive-integers (cons-stream 1 (add-streams ones positive-integers)))
(define fibs
  (cons-stream 0 (cons-stream 1 (add-streams (stream-cdr fibs) fibs))))
(define (scale-stream stream factor)
  (stream-map (lambda (x) (* x factor)) stream))

; For debugging purposes
(define (list->stream lst)
  (if (null? lst)
      the-empty-stream
      (cons-stream (car lst) (list->stream (cdr lst)))))
(define (print-1st-elements n stream)
  (if (or (< n 1) (stream-null? stream))
      (newline)
      (begin (display (stream-car stream))
             (display " ")
             (print-1st-elements (dec n) (stream-cdr stream)))))

; Exercise 3.54
(define (mul-streams s1 s2) (stream-multimap * s1 s2))
(define factorials
  (cons-stream 1 (mul-streams (integers-starting-from 2) factorials)))

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

; Exercise 3.56
(define (merge s1 s2)
  (cond ((stream-null? s1) s2)
        ((stream-null? s2) s1)
        (else (let ((a1 (stream-car s1))
                    (a2 (stream-car s2)))
                (cond ((< a1 a2) (cons-stream a1 (merge (stream-cdr s1) s2)))
                      ((> a1 a2) (cons-stream a2 (merge s1 (stream-cdr s2))))
                      (else (cons-stream a1 (merge (stream-cdr s1)
                                                   (stream-cdr s2)))))))))
(define hamming-sequence
  (cons-stream 1 (merge (merge (scale-stream hamming-sequence 2)
                               (scale-stream hamming-sequence 3))
                        (scale-stream hamming-sequence 5))))

; Exercise 3.58: rational number num/den in base radix
(define (expand num den radix)
  (let ((product (* num radix)))
    (cons-stream (quotient product den)
                 (expand (remainder product den) den radix))))

; Exercise 3.59
(define (integrate-series coef-stream)
  (stream-multimap / coef-stream positive-integers))
(define exp-series (cons-stream 1 (integrate-series exp-series)))
(define cosine-series
  (cons-stream 1 (scale-stream (integrate-series sine-series) -1)))
(define sine-series (cons-stream 0 (integrate-series cosine-series)))

; Exercise 3.60
(define (mul-series s1 s2)
  (if (stream-null? s2)
      the-empty-stream
      (add-streams (cons-stream 0 (mul-series s1 (stream-cdr s2)))
                   (scale-stream s1 (car s2)))))

; Exercise 3.61 modified: compute 1/S
(define (invert-series s)
  (let ((c (stream-car s)))
    (define x (cons-stream (/ 1 c)
                           (mul-series (scale-stream (stream-cdr s) (/ -1 c)) x)))
    x))

; Exercise 3.62
(define (div-series s1 s2)
  (cond ((stream-null? (stream-cdr s2)) (scale-stream s1 (/ 1 (stream-car s2))))
        ((and (= (stream-car s1) 0) (= (stream-car s2) 0))
         (div-series (stream-cdr s1) (stream-cdr s2)))
        (else (mul-series s1 (invert-series s2)))))

(define (pi-summands n)
  (cons-stream (/ 1.0 n) (stream-map - (pi-summands (+ n 2)))))
(define pi-stream
  (scale-stream (partial-sums (pi-summands 1)) 4))
(define (euler-transform s)
  (let ((s0 (stream-car s))
        (s1 (stream-ref s 1))
        (s2 (stream-ref s 2)))
    (cons-stream (/ (- (* s0 s2) (square s1)) (+ s0 (* -2 s1) s2))
                 (euler-transform (stream-cdr s)))))
(define (make-tableau transform s)
  (cons-stream s (make-tableau transform (transform s))))
(define (accelerated-sequence transform s)
  (stream-map stream-car (make-tableau transform s)))

; Exercise 3.64
(define (average x y) (/ (+ x y) 2))
(define (sqrt-stream x)
  (define (sqrt-improve guess) (average guess (/ x guess)))
  (define guesses (cons-stream 1.0 (stream-map sqrt-improve guesses)))
  guesses)
(define (stream-limit stream tolerance)
  (let* ((d (stream-cdr stream))
         (ad (stream-car d)))
    (if (< (abs (- (stream-car stream) ad)) tolerance)
        ad
        (stream-limit d tolerance))))
(define (sqrt-acc x tolerance)
  (stream-limit (sqrt-stream x) tolerance))

; Exercise 3.65
(define (ln2-summands n)
  (cons-stream (/ 1.0 n) (stream-map - (ln2-summands (inc n)))))
(define ln2-stream (partial-sums (ln2-summands 1)))

; Exercise 3.67
(define (pairs s t)
  (let ((as (stream-car s))
        (dt (stream-cdr t)))
    (cons-stream (cons as (stream-car t))
                 (interleave (stream-map (lambda (x) (cons as x)) dt)
                             (pairs (stream-cdr s) dt)))))
(define (all-pairs stream)
  (let ((a (stream-car stream)))
    (let ((new-pairs (cons-stream a (all-pairs (stream-cdr stream))))
          (aa (car a))
          (da (cdr a)))
      (if (= aa da)
          new-pairs
          (cons-stream (cons da aa) new-pairs)))))

; Exercise 3.69 extended: pick any number of streams
(define (interleave . streams)
  (if (null? streams)
      the-empty-stream
      (let ((a (car streams))
            (d (cdr streams)))
        (cons-stream
         (stream-car a)
         (apply interleave (not-empty (append d (list (stream-cdr a)))))))))
(define (pick weigh . streams) ; modified for exercise 3.70
  (define (merge-weighted weigh streams)
    (define (min-weight streams)
      (let ((a (car streams))
            (d (cdr streams)))
        (if (null? d)
            (list a)
            (let ((next (min-weight d)))
              (if (< (weigh (stream-car a)) (weigh (stream-car (car next))))
                  (cons a next)
                  (cons (car next) (cons a (cdr next))))))))
    (if (null? streams)
        the-empty-stream
        (let ((m (min-weight (not-empty streams))))
          (cons-stream (stream-car (car m))
                       (merge-weighted
                        weigh
                        (if (null? (stream-cdr (car m)))
                            (cdr m)
                            (cons (stream-cdr (car m))
                                  (cdr m))))))))
  (define (heads lst)
    (if (null? lst)
        '()
        (cons '()
              (map (lambda (l) (cons (car lst) l))
                   (heads (cdr lst))))))
  (define (iter cars cdrs)
    (if (null? cdrs)
        '()
        (cons (stream-map (lambda (l) (append (car cars) l))
                          (apply pick (cons weigh cdrs)))
              (iter (cdr cars) (cdr cdrs)))))
  (if (null? streams)
      the-empty-stream
      (let ((cars (map stream-car streams))
            (cdrs (map stream-cdr streams)))
        (cons-stream cars (merge-weighted weigh (iter (heads cars) cdrs))))))
(define (sum lst) (apply + lst))
(define pythagorean-triples
  (stream-filter
   (lambda (l) (apply (lambda (i j k) (= (+ (* i i) (* j j)) (* k k))) l))
   (pick sum positive-integers positive-integers positive-integers)))

; Exercise 3.70
(define sorted-by-sum (pick sum positive-integers positive-integers))
(define (stream-append s1 s2)
  (if (stream-null? s1)
      s2
      (cons-stream (stream-car s1) (stream-append (stream-cdr s1) s2))))
(define bacon-seq ; i.e. neither Ham(ming) nor sausages
  (stream-append (list->stream (list 1 7 11 13 17 19 23))
                 (cons-stream 29 (stream-map (lambda (x) (+ x 30)) bacon-seq))))
(define bacons
  (pick (lambda (l) (if (null? (cdr l))
                        (car l)
                        (apply (lambda (i j) (+ i i j j j (* 5 i j))) l)))
        bacon-seq bacon-seq))

; Exercise 3.71
(define (cube-sum lst) (sum (map (lambda (x) (* x x x)) lst)))
(define (inf-sorted-duplicates stream inits)
  (let ((a (stream-car stream))
        (d (stream-cdr stream)))
    (if (apply = (cons a inits))
        (cons-stream a (inf-sorted-duplicates d (append (cdr inits) (list a))))
        (inf-sorted-duplicates d (append (cdr inits) (list a))))))
(define ramanujan
  (inf-sorted-duplicates
   (stream-map cube-sum (pick cube-sum positive-integers positive-integers))
   (list 0)))

; Exercise 3.72
(define (square-sum lst) (sum (map square lst)))
(define three-sums
  (inf-sorted-duplicates
   (stream-map square-sum (pick square-sum positive-integers positive-integers))
   (list 0 0)))

; Exercise 3.73
(define (integral integrand initial-value dt)
  (define int (cons-stream initial-value
                           (add-streams (scale-stream integrand dt) int)))
  int)
(define (RC R C dt)
  (lambda (currents init-voltage)
    (add-streams (integral (scale-stream currents (/ 1 C)) init-voltage dt)
                 (scale-stream currents R))))

; Exercise 3.74
(define (sign-change-detector n p)
  (cond ((and (< p 0) (not (< n 0))) 1)
        ((and (not (< p 0)) (< n 0)) -1)
        (else 0)))
;(define zero-crossings
;  (stream-multimap sign-change-detector
;                   (stream-cdr sense-data)
;                   sense-data))

; Exercise 3.76
(define (smooth stream) (stream-multimap average stream (stream-cdr stream)))
(define (make-zero-crossings input-stream last-value)
  (cons-stream (sign-change-detector (stream-car input-stream)
                                     last-value)
               (make-zero-crossings (stream-cdr input-stream)
                                    (stream-car input-stream))))

; Exercise 3.81
(define (rand-stream requests init updater)
  (let ((a (stream-car requests)))
    (let ((updated (cond ((eq? (car a) 'generate) (updater init))
                         ((eq? (car a) 'reset) (cdr a))
                         (else (error "Unknown request: RAND-STREAM"
                                      (car a))))))
      (cons-stream updated (rand-stream (stream-cdr requests)
                                        updated updater)))))

; Exercise 3.82
(define (monte-carlo-stream experiment)
  (define (try) (cons-stream (if (experiment) 1 0) (try)))
  (stream-multimap / (partial-sums (try)) positive-integers))
(define (estimate-integral-stream P x1 x2 y1 y2)
  (monte-carlo-stream (lambda () (P (random-in-range x1 x2)
                                    (random-in-range y1 y2)))))