home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / ABE&SUS3.ZIP / A&S_3.LSP
Encoding:
Text File  |  1987-04-06  |  33.6 KB  |  1,255 lines
  1.  
  2. ;;; Section 3.1.1
  3.  
  4. (define balance 100)
  5.  
  6. (define (withdraw amount)
  7.   (if (>= balance amount)
  8.       (sequence (set! balance (- balance amount))
  9.                 balance)
  10.       "Insufficient funds"))
  11.  
  12. (define new-withdraw
  13.   (let ((balance 100))
  14.     (lambda (amount)
  15.       (if (>= balance amount)
  16.           (sequence (set! balance (- balance amount))
  17.                     balance)
  18.           "Insufficient funds"))))
  19.  
  20. (define (make-withdraw balance)
  21.   (lambda (amount)
  22.     (if (>= balance amount)
  23.         (sequence (set! balance (- balance amount))
  24.                   balance)
  25.         "Insufficient funds")))
  26.  
  27. (define (make-account balance)
  28.   (define (withdraw amount)
  29.     (if (>= balance amount)
  30.         (sequence (set! balance (- balance amount))
  31.                   balance)
  32.         "Insufficient funds"))
  33.   (define (deposit amount)
  34.     (set! balance (+ balance amount))
  35.     balance)
  36.   (define (dispatch m)
  37.     (cond ((eq? m 'withdraw) withdraw)
  38.           ((eq? m 'deposit) deposit)
  39.           (else (error "Unknown request -- MAKE-ACCOUNT"
  40.                        m))))
  41.   dispatch)
  42.  
  43. ;;; Section 3.1.2
  44.  
  45. (define (make-simplified-withdraw balance)
  46.     (lambda (amount)
  47.       (set! balance (- balance amount))
  48.       balance))
  49.  
  50. (define (make-decrementer balance)
  51.   (lambda (amount)
  52.     (- balance amount)))
  53.  
  54. ;;; Section 3.1.3
  55.  
  56. ;;; NB. We do not provide a definition of RAND-UPDATE
  57.  
  58. (define rand
  59.   (let ((x random-init))
  60.     (lambda ()
  61.       (set! x (rand-update x))
  62.       x)))
  63.  
  64. (define (estimate-pi trials)
  65.   (sqrt (/ 6 (monte-carlo trials cesaro-test))))
  66.  
  67. (define (cesaro-test)
  68.    (= (gcd (rand) (rand)) 1))
  69.  
  70. (define (monte-carlo trials experiment)
  71.   (define (iter trials-remaining trials-passed)
  72.     (cond ((= trials-remaining 0)
  73.            (/ trials-passed trials))
  74.           ((experiment)
  75.            (iter (-1+ trials-remaining) (1+ trials-passed)))
  76.           (else
  77.            (iter (-1+ trials-remaining) trials-passed))))
  78.   (iter trials 0))
  79.  
  80. (define (estimate-pi trials)
  81.   (sqrt (/ 6 (random-gcd-test trials random-init))))
  82.  
  83. (define (random-gcd-test trials initial-x)
  84.   (define (iter trials-remaining trials-passed x)
  85.     (let ((x1 (rand-update x)))
  86.       (let ((x2 (rand-update x1)))
  87.         (cond ((= trials-remaining 0)   
  88.                (/ trials-passed trials))
  89.               ((= (gcd x1 x2) 1)
  90.                (iter (-1+ trials-remaining)
  91.                      (1+ trials-passed)
  92.                      x2))
  93.               (else
  94.                (iter (-1+ trials-remaining)
  95.                      trials-passed
  96.                      x2))))))
  97.   (iter trials 0 initial-x))
  98.  
  99. ;;; Exercise 3.7
  100.  
  101. (define (real-random low high)
  102.   (let ((range (- high low)))
  103.     (+ low
  104.        (/ (random (round (* 10000 range)))
  105.           10000))))
  106.  
  107.  
  108. ;;; Exercise 3.10 -- a variant of the earlier make-withdraw
  109.  
  110. (define (make-withdraw initial-amount)
  111.   (let ((balance initial-amount))
  112.     (lambda (amount)
  113.       (if (>= balance amount)
  114.           (sequence (set! balance (- balance amount))
  115.                     balance)
  116.           "Insufficient funds"))))
  117.  
  118. ;;; Section 3.3.1
  119.  
  120. (define (cons x y)
  121.   (let ((new (get-new-pair)))
  122.     (set-car! new x)
  123.     (set-cdr! new y)
  124.     new))
  125.  
  126. ;;; Exercise 3.12
  127. (define (append x y)
  128.   (if (null? x)
  129.       y
  130.       (cons (car x) (append (cdr x) y))))
  131.  
  132. (define (append! x y)
  133.   (set-cdr! (last x) y)
  134.   x)
  135.  
  136. (define (last x)
  137.   (if (null? (cdr x))
  138.       x
  139.       (last (cdr x))))
  140.  
  141. ;;; Exercise 3.13
  142.  
  143. (define (make-cycle x)
  144.   (set-cdr! (last x) x)
  145.   x)
  146.  
  147. ;;; Exercise 3.14
  148.  
  149. (define (mystery x)
  150.   (define (loop x y)
  151.     (if (null? x)
  152.         y
  153.         (let ((temp (cdr x)))
  154.           (set-cdr! x y)
  155.           (loop temp x))))
  156.   (loop x '()))
  157.  
  158. ;;; Exercise 3.16
  159.  
  160. (define (count-pairs x)
  161.   (if (atom? x)
  162.       0
  163.       (+ (count-pairs (car x))
  164.          (count-pairs (cdr x))
  165.          1)))
  166.  
  167. ;;; Implementation of pairs as procedures
  168.  
  169. (define (cons x y)
  170.   (define (set-x! v) (set! x v))
  171.   (define (set-y! v) (set! y v))
  172.   (define (dispatch m)
  173.     (cond ((eq? m 'car) x)
  174.           ((eq? m 'cdr) y)
  175.           ((eq? m 'set-car!) set-x!)
  176.           ((eq? m 'set-cdr!) set-y!)
  177.           (else (error "Undefined operation -- CONS" m))))
  178.   dispatch)
  179.  
  180. (define (car z) (z 'car))
  181.  
  182. (define (cdr z) (z 'cdr))
  183.  
  184. (define (set-car! z new-value)
  185.   ((z 'set-car!) new-value)
  186.   z)
  187.  
  188. (define (set-cdr! z new-value)
  189.   ((z 'set-cdr!) new-value)
  190.   z)
  191.  
  192. ;;; Section 3.3.2 -- Queues
  193.  
  194. ;;; Representaton of queues
  195.  
  196. (define (front-ptr queue) (car queue))
  197.  
  198. (define (rear-ptr queue) (cdr queue))
  199.  
  200. (define (set-front-ptr! queue item) (set-car! queue item))
  201.  
  202. (define (set-rear-ptr! queue item) (set-cdr! queue item))
  203.  
  204. ;;; Operations on queues
  205.  
  206. (define (empty-queue? queue) (null? (front-ptr queue)))
  207.  
  208. (define (make-queue) (cons '() '()))
  209.  
  210. (define (front queue)
  211.   (if (empty-queue? queue)
  212.       (error "FRONT called with an empty queue" queue)
  213.       (car (front-ptr queue))))
  214.  
  215. (define (insert-queue! queue item)
  216.   (let ((new-pair (cons item nil)))
  217.     (cond ((empty-queue? queue)
  218.            (set-front-ptr! queue new-pair)
  219.            (set-rear-ptr! queue new-pair)
  220.            queue)
  221.           (else
  222.            (set-cdr! (rear-ptr queue) new-pair)
  223.            (set-rear-ptr! queue new-pair)
  224.            queue)))) 
  225.  
  226. (define (delete-queue! queue)
  227.   (cond ((empty-queue? queue)
  228.          (error "Delete called with an empty queue" queue))
  229.         (else
  230.          (set-front-ptr! queue (cdr (front-ptr queue)))
  231.          queue))) 
  232.  
  233. ;;; Section 3.3.3 -- Tables
  234.  
  235. ;;; One-dimensional tables
  236.  
  237. (define (lookup key table)
  238.   (let ((record (assq key (cdr table))))
  239.     (if (null? record)
  240.         nil
  241.         (cdr record))))
  242.  
  243. (define (assq key records)
  244.   (cond ((null? records) nil)
  245.         ((eq? key (caar records)) (car records))
  246.         (else (assq key (cdr records)))))
  247.  
  248. (define (insert! key value table)
  249.   (let ((record (assq key (cdr table))))
  250.     (if (null? record)
  251.         (set-cdr! table
  252.                   (cons (cons key value) (cdr table)))
  253.         (set-cdr! record value)))
  254.   'ok)
  255.  
  256. (define (make-table)
  257.   (list '*table*))
  258.  
  259. ;;; Two-dimensional tables
  260.  
  261. (define (lookup key-1 key-2 table)
  262.   (let ((subtable (assq key-1 (cdr table))))
  263.     (if (null? subtable)
  264.         nil
  265.         (let ((record (assq key-2 (cdr subtable))))
  266.           (if (null? record)
  267.               nil
  268.               (cdr record))))))
  269.  
  270. (define (insert! key-1 key-2 value table)
  271.   (let ((subtable (assq key-1 (cdr table))))
  272.     (if (null? subtable)
  273.         (set-cdr! table
  274.                   (cons (list key-1
  275.                               (cons key-2 value))
  276.                         (cdr table)))
  277.         (let ((record (assq key-2 (cdr subtable))))
  278.           (if (null? record)
  279.               (set-cdr! subtable
  280.                         (cons (cons key-2 value)
  281.                               (cdr subtable)))
  282.               (set-cdr! record value)))))
  283.   'ok)
  284.  
  285. ;;; Local tables
  286.  
  287. (define (make-table)
  288.   (let ((local-table (list '*table*)))
  289.     (define (lookup key-1 key-2)
  290.       (let ((subtable (assq key-1 (cdr local-table))))
  291.         (if (null? subtable)
  292.             nil
  293.             (let ((record (assq key-2 (cdr subtable))))
  294.               (if (null? record)
  295.                   nil
  296.                   (cdr record))))))
  297.  
  298.     (define (insert! key-1 key-2 value)
  299.       (let ((subtable (assq key-1 (cdr local-table))))
  300.         (if (null? subtable)
  301.             (set-cdr! local-table
  302.                       (cons (list key-1
  303.                                   (cons key-2 value))
  304.                             (cdr local-table)))
  305.             (let ((record (assq key-2 (cdr subtable))))
  306.               (if (null? record)
  307.                   (set-cdr! subtable
  308.                             (cons (cons key-2 value)
  309.                                   (cdr subtable)))
  310.                   (set-cdr! record value)))))
  311.        `ok)    
  312.     (define (dispatch m)
  313.       (cond ((eq? m 'lookup-proc) lookup)
  314.             ((eq? m 'insert-proc!) insert!)
  315.             (else (error "Unknown operation -- TABLE" m))))
  316.  
  317.     dispatch))
  318.  
  319. ;;; The PUT and GET operations used in chapter 2
  320.  
  321. (define operation-table (make-table))
  322. (define get (operation-table 'lookup-proc))
  323. (define put (operation-table 'insert-proc!))
  324.  
  325. ;;; Exercise 3.27
  326.  
  327. (define (fib n)
  328.   (cond ((= n 0) 0)
  329.         ((= n 1) 1)
  330.         (else (+ (fib (- n 1))
  331.                  (fib (- n 2))))))
  332.  
  333. (define memo-fib
  334.   (memoize (lambda (n)
  335.              (cond ((= n 0) 0)
  336.                    ((= n 1) 1)
  337.                    (else (+ (memo-fib (- n 1))
  338.                             (memo-fib (- n 2))))))))
  339.  
  340. (define (memoize f)
  341.   (let ((table (make-table)))
  342.     (lambda (x)
  343.       (let ((previously-computed-result (lookup x table)))
  344.         (if (not (null? previously-computed-result))
  345.             previously-computed-result
  346.             (let ((result (f x)))
  347.               (insert! x result table)
  348.               result))))))
  349.  
  350. ;;; Section 3.3.4 -- Digial-circuit simulator
  351.  
  352. (define (half-adder a b s c)
  353.   (let ((d (make-wire)) (e (make-wire)))
  354.     (or-gate a b d)
  355.     (and-gate a b c)
  356.     (inverter c e)
  357.     (and-gate d e s)))
  358.  
  359. (define (full-adder a b c-in sum c-out)
  360.   (let ((s (make-wire))
  361.         (c1 (make-wire))
  362.         (c2 (make-wire)))
  363.     (half-adder b c-in s c1)
  364.     (half-adder a s sum c2)
  365.     (or-gate c1 c2 c-out)))
  366.  
  367. ;;; Primitive function boxes
  368.  
  369. (define (inverter input output)
  370.   (define (invert-input)
  371.     (let ((new-value (logical-not (get-signal input))))
  372.       (after-delay inverter-delay
  373.                    (lambda ()
  374.                      (set-signal! output
  375.                                   new-value)))))
  376.   (add-action! input invert-input))
  377.  
  378. (define (logical-not s)
  379.   (cond ((= s 0) 1)
  380.         ((= s 1) 0)
  381.         (else (error "Invalid signal" s))))
  382.  
  383. (define (and-gate a1 a2 output)
  384.   (define (and-action-procedure)
  385.     (let ((new-value
  386.            (logical-and (get-signal a1) (get-signal a2))))
  387.       (after-delay and-gate-delay
  388.                    (lambda ()
  389.                      (set-signal! output new-value)))))
  390.   (add-action! a1 and-action-procedure)
  391.   (add-action! a2 and-action-procedure))
  392.  
  393. ;;; Wires
  394.  
  395. (define (make-wire)
  396.   (let ((signal-value 0) (action-procedures '()))
  397.     (define (set-my-signal! new-value)
  398.       (if (not (= signal-value new-value))
  399.           (sequence (set! signal-value new-value)
  400.                     (call-each action-procedures))
  401.           'done))
  402.  
  403.     (define (accept-action-procedure proc)
  404.       (set! action-procedures (cons proc action-procedures))
  405.       (proc))
  406.  
  407.     (define (dispatch m)
  408.       (cond ((eq? m 'get-signal) signal-value)
  409.             ((eq? m 'set-signal!) set-my-signal!)
  410.             ((eq? m 'add-action!) accept-action-procedure)
  411.             (else (error "Unknown operation -- WIRE" m))))
  412.  
  413.     dispatch))
  414.  
  415. (define (call-each procedures)
  416.   (if (null? procedures)
  417.       'done
  418.       (sequence
  419.        ((car procedures))
  420.        (call-each (cdr procedures)))))
  421.  
  422. (define (get-signal wire)
  423.   (wire 'get-signal))
  424.  
  425. (define (set-signal! wire new-value)
  426.   ((wire 'set-signal!) new-value))
  427.  
  428. (define (add-action! wire action-procedure)
  429.   ((wire 'add-action!) action-procedure))
  430.  
  431. ;;; Agenda use
  432.  
  433. (define (after-delay delay action)
  434.   (add-to-agenda! (+ delay (current-time the-agenda))
  435.                   action
  436.                   the-agenda))
  437.  
  438. ;;; Top level of simulation
  439.  
  440. (define (propagate)
  441.   (if (empty-agenda? the-agenda)
  442.       'done
  443.       (let ((first-item (first-agenda-item the-agenda)))
  444.         (first-item)
  445.         (remove-first-agenda-item! the-agenda)
  446.         (propagate))))
  447.  
  448. ;;; Probing a wire
  449.  
  450. (define (probe name wire)
  451.   (add-action! wire
  452.               (lambda ()        
  453.                 (print name)
  454.                 (princ (current-time the-agenda))
  455.                 (princ "  New-value = ")
  456.                 (princ (get-signal wire)))))
  457.  
  458. ;;; Implementation of the agenda
  459.  
  460. (define (make-time-segment time queue)
  461.   (cons time queue))
  462.  
  463. (define (segment-time s) (car s))
  464.  
  465. (define (segment-queue s) (cdr s))
  466.  
  467. (define (make-agenda)
  468.   (list '*agenda*
  469.         (make-time-segment 0 (make-queue))))
  470.  
  471. (define (segments agenda) (cdr agenda))
  472.  
  473. (define (first-segment agenda) (car (segments agenda)))
  474.  
  475. (define (rest-segments agenda) (cdr (segments agenda)))
  476.  
  477. (define (set-segments! agenda segments)
  478.   (set-cdr! agenda segments))
  479.  
  480. (define (current-time agenda)
  481.   (segment-time (first-segment agenda)))
  482.  
  483. (define (empty-agenda? agenda)
  484.   (and (empty-queue? (segment-queue (first-segment agenda)))
  485.        (null? (rest-segments agenda))))
  486.  
  487. (define (add-to-agenda! time action agenda)
  488.   (define (add-to-segments! segments)
  489.     (if (= (segment-time (car segments)) time)
  490.         (insert-queue! (segment-queue (car segments))
  491.                        action)
  492.         (let ((rest (cdr segments)))
  493.           (cond ((null? rest)
  494.                  (insert-new-time! time action segments))
  495.                 ((> (segment-time (car rest)) time)
  496.                  (insert-new-time! time action segments))
  497.                 (else (add-to-segments! rest))))))
  498.   (add-to-segments! (segments agenda)))
  499.  
  500. (define (insert-new-time! time action segments)
  501.   (let ((q (make-queue)))
  502.     (insert-queue! q action)
  503.     (set-cdr! segments
  504.               (cons (make-time-segment time q)
  505.                     (cdr segments)))))
  506.  
  507. (define (remove-first-agenda-item! agenda)
  508.   (delete-queue! (segment-queue (first-segment agenda))))
  509.  
  510. (define (first-agenda-item agenda)
  511.   (let ((q (segment-queue (first-segment agenda))))
  512.     (if (empty-queue? q)
  513.         (sequence (set-segments! agenda
  514.                                  (rest-segments agenda))
  515.                   (first-agenda-item agenda))
  516.         (front q))))
  517.  
  518. ;;; Section 3.3.5 -- Propagation of constraints
  519.  
  520. (define (centigrade-fahrenheit-converter c f)
  521.   (let ((u (make-connector))
  522.         (v (make-connector))
  523.         (w (make-connector))
  524.         (x (make-connector))
  525.         (y (make-connector)))
  526.     (multiplier c w u)
  527.     (multiplier v x u)
  528.     (adder v y f)
  529.     (constant 9 w)
  530.     (constant 5 x)
  531.     (constant 32 y)))
  532.  
  533. ;;; Primitive constraints
  534.  
  535. (define (adder a1 a2 sum)
  536.   (define (process-new-value)
  537.     (cond ((and (has-value? a1) (has-value? a2))
  538.            (set-value! sum
  539.                        (+ (get-value a1) (get-value a2))
  540.                        me))
  541.           ((and (has-value? a1) (has-value? sum))
  542.            (set-value! a2
  543.                        (- (get-value sum) (get-value a1))
  544.                        me))
  545.           ((and (has-value? a2) (has-value? sum))
  546.            (set-value! a1
  547.                        (- (get-value sum) (get-value a2))
  548.                        me))))
  549.  
  550.   (define (process-forget-value)
  551.     (forget-value! sum me)
  552.     (forget-value! a1 me)
  553.     (forget-value! a2 me)
  554.     (process-new-value))
  555.  
  556.   (define (me request)
  557.     (cond ((eq? request 'I-have-a-value)  
  558.            process-new-value)
  559.           ((eq? request 'I-lost-my-value) 
  560.            process-forget-value)
  561.           (else 
  562.            (error "Unknown request -- ADDER" request))))
  563.  
  564.   (connect a1 me)
  565.   (connect a2 me)
  566.   (connect sum me)
  567.   me)
  568.  
  569. (define (inform-about-value constraint)
  570.   ((constraint 'I-have-a-value)))
  571.  
  572. (define (inform-about-no-value constraint)
  573.   ((constraint 'I-lost-my-value)))
  574.  
  575. (define (multiplier m1 m2 product)
  576.   (define (process-new-value)
  577.     (cond ((or (if (has-value? m1) (= (get-value m1) 0) nil)
  578.                (if (has-value? m2) (= (get-value m2) 0) nil))
  579.            (set-value! product 0 me))
  580.           ((and (has-value? m1) (has-value? m2))
  581.            (set-value! product
  582.                        (* (get-value m1) (get-value m2))
  583.                        me))
  584.           ((and (has-value? product) (has-value? m1))
  585.            (set-value! m2
  586.                        (/ (get-value product) (get-value m1))
  587.                        me))
  588.           ((and (has-value? product) (has-value? m2))
  589.            (set-value! m1
  590.                        (/ (get-value product) (get-value m2))
  591.                        me))))
  592.  
  593.   (define (process-forget-value)
  594.     (forget-value! product me)
  595.     (forget-value! m1 me)
  596.     (forget-value! m2 me)
  597.     (process-new-value))
  598.  
  599.   (define (me request)
  600.     (cond ((eq? request 'I-have-a-value)
  601.            process-new-value)
  602.           ((eq? request 'I-lost-my-value)
  603.            process-forget-value)
  604.           (else
  605.            (error "Unknown request -- MULTIPLIER" request))))
  606.  
  607.   (connect m1 me)
  608.   (connect m2 me)
  609.   (connect product me)
  610.   me)
  611.  
  612. (define (constant value connector)
  613.   (define (me request)
  614.     (error "Unknown request -- CONSTANT" request))
  615.   (connect connector me)
  616.   (set-value! connector value me)
  617.   me)
  618.  
  619. (define (probe name connector)
  620.   (define (process-new-value)
  621.     (newline)
  622.     (princ "Probe: ")
  623.     (princ name)
  624.     (princ " = ")
  625.     (princ (get-value connector)))
  626.  
  627.   (define (process-forget-value)
  628.     (newline)
  629.     (princ "Probe: ")
  630.     (princ name)
  631.     (princ " = ")
  632.     (princ "?"))
  633.  
  634.   (define (me request)
  635.     (cond ((eq? request 'I-have-a-value)
  636.            process-new-value)
  637.           ((eq? request 'I-lost-my-value)
  638.            process-forget-value)
  639.           (else
  640.            (error "Unknown request -- PROBE" request))))
  641.  
  642.   (connect connector me)
  643.   me)
  644.  
  645. ;;; Connectors
  646.  
  647. (define (make-connector)
  648.   (let ((value nil) (informant nil) (constraints '()))
  649.     (define (set-my-value newval setter)
  650.       (cond ((not (has-value? me))
  651.              (set! value newval)
  652.              (set! informant setter)
  653.              (for-each-except setter
  654.                               inform-about-value
  655.                               constraints))
  656.             ((not (= value newval))
  657.              (error "Contradiction" (list value newval)))))
  658.  
  659.     (define (forget-my-value retractor)
  660.       (if (eq? retractor informant)
  661.           (sequence (set! informant nil)
  662.                     (for-each-except retractor
  663.                                      inform-about-no-value
  664.                                      constraints))))
  665.  
  666.     (define (connect new-constraint)
  667.       (if (not (memq new-constraint constraints))
  668.           (set! constraints 
  669.                 (cons new-constraint constraints)))
  670.       (if (has-value? me)
  671.           (inform-about-value new-constraint)))
  672.  
  673.     (define (me request)
  674.       (cond ((eq? request 'has-value?)
  675.              (not (null? informant)))
  676.             ((eq? request 'value) value)
  677.             ((eq? request 'set-value!) set-my-value)
  678.             ((eq? request 'forget) forget-my-value)
  679.             ((eq? request 'connect) connect)
  680.             (else (error "Unknown operation -- CONNECTOR"
  681.                          request))))
  682.     me))
  683.  
  684. (define (for-each-except exception procedure list)
  685.   (define (loop items)
  686.     (cond ((null? items) 'done)
  687.           ((eq? (car items) exception) (loop (cdr items)))
  688.           (else (procedure (car items))
  689.                 (loop (cdr items)))))
  690.   (loop list))
  691.  
  692. ;;; Interface to connectors
  693.  
  694. (define (has-value? connector)
  695.   (connector 'has-value?))
  696.  
  697. (define (get-value connector)
  698.   (connector 'value))
  699.  
  700. (define (forget-value! connector retractor)
  701.   ((connector 'forget) retractor))
  702.  
  703. (define (set-value! connector new-value informant)
  704.   ((connector 'set-value!) new-value informant))
  705.  
  706. (define (connect connector new-constraint)
  707.   ((connector 'connect) new-constraint))
  708.  
  709.  
  710. ;;; Exercise 3.37
  711.  
  712. (define (centigrade-fahrenheit-converter x)
  713.   (c+ (c* (c/ (cv 9) (cv 5))
  714.           x)
  715.       (cv 32)))
  716.  
  717. (define (c+ x y)
  718.   (let ((z (make-connector)))
  719.     (adder x y z)
  720.     z))
  721.  
  722. ;;; Section 3.4.1
  723.  
  724. (define (sum-odd-squares tree)
  725.   (if (leaf-node? tree)
  726.       (if (odd? tree)
  727.           (square tree)
  728.           0)
  729.       (+ (sum-odd-squares (left-branch tree))
  730.          (sum-odd-squares (right-branch tree)))))
  731.  
  732. (define (odd-fibs n)
  733.   (define (next k)
  734.     (if (> k n)
  735.         '()
  736.         (let ((f (fib k)))
  737.           (if (odd? f)
  738.               (cons f (next (1+ k)))
  739.               (next (1+ k))))))
  740.   (next 1))
  741.  
  742. (define (enumerate-tree tree)
  743.   (if (leaf-node? tree)
  744.       (cons-stream tree the-empty-stream)
  745.       (append-streams (enumerate-tree (left-branch tree))
  746.                       (enumerate-tree (right-branch tree)))))
  747.  
  748. (define (append-streams s1 s2)
  749.   (if (empty-stream? s1)
  750.       s2
  751.       (cons-stream (head s1)
  752.                    (append-streams (tail s1) s2))))
  753.  
  754. (define (filter-odd s)
  755.   (cond ((empty-stream? s) the-empty-stream)
  756.         ((odd? (head s))
  757.          (cons-stream (head s) (filter-odd (tail s))))
  758.         (else (filter-odd (tail s)))))
  759.  
  760. (define (map-square s)
  761.   (if (empty-stream? s)
  762.       the-empty-stream
  763.       (cons-stream (square (head s))
  764.                    (map-square (tail s)))))
  765.  
  766. (define (accumulate-+ s)
  767.   (if (empty-stream? s)
  768.       0
  769.       (+ (head s) (accumulate-+ (tail s)))))
  770.  
  771. (define (sum-odd-squares tree)
  772.   (accumulate-+
  773.     (map-square
  774.       (filter-odd
  775.         (enumerate-tree tree)))))
  776.  
  777. (define (enumerate-interval low high)
  778.   (if (> low high)
  779.       the-empty-stream
  780.       (cons-stream low (enumerate-interval (1+ low) high))))
  781.  
  782. (define (map-fib s)
  783.   (if (empty-stream? s)
  784.       the-empty-stream
  785.       (cons-stream (fib (head s))
  786.                    (map-fib (tail s)))))
  787.  
  788. (define (accumulate-cons s)
  789.   (if (empty-stream? s)
  790.       '()
  791.       (cons (head s) (accumulate-cons (tail s)))))
  792.  
  793. (define (odd-fibs n)
  794.   (accumulate-cons
  795.     (filter-odd
  796.       (map-fib
  797.         (enumerate-interval 1 n)))))
  798.  
  799. (define (list-square-fibs n)
  800.   (accumulate-cons
  801.     (map-square
  802.       (map-fib
  803.         (enumerate-interval 1 n)))))
  804.  
  805. ;;; Section 3.4.2
  806.  
  807. (define (accumulate combiner initial-value stream)
  808.   (if (empty-stream? stream)
  809.       initial-value
  810.       (combiner (head stream)
  811.                 (accumulate combiner
  812.                             initial-value
  813.                             (tail stream)))))
  814.  
  815. (define (sum-stream stream)
  816.   (accumulate + 0 stream))
  817.  
  818. (define (product-stream stream)
  819.   (accumulate * 1 stream))
  820.  
  821. (define (accumulate-cons stream)
  822.   (accumulate cons '() stream))
  823.  
  824. (define (flatten stream)
  825.   (accumulate append-streams the-empty-stream stream))
  826.  
  827. (define (horner-eval x coefficient-stream)
  828.   (define (add-term coeff higher-terms)
  829.     (+ coeff (* x higher-terms)))
  830.   (accumulate add-term
  831.               0
  832.               coefficient-stream))
  833.  
  834.  
  835. (define (map proc stream)
  836.   (if (empty-stream? stream)
  837.       the-empty-stream
  838.       (cons-stream (proc (head stream))
  839.                    (map proc (tail stream)))))
  840.  
  841. (define (filter pred stream)
  842.   (cond ((empty-stream? stream) the-empty-stream)
  843.         ((pred (head stream))
  844.          (cons-stream (head stream)
  845.                       (filter pred (tail stream))))
  846.         (else (filter pred (tail stream)))))
  847.  
  848. ;;; Examples
  849.  
  850. (define (product-of-squares-of-odd-elements stream)
  851.   (accumulate *
  852.               1
  853.               (map square
  854.                    (filter odd? stream))))
  855.  
  856. (define (salary-of-highest-paid-programmer record-stream)
  857.   (accumulate max
  858.               0
  859.               (map salary
  860.                    (filter programmer?
  861.                            record-stream))))
  862.  
  863. ;;; Stream printer
  864.  
  865. (define (for-each proc stream)
  866.   (if (empty-stream? stream)
  867.       'done
  868.       (sequence (proc (head stream))
  869.                 (for-each proc (tail stream)))))
  870.  
  871. (define (print-stream s)
  872.   (for-each print s))
  873.  
  874. ;;; Exercise 3.38
  875.  
  876. (define (left-accumulate combiner initial-value stream)
  877.   (if (empty-stream? stream)
  878.       initial-value
  879.       (left-accumulate combiner
  880.                        (combiner initial-value (head stream))
  881.                        (tail stream))))
  882.  
  883.  
  884. ;;; Nested mappings
  885.  
  886. (define (flatmap f s) (flatten (map f s)))
  887.  
  888. (define (prime-sum-pairs n)
  889.   (map (lambda (pair) (list (car pair)
  890.                             (cadr pair)
  891.                             (+ (car pair) (cadr pair))))
  892.        (filter (lambda (pair) (prime? (+ (car pair)
  893.                                          (cadr pair))))
  894.                (flatmap
  895.                 (lambda (i)
  896.                   (map (lambda (j) (list i j))
  897.                        (enumerate-interval 1 (-1+ i))))
  898.                 (enumerate-interval 1 n)))))
  899.  
  900. (define (triples n s)
  901.   (filter (lambda (triple) 
  902.             (= (+ (car triple) (cadr triple) (caddr triple))
  903.                s))
  904.           (flatmap 
  905.            (lambda (i)
  906.              (flatmap
  907.               (lambda (j)
  908.                 (map (lambda (k) (list i j k))
  909.                      (enumerate-interval 1 (-1+ j))))
  910.               (enumerate-interval 1 (-1+ i))))
  911.            (enumerate-interval 1 n))))
  912.  
  913. ;;; Versions of the above with COLLECT
  914.  
  915. (define (prime-sum-pairs n)
  916.   (collect (list i j (+ i j))
  917.            ((i (enumerate-interval 1 n))
  918.             (j (enumerate-interval 1 (-1+ i))))
  919.            (prime? (+ i j))))
  920.  
  921. (define (triples n s)
  922.   (collect (list i j k)
  923.            ((i (enumerate-interval 1 n))
  924.             (j (enumerate-interval 1 (-1+ i)))
  925.             (k (enumerate-interval 1 (-1+ j))))
  926.            (= (+ i j k) s)))
  927.  
  928. (define (permutations S)
  929.   (if (empty-stream? S)
  930.       (singleton the-empty-stream)
  931.       (flatmap (lambda (x)
  932.                  (map (lambda (p)
  933.                         (cons-stream x p))
  934.                       (permutations (remove x S))))
  935.                S)))
  936.  
  937. (define (singleton s)
  938.   (cons-stream s the-empty-stream)) 
  939.  
  940. ;;; Version with COLLECT
  941.  
  942. (define (permutations S)
  943.   (if (empty-stream? S)
  944.       (singleton the-empty-stream)
  945.       (collect (cons-stream x p)
  946.                ((x S)
  947.                 (p (permutations (remove x S)))))))
  948.  
  949. (define (remove item stream)
  950.   (filter (lambda (x) (not (equal? x item)))
  951.           stream))
  952.  
  953. ;;; Exercise 3.41
  954.  
  955. (define (queens board-size)
  956.   (define (queen-cols k)
  957.     (if (= k 0)
  958.         (singleton empty-board)
  959.         (collect (adjoin-position new-row k rest-of-queens)
  960.                  ((rest-of-queens (queen-cols (-1+ k)))
  961.                   (new-row (enumerate-interval 1 board-size)))
  962.                  (safe? new-row k rest-of-queens))))
  963.   (queen-cols board-size))
  964.  
  965. ;;; Section 3.4.3 -- Implementing streams
  966.  
  967. (define (sum-primes a b)
  968.   (define (iter count accum)
  969.     (cond ((> count b) accum)
  970.           ((prime? count) (iter (1+ count) (+ count accum)))
  971.           (else (iter (1+ count) accum))))
  972.   (iter a 0))
  973.  
  974. (define (sum-primes a b)
  975.   (accumulate +
  976.               0
  977.               (filter prime?
  978.                       (enumerate-interval a b))))
  979.  
  980. ;;; Implementation of HEAD and TAIL
  981.  
  982. (define (head stream) (car stream))
  983.  
  984. (define (tail stream) (force (cdr stream)))
  985.  
  986. (define (force delayed-object)
  987.   (delayed-object))
  988.  
  989. ;;; Memoization of streams
  990.  
  991. (define (memo-proc proc)
  992.   (let ((already-run? nil) (result nil))
  993.     (lambda ()
  994.       (if (not already-run?)
  995.           (sequence (set! result (proc))
  996.                     (set! already-run? (not nil))
  997.                     result)
  998.           result))))
  999.  
  1000. ;;; Exercise 3.43
  1001.  
  1002. (define (show x)
  1003.   (print x)
  1004.   x)
  1005.  
  1006. (define (nth-stream n s)
  1007.   (if (= n 0)
  1008.       (head s)
  1009.       (nth-stream (-1+ n) (tail s))))
  1010.  
  1011. ;;; Exercise 3.45
  1012.  
  1013. (define (copy-stream s)
  1014.   (if (empty-stream? s)
  1015.       the-empty-stream
  1016.       (cons-stream (head s) (copy-stream (tail s)))))
  1017.  
  1018. (define (*copy-stream s)
  1019.   (accumulate cons the-empty-stream s))
  1020.  
  1021. ;;; Section 3.4.4 -- Infinite streams
  1022.  
  1023. (define (integers-starting-from n)
  1024.   (cons-stream n (integers-starting-from (1+ n))))
  1025.  
  1026. (define integers (integers-starting-from 1))
  1027.  
  1028. (define (divisible? x y) (= (remainder x y) 0))
  1029.  
  1030. (define no-sevens
  1031.   (filter (lambda (x) (not (divisible? x 7)))
  1032.           integers))
  1033.  
  1034. (define (fibgen a b)
  1035.   (cons-stream a (fibgen b (+ a b))))
  1036.  
  1037. (define fibs (fibgen 0 1))
  1038.  
  1039. (define (sieve stream)
  1040.   (cons-stream
  1041.    (head stream)
  1042.    (sieve (filter
  1043.            (lambda (x) (not (divisible? x (head stream))))
  1044.            (tail stream)))))
  1045.  
  1046. (define primes (sieve (integers-starting-from 2)))
  1047.  
  1048. (define ones (cons-stream 1 ones))
  1049.  
  1050. (define (add-streams s1 s2)
  1051.   (cond ((empty-stream? s1) s2)
  1052.         ((empty-stream? s2) s1)
  1053.         (else
  1054.          (cons-stream (+ (head s1) (head s2))
  1055.                       (add-streams (tail s1) (tail s2))))))
  1056.  
  1057. (define integers (cons-stream 1 (add-streams ones integers)))
  1058.  
  1059. (define fibs
  1060.   (cons-stream 0
  1061.                (cons-stream 1
  1062.                             (add-streams (tail fibs) fibs))))
  1063.  
  1064. (define (scale-stream c stream)
  1065.   (map (lambda (x) (* x c)) stream))
  1066.  
  1067. (define double (cons-stream 1 (scale-stream 2 double)))
  1068.  
  1069. (define primes
  1070.   (cons-stream 2 (filter prime? (integers-starting-from 3))))
  1071.  
  1072. (define (prime? n)
  1073.   (define (iter ps)
  1074.     (cond ((> (square (head ps)) n) t)
  1075.           ((divisible? n (head ps)) nil)
  1076.           (else (iter (tail ps)))))
  1077.   (iter primes))
  1078.  
  1079. ;;; Exercise 3.46
  1080.  
  1081. (define (merge s1 s2)
  1082.   (cond ((empty-stream? s1) s2)
  1083.         ((empty-stream? s2) s1)
  1084.         (else
  1085.          (let ((h1 (head s1))
  1086.                (h2 (head s2)))
  1087.            (cond ((< h1 h2) (cons-stream h1 (merge (tail s1) s2)))
  1088.                  ((> h1 h2) (cons-stream h2 (merge s1 (tail s2))))
  1089.                  (else
  1090.                   (cons-stream h1
  1091.                                (merge (tail s1) (tail s2)))))))))
  1092.  
  1093. ;;; Exercise 3.48
  1094.  
  1095. (define (expand num den radix)
  1096.   (cons-stream (quotient (* num radix) den)
  1097.                (expand (remainder (* num radix) den) den radix)))
  1098.  
  1099. ;;; Exercise 3.49
  1100.  
  1101. (define (integrate-term t)
  1102.   (let ((new-order (1+ (order t))))
  1103.     (make-term new-order
  1104.                (rat/int (coeff t) new-order))))
  1105.  
  1106. (define (integrate-series series)
  1107.   (map integrate-term series))
  1108.  
  1109. (define (rat/int r i) (/rat r (make-rat i 1)))
  1110.  
  1111. (define unit-term (make-term 0 (make-rat 1 1)))
  1112.  
  1113. (define exp-series
  1114.   (cons-stream unit-term (integrate-series exp-series)))
  1115.  
  1116. ;;; Streams as signals
  1117.  
  1118. (define (integral integrand initial-value dt)
  1119.   (define int
  1120.     (cons-stream initial-value
  1121.                  (add-streams (scale-stream dt integrand)
  1122.                               int)))
  1123.   int)
  1124.  
  1125. ;;; Exrecise 3.51
  1126.  
  1127. (define (make-zero-crossings input-stream last-value)
  1128.   (cons-stream (sign-change-detector (head input-stream) last-value)
  1129.                (make-zero-crossings (tail input-stream)
  1130.                                     (head input-stream))))
  1131.  
  1132. (define zero-crossings (make-zero-crossings sense-data 0))
  1133.  
  1134. (define (map-2 proc s1 s2)
  1135.   (cons-stream (proc (head s1) (head s2))
  1136.                (map-2 proc (tail s1) (tail s2))))
  1137.  
  1138. (define (make-zero-crossings input-stream last-value)
  1139.   (let ((avpt (/ (+ (head input-stream) last-value) 2)))
  1140.     (cons-stream (sign-change-detector avpt last-value)
  1141.                  (make-zero-crossings (tail input-stream) avpt))))
  1142.  
  1143. ;;; Section 3.4.5
  1144.  
  1145. (define (solve f y-init dt)
  1146.   (define y (integral dy y-init dt))
  1147.   (define dy (map f y))
  1148.   y)
  1149.  
  1150. (define (integral delayed-integrand initial-value dt)
  1151.   (define int
  1152.     (cons-stream initial-value
  1153.                  (let ((integrand (force delayed-integrand)))
  1154.                    (add-streams (scale-stream dt integrand)
  1155.                                 int))))
  1156.   int)
  1157.  
  1158. (define (solve f y-init dt)
  1159.   (define y (integral (delay dy) y-init dt))
  1160.   (define dy (map f y))
  1161.   y)
  1162.  
  1163. (define (integral integrand initial-value dt)
  1164.   (cons-stream initial-value
  1165.                (if (empty-stream? integrand)
  1166.                    the-empty-stream
  1167.                    (integral (tail integrand)
  1168.                              (+ (* dt (head integrand))
  1169.                                 initial-value)
  1170.                              dt))))
  1171.  
  1172. ;;; Nested mappings
  1173.  
  1174. (define (pairs S1 S2)
  1175.   (collect (list i j)
  1176.            ((i S1)
  1177.             (j S2))))
  1178.  
  1179. (define (pairs S1 S2)
  1180.   (flatmap (lambda (i)
  1181.              (map (lambda (j) (list i j))
  1182.                   S2))
  1183.            S1))
  1184.  
  1185. (define (flatmap f s) (flatten (map f s)))
  1186.  
  1187. (define (flatten stream)
  1188.   (accumulate append-streams the-empty-stream stream))
  1189.  
  1190. (define (interleave s1 s2)
  1191.   (if (empty-stream? s1)
  1192.       s2
  1193.       (cons-stream (head s1)
  1194.                    (interleave s2
  1195.                                (tail s1)))))
  1196.  
  1197. (define (flatten stream)
  1198.   (accumulate interleave the-empty-stream stream))
  1199.  
  1200. (define (accumulate-delayed combiner initial-value stream)
  1201.   (if (empty-stream? stream)
  1202.       initial-value
  1203.       (combiner (head stream)
  1204.                 (delay
  1205.                  (accumulate-delayed combiner
  1206.                                      initial-value
  1207.                                      (tail stream))))))
  1208.  
  1209. (define (interleave-delayed s1 delayed-s2)
  1210.   (if (empty-stream? s1)
  1211.       (force delayed-s2)
  1212.       (cons-stream (head s1)
  1213.                    (interleave-delayed (force delayed-s2)
  1214.                                        (delay (tail s1))))))
  1215.  
  1216. (define (flatten stream)
  1217.   (accumulate-delayed interleave-delayed
  1218.                       the-empty-stream
  1219.                       stream))
  1220.  
  1221. ;;; Section 3.4.6
  1222.  
  1223. (define (stream-withdraw balance amount-stream)
  1224.     (cons-stream balance
  1225.                  (stream-withdraw (- balance
  1226.                                      (head amount-stream))
  1227.                                   (tail amount-stream))))
  1228.  
  1229. (define random-numbers
  1230.   (cons-stream random-init
  1231.                (map rand-update random-numbers)))
  1232.  
  1233. (define cesaro-stream
  1234.   (map-successive-pairs (lambda (r1 r2) (= (gcd r1 r2) 1))
  1235.                         random-numbers))
  1236.  
  1237. (define (map-successive-pairs f s)
  1238.   (cons-stream (f (head s) (head (tail s)))
  1239.                (map-successive-pairs f (tail (tail s)))))
  1240.  
  1241. (define (monte-carlo experiment-stream nt nf)
  1242.   (define (next nt nf)
  1243.     (cons-stream (/ nt (+ nt nf))
  1244.                  (monte-carlo (tail experiment-stream)
  1245.                               nt
  1246.                               nf)))
  1247.   (if (head experiment-stream)
  1248.       (next (+ nt 1) nf)
  1249.       (next nt (+ nf 1))))
  1250.  
  1251. (define pi
  1252.   (map (lambda (p) (sqrt (/ 6 p)))
  1253.        (monte-carlo cesaro-stream 0 0)))
  1254.  
  1255. (42)%