; - Exercise 2.3, pg. 39 -

(define firsts-of-both
  (lambda (list-1 list-2)
    (make-list-of-two (car list-1) (car list-2))))

; - End Exercise -

; - Program 2.1, pg. 44 -

(define singleton-list?
  (lambda (ls)
    (and (pair? ls) (null? (cdr ls)))))

; - End Program -

; - Program 2.2, pg. 47 -

(define last-item
  (lambda (ls)
    (cond
      ((null? (cdr ls)) (car ls))
      (else (last-item (cdr ls))))))

; - End Program -

; - Program 2.3, pg. 50 -

(define member?
  (lambda (item ls)
    (cond
      ((null? ls) #f)
      (else (or (equal? (car ls) item) 
                (member? item (cdr ls)))))))

; - End Program -

; - Program 2.4, pg. 52 -

(define remove-1st
  (lambda (item ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) item) (cdr ls))
      (else (cons (car ls) (remove-1st item (cdr ls)))))))

; - End Program -

; - Program 2.5, pg. 62 -

(define remove-1st-trace
  (lambda (item ls)
    (cond
      ((entering (null? ls) ls 1)
       (leaving '() 1))
      ((entering (equal? (car ls) item) ls 2)
       (leaving (cdr ls) 2))
      ((entering 'else ls 3)
       (leaving
         (cons (car ls) (remove-1st-trace item (cdr ls)))
         3)))))

; - End Program -

; - Program 2.6, pg. 62 -

(define entering
  (lambda (test input cond-clause-number)
    (begin
      (if test (writeln "   Entering cond-clause-"
                 cond-clause-number " with ls = " input))
      test)))

; - End Program -

; - Program 2.7, pg. 62 -

(define leaving
  (lambda (result cond-clause-number)
    (begin
      (writeln "Leaving cond-clause-" 
        cond-clause-number " with result = " result)
      result)))

; - End Program -

; - Program 2.8, pg. 66 -

(define swapper 
  (lambda (x y ls) 
    (cond
      ((null? ls) '())
      ((equal? (car ls) x) 
       (cons y (swapper x y (cdr ls))))
      ((equal? (car ls) y) 
       (cons x (swapper x y (cdr ls))))
      (else 
       (cons (car ls) (swapper x y (cdr ls)))))))      

; - End Program -

; - Exercise 2.24, pg. 70 -

(define describe
  (lambda (s)
    (cond
      ((null? s) (quote '()))
      ((number? s) s)
      ((symbol? s) (list 'quote s))
      ((pair? s) (list 'cons (describe (car s)) (describe (cdr s))))
      (else s))))

; - End Exercise -
; - Program 3.1, pg. 75 -

(define add1
  (lambda (n)
    (+ n 1)))

; - End Program -

; - Program 3.2, pg. 75 -

(define sub1
  (lambda (n)
    (- n 1)))

; - End Program -

; - Program 3.4, pg. 77 -

(define harmonic-sum
  (lambda (n)
    (cond
      ((zero? n) 0)
      (else (+ (/ 1 n) (harmonic-sum (sub1 n)))))))

; - End Program -

; - Program 3.5, pg. 78 -

(define list-of-zeros
  (lambda (n)
    (cond
      ((zero? n) '())
      (else (cons 0 (list-of-zeros (sub1 n)))))))

; - End Program -

; - Program 3.6, pg. 79 -

(define length
  (lambda (ls)
    (if (null? ls)
        0
        (add1 (length (cdr ls))))))

; - End Program -

; - Program 3.7, pg. 81 -

(define list-ref
  (lambda (ls n)
    (cond
      ((null? ls)
       (error "list-ref: Index" n "out of range for list" ls))
      ((zero? n) (car ls))
      (else (list-ref (cdr ls) (sub1 n))))))

; - End Program -

; - Program 3.8, pg. 85 -

(define rzero?
  (lambda (rtl)
    (zero? (numr rtl))))

; - End Program -

; - Program 3.9, pg. 86 -

(define r+
  (lambda (x y)
    (make-ratl 
      (+ (* (numr x) (denr y)) (* (numr y) (denr x)))
      (* (denr x) (denr y))))) 

; - End Program -

; - Program 3.10, pg. 86 -

(define r*
  (lambda (x y)
    (make-ratl 
      (* (numr x) (numr y)) 
      (* (denr x) (denr y)))))

; - End Program -

; - Program 3.11, pg. 86 -

(define r-
  (lambda (x y)
    (make-ratl 
      (- (* (numr x) (denr y)) (* (numr y) (denr x)))
      (* (denr x) (denr y)))))

; - End Program -

; - Program 3.12, pg. 87 -

(define rinvert 
  (lambda (rtl)
    (if (rzero? rtl)
        (error "rinvert: Cannot invert " rtl)
        (make-ratl (denr rtl) (numr rtl)))))

; - End Program -

; - Program 3.13, pg. 87 -

(define r/
  (lambda (x y)
    (r* x (rinvert y))))

; - End Program -

; - Program 3.14, pg. 87 -

(define r=
  (lambda (x y)
    (= (* (numr x) (denr y)) (* (numr y) (denr x)))))

; - End Program -

; - Program 3.15, pg. 87 -

(define rpositive?
  (lambda (rtl)
    (or (and (positive? (numr rtl)) (positive? (denr rtl)))
        (and (negative? (numr rtl)) (negative? (denr rtl))))))

; - End Program -

; - Program 3.16, pg. 88 -

(define r>
  (lambda (x y)
    (rpositive? (r- x y))))

; - End Program -

; - Program 3.17, pg. 88 -

(define max                    
  (lambda (x y)
    (if (> x y)
        x
        y))) 

; - End Program -

; - Program 3.18, pg. 88 -

(define rmax
  (lambda (x y)
    (if (r> x y)
        x
        y))) 

; - End Program -

; - Program 3.19, pg. 89 -

(define extreme-value
  (lambda (pred x y)
    (if (pred x y)
        x 
        y))) 

; - End Program -

; - Program 3.20, pg. 90 -

(define rprint
  (lambda (rtl)
    (writeln (numr rtl) "/" (denr rtl)))) 

; - End Program -

; - Program 3.21, pg. 91 -

(define numr
  (lambda (rtl)
    (car rtl)))

(define denr
  (lambda (rtl)
    (cadr rtl)))

(define make-ratl
  (lambda (int1 int2)
    (if (zero? int2)
        (error "make-ratl: The denominator cannot be zero.")
        (list int1 int2)))) 

; - End Program -

; - Exercise 3.15, pg. 92 -

(define rpositive?
  (lambda (rtl)
    (same-sign? (numr rtl) (denr rtl))))

; - End Exercise -
; - Program 4.1, pg. 96 -

(define append
  (lambda (ls1 ls2)       
    (if (null? ls1) 
        ls2
        (cons (car ls1) (append (cdr ls1) ls2)))))

; - End Program -
 
; - Program 4.2, pg. 97 -

(define reverse
  (lambda (ls)
    (if (null? ls)
        '()
        (append (reverse (cdr ls)) (list (car ls))))))

; - End Program -

; - Program 4.3, pg. 98 -

(define merge
  (lambda (sorted-ntpl1 sorted-ntpl2)
    (cond 
      ((null? sorted-ntpl1) sorted-ntpl2)
      ((null? sorted-ntpl2) sorted-ntpl1)
      ((< (car sorted-ntpl1) (car sorted-ntpl2))
       (cons (car sorted-ntpl1) 
             (merge (cdr sorted-ntpl1) sorted-ntpl2)))
      (else (cons (car sorted-ntpl2) 
                  (merge sorted-ntpl1 (cdr sorted-ntpl2)))))))

; - End Program -
 
; - Program 4.4, pg. 98 -

(define even? 
  (lambda (int)
    (if (zero? int)
        #t
        (odd? (sub1 int)))))

; - End Program -

; - Program 4.5, pg. 99 -

(define odd?
  (lambda (int)
    (if (zero? int)
        #f
        (even? (sub1 int)))))

; - End Program -
 
; - Program 4.6, pg. 100 -

(define remove
  (lambda (item ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) item) (remove item (cdr ls)))
      (else (cons (car ls) (remove item (cdr ls)))))))

; - End Program -

; - Program 4.7, pg. 102 -

(define count-all
  (lambda (ls)
    (cond
      ((null? ls) 0)
      ((not (pair? (car ls))) (add1 (count-all (cdr ls))))
      (else (+ (count-all (car ls)) (count-all (cdr ls)))))))

; - End Program -

; - Program 4.8, pg. 105 -

(define remove-all
  (lambda (item ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) item) (remove-all item (cdr ls)))
      ((pair? (car ls)) 
       (cons (remove-all item (car ls)) (remove-all item (cdr ls))))
      (else (cons (car ls) (remove-all item (cdr ls)))))))

; - End Program -

; - Program 4.9, pg. 105 -

(define remq-all
  (lambda (symbl ls)
    (cond
      ((null? ls) '())
      ((pair? (car ls))
       (cons (remq-all symbl (car ls)) (remq-all symbl (cdr ls))))
      ((eq? (car ls) symbl) (remq-all symbl (cdr ls)))
      (else (cons (car ls) (remq-all symbl (cdr ls)))))))

; - End Program -

; - Program 4.10, pg. 107 -

(define reverse-all
  (lambda (ls)
    (if (null? ls) 
        '()
        (append (reverse-all (cdr ls))
                (list (if (pair? (car ls))
                          (reverse-all (car ls))
                          (car ls)))))))

; - End Program -

; - Program 4.13, pg. 110 -

(define depth
  (lambda (item)
    (if (not (pair? item)) 
        0
        (max (add1 (depth (car item))) (depth (cdr item))))))

; - End Program -

; - Program 4.14, pg. 111 -

(define flatten
  (lambda (ls)
    (cond
      ((null? ls) '())
      ((pair? (car ls))
       (append (flatten (car ls)) (flatten (cdr ls))))
      (else (cons (car ls) (flatten (cdr ls)))))))

; - End Program -

; - Program 4.15, pg. 113 -

(define remove-left-most
  (lambda (item ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) item) (cdr ls))
      ((not (pair? (car ls)))
       (cons (car ls) (remove-left-most item (cdr ls))))
      ((member-all? item (car ls))
       (cons (remove-left-most item (car ls)) (cdr ls)))
      (else (cons (car ls) (remove-left-most item (cdr ls)))))))

; - End Program -

; - Program 4.16, pg. 113 -

(define member-all?
  (lambda (item ls)
    (if (null? ls) 
        #f
        (or (equal? (car ls) item)
            (and (not (pair? (car ls)))
                 (member-all? item (cdr ls)))
            (and (pair? (car ls))
                 (or (member-all? item (car ls))
                     (member-all? item (cdr ls))))))))

; - End Program -

; - Program 4.17, pg. 114 -

(define remove-left-most
  (lambda (item ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) item) (cdr ls))
      ((and (pair? (car ls)) (member-all? item (car ls)))
       (cons (remove-left-most item (car ls)) (cdr ls)))
      (else (cons (car ls) (remove-left-most item (cdr ls)))))))

; - End Program -

; - Program 4.18, pg. 116 -

(define fact
  (lambda (int)
    (if (zero? int)
        1
        (* int (fact (sub1 int))))))

; - End Program -

; - Program 4.19, pg. 118 -

(define fact-it
  (lambda (int acc)
    (if (zero? int)
        acc
        (fact-it (sub1 int) (* acc int)))))

; - End Program -

; - Program 4.20, pg. 121 -

(define fib
  (lambda (int)
    (if (< int 2) 
        int
        (+ (fib (- int 1)) (fib (- int 2))))))

; - End Program -

; - Program 4.24, pg. 124 -

(define fib-it
  (lambda (int acc1 acc2)
    (if (= int 1)
        acc2
        (fib-it (sub1 int) acc2 (+ acc1 acc2)))))

; - End Program -

; - Program 4.25, pg. 127 -

(define reverse-it
  (lambda (ls acc)
    (if (null? ls)
        acc
        (reverse-it (cdr ls) (cons (car ls) acc)))))

; - End Program -
; - Program 5.3, pg. 137 -

(define remove-leftmost
  (lambda (item ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) item) (cdr ls))
      ((pair? (car ls))
       (let ((rem-list (remove-leftmost item (car ls))))
         (cons rem-list (cond
                          ((equal? (car ls) rem-list)
                           (remove-leftmost item (cdr ls)))
                          (else (cdr ls))))))
      (else (cons (car ls) (remove-leftmost item (cdr ls)))))))

; - End Program -

; - Program 5.4, pg. 139 -

(define fact
  (lambda (n)
    (letrec ((fact-it 
               (lambda (k acc)
                 (if (zero? k)
                     acc
                     (fact-it (sub1 k) (* k acc))))))
      (fact-it n 1))))  

; - End Program -

; - Program 5.5, pg. 139 -

(define swapper
  (lambda (x y ls)
    (letrec
      ((swap
         (lambda (ls*)
           (cond 
             ((null? ls*) '())
             ((equal? (car ls*) x) (cons y (swap (cdr ls*))))
             ((equal? (car ls*) y) (cons x (swap (cdr ls*))))
             (else (cons (car ls*) (swap (cdr ls*))))))))
      (swap ls))))

; - End Program -

; - Exercise 5.5, pg. 141 -

(define mystery
  (lambda (n)
    (letrec
      ((mystery-helper
         (lambda (n s)
           (cond
             ((zero? n) (list s))
             (else
               (append
                 (mystery-helper (sub1 n) (cons 0 s))
                 (mystery-helper (sub1 n) (cons 1 s))))))))
      (mystery-helper n '()))))

; - End Exercise -

; - Program 5.6, pg. 144 -

(define zero-poly?
  (lambda (poly)
    (and (zero? (degree poly)) (zero? (leading-coef poly)))))

; - End Program -

; - Program 5.7, pg. 145 -

(define make-term
  (lambda (deg coef)
    (poly-cons deg coef the-zero-poly))) 

; - End Program -

; - Program 5.8, pg. 145 -

(define leading-term
  (lambda (poly)
    (make-term (degree poly) (leading-coef poly))))

; - End Program -

; - Program 5.9, pg. 146 -

(define p+
  (lambda (poly1 poly2)
    (cond
      ((zero-poly? poly1) poly2)
      ((zero-poly? poly2) poly1)
      (else (let ((n1 (degree poly1))
                  (n2 (degree poly2))
                  (a1 (leading-coef poly1))
                  (a2 (leading-coef poly2))
                  (rest1 (rest-of-poly poly1))
                  (rest2 (rest-of-poly poly2)))
              (cond 
                ((> n1 n2) (poly-cons n1 a1 (p+ rest1 poly2)))
                ((< n1 n2) (poly-cons n2 a2 (p+ poly1 rest2)))
                (else 
                 (poly-cons n1 (+ a1 a2) (p+ rest1 rest2))))))))) 

; - End Program -

; - Program 5.10, pg. 148 -

(define p* 
  (letrec 
    ((t* (lambda (trm poly)
           (if (zero-poly? poly)
               the-zero-poly
               (poly-cons 
                 (+ (degree trm) (degree poly))
                 (* (leading-coef trm) (leading-coef poly))
                 (t* trm (rest-of-poly poly)))))))
    (lambda (poly1 poly2)
      (letrec
        ((p*-helper (lambda (p1)
                      (if (zero-poly? p1)
                          the-zero-poly
                          (p+ (t* (leading-term p1) poly2)
                              (p*-helper (rest-of-poly p1)))))))
        (p*-helper poly1)))))

; - End Program -

; - Program 5.11, pg. 148 -

(define negative-poly
  (lambda (poly) 
    (let ((poly-negative-one (make-term 0 -1)))
      (p* poly-negative-one poly))))

; - End Program -

; - Program 5.12, pg. 148 -

(define p-
  (lambda (poly1 poly2)
    (p+ poly1 (negative-poly poly2))))  

; - End Program -

; - Program 5.13, pg. 150 -

(define poly-value
  (lambda (poly num)
    (letrec 
      ((pvalue (lambda (p)
                 (let ((n (degree p)))
                   (if (zero? n) 
                       (leading-coef p)
                       (let ((rest (rest-of-poly p)))
                         (if (< (degree rest) (sub1 n))
                             (pvalue (poly-cons
                                       (sub1 n)
                                       (* num (leading-coef p))
                                       rest))
                             (pvalue (poly-cons 
                                       (sub1 n)
                                       (+ (* num (leading-coef p))
                                          (leading-coef rest))
                                       (rest-of-poly rest))))))))))
      (pvalue poly))))

; - End Program -

; - Program 5.14, pg. 151 -

(define the-zero-poly '(0))

(define degree 
  (lambda (poly)
    (sub1 (length poly))))

(define leading-coef
  (lambda (poly)
    (car poly)))

(define rest-of-poly
  (lambda (poly)
    (cond
      ((zero? (degree poly)) the-zero-poly)
      ((zero? (leading-coef (cdr poly)))
       (rest-of-poly (cdr poly)))
      (else (cdr poly)))))

(define poly-cons
  (lambda (deg coef poly)
    (let ((deg-p (degree poly)))
      (cond
        ((and (zero? deg) (equal? poly the-zero-poly)) (list coef))
        ((< deg-p deg)
         (if (zero? coef)
             poly
             (cons coef 
                (append (list-of-zeros (sub1 (- deg deg-p))) 
                        poly))))
        (else (error "poly-cons: Degree too high in" poly))))))

; - End Program -

; - Program 5.15, pg. 153 -

(define the-zero-poly '((0 0)))

(define degree
  (lambda (poly)
    (caar poly)))
    
(define leading-coef
  (lambda (poly)
    (cadar poly)))

(define rest-of-poly 
  (lambda (poly)
    (if (null? (cdr poly))
        the-zero-poly
        (cdr poly))))

(define poly-cons
  (lambda (deg coef poly)
    (let ((deg-p (degree poly)))
      (cond 
        ((and (zero? deg) (equal? poly the-zero-poly))
         (list (list deg coef)))
        ((< deg-p deg)
         (if (zero? coef) 
             poly
             (cons (list deg coef) poly)))
        (else (error "poly-cons: degree too high in" poly))))))

; - End Program -

; - Program 5.16, pg. 157 -

(define digits->poly
  (lambda (digit-list)
    (if (null? digit-list)
        (error "digits->poly: Not defined for" digit-list)
        (letrec
          ((make-poly
             (lambda (deg ls)
               (if (null? ls)
                   the-zero-poly
                   (poly-cons deg (car ls)
                     (make-poly (sub1 deg) (cdr ls)))))))
          (make-poly (sub1 (length digit-list)) digit-list)))))

; - End Program -

; - Program 5.17, pg. 157 -

(define binary->decimal
  (lambda (digit-list)
    (poly-value (digits->poly digit-list) 2)))  

; - End Program -

; - Program 5.18, pg. 158 -

(define poly->digits
  (lambda (poly)
    (letrec
      ((convert
         (lambda (p deg)
           (cond
             ((zero? deg) (list (leading-coef p)))
             ((= (degree p) deg)
              (cons (leading-coef p)
                    (convert (rest-of-poly p) (sub1 deg))))
             (else
              (cons 0 (convert p (sub1 deg))))))))
      (convert poly (degree poly)))))

; - End Program -

; - Program 5.20, pg. 160 -

(define decimal->binary
  (lambda (num)
    (letrec
      ((dec->bin
         (lambda (n deg)
           (if (zero? n)
               the-zero-poly
               (p+ (make-term deg (remainder n 2))
                   (dec->bin (quotient n 2) (add1 deg)))))))
      (poly->digits (dec->bin num 0)))))

; - End Program -
; - Program 6.1, pg. 165 -

(define string-insert
  (lambda (insrt strng n)
    (string-append
      (substring strng 0 n)
      insrt
      (substring strng n (string-length strng)))))

; - End Program -

; - Exercise 6.4, pg. 167 -

(define mystery
  (lambda (pos-int)
    (letrec ((helper
               (lambda (n count)
                 (cond
                   ((= n 1) 
                    (newline)
                    (writeln "It took " count " steps to get to 1."))
                   ((even? n)
                    (writeln count 
                      ". We divide " n " by 2.")
                    (helper (/ n 2) (add1 count)))
                   (else 
                    (writeln count
                      ". We multiply " n " by 3 and add 1.")
                    (helper (+ (* n 3) 1) (add1 count)))))))
      (helper pos-int 0))))

; - End Exercise -

; - Program 6.2, pg. 169 -

(define square-root
  (lambda (a)
    (letrec 
      ((next-estimate 
         (lambda (u)
           (let ((v (/ (+ u (/ a u)) 2)))
             (if (close-enough? u v)
                 v
                 (next-estimate v))))))
      (next-estimate 1))))

; - End Program -  

; - Program 6.3, pg. 171 -

(define square-root-display
  (lambda (a)
    (letrec ((next-estimate (lambda (u)
                              (let ((v (/ (+ u (/ a u)) 2)))
                                (if (close-enough? u v)
                                    v
                                    (begin
                                      (display v)
                                      (newline)
                                      (next-estimate v)))))))
      (next-estimate 1)))) 

; - End Program -

; - Program 6.5, pg. 172 -

(define round-n-places
  (lambda (n dec-num)
    (let ((scale-factor (expt 10 n)))
      (/ (round (* dec-num scale-factor)) scale-factor)))) 

; - End Program -

; - Program 6.6, pg. 174 -

(define read-demo
  (lambda ()
    (display "Enter data (enter done when finished): ")
    (let ((response (read)))
      (cond
        ((eq? response 'done) (display "Thank you. Good-bye."))
        (else (display "You entered: ")
              (write response)
              (newline)
              (read-demo))))))

; - End Program -

; - Program 6.7, pg. 175 -

(define interactive-square-root
  (lambda ()
    (writeln "Enter the number whose square root you want,"
             " or enter done to quit:")
    (let ((n (read)))
      (if (eqv? n 'done)
          (writeln "That's all, folks.")
          (begin
            (writeln "The square root of " n " is " (square-root n))
            (newline)
            (interactive-square-root))))))

; - End Program -

; - Program 6.9, pg. 181 -

(define tower-of-hanoi
  (lambda (n)
    (letrec 
      ((move 
         (lambda (n source destination helper)
           (if (= n 1) 
               (list (list source destination))
               (append
                 (move (sub1 n) source helper destination)
                 (cons
                   (list source destination)
                   (move (sub1 n) helper destination source)))))))
      (move n 'L 'R 'C))))

; - End Program -

; - Program 6.10, pg. 182 -

(define display-tower-of-hanoi
  (let ((show-move (lambda (s d) 
                     (display s)
                     (display " -> ")
                     (display d))))
    (lambda (n)
      (letrec 
        ((move 
           (lambda (n source destination helper)
             (if (= n 1) 
                 (begin
                   (show-move source destination) 
                   (newline))
                 (begin
                   (move (sub1 n) source helper destination)
                   (show-move source destination)
                   (display ", ")
                   (move (sub1 n) helper destination source))))))
        (move n 'L 'R 'C)))))

; - End Program -

; - Program 6.12, pg. 184 -

(define legal?
  (lambda (try legal-pl)
    (letrec
      ((good?
         (lambda (new-pl up down)
           (cond
             ((null? new-pl) #t)
             (else (let ((next-pos (car new-pl)))
                     (and
                       (not (= next-pos try))
                       (not (= next-pos up))
                       (not (= next-pos down))
                       (good? (cdr new-pl) 
                              (add1 up) 
                              (sub1 down)))))))))
      (good? legal-pl (add1 try) (sub1 try)))))

(define solution?
  (lambda (legal-pl)
    (= (length legal-pl) 8)))

(define fresh-try 8)

; - End Program -

; - Program 6.13, pg. 185 -

(define build-solution
  (lambda (legal-pl)
    (cond
      ((solution? legal-pl) legal-pl)
      (else (forward fresh-try legal-pl)))))

; - End Program -

; - Program 6.14, pg. 186 -

(define forward
  (lambda (try legal-pl)
    (cond
      ((zero? try) (backtrack legal-pl))
      ((legal? try legal-pl) (build-solution (cons try legal-pl)))
      (else (forward (sub1 try) legal-pl)))))

; - End Program -

; - Program 6.15, pg. 186 -

(define backtrack
  (lambda (legal-pl)
    (cond
      ((null? legal-pl) '())
      (else (forward (sub1 (car legal-pl)) (cdr legal-pl))))))

; - End Program -

; - Program 6.16, pg. 188 -

(define searcher
  (lambda (legal? solution? fresh-try)
    (letrec 
      ((build-solution
         (lambda (legal-pl)
           (cond
             ((solution? legal-pl) legal-pl)
             (else (forward fresh-try legal-pl)))))
       (forward
         (lambda (try legal-pl)
           (cond
             ((zero? try) (backtrack legal-pl))
             ((legal? try legal-pl) 
              (build-solution (cons try legal-pl)))
             (else (forward (sub1 try) legal-pl)))))
       (backtrack
         (lambda (legal-pl)
           (cond
             ((null? legal-pl) '())
             (else 
               (forward (sub1 (car legal-pl)) (cdr legal-pl))))))
       (build-all-solutions
         (lambda ()
           (letrec
             ((loop (lambda (sol)
                      (cond
                        ((null? sol) '())
                        (else (cons sol (loop (backtrack sol))))))))
             (loop (build-solution '()))))))
      (build-all-solutions))))

; - End Program -

; - Exercise 6.16, pg. 191 -

(define blanks
  (lambda (n)
    (cond
      ((zero? n) "")
      (else (string-append " " (blanks (sub1 n)))))))

; - End Exercise -
; - Program 7.1, pg. 196 -

(define map
  (lambda (proc ls)
    (if (null? ls)
        '()
        (cons (proc (car ls)) (map proc (cdr ls))))))

; - End Program -

; - Program 7.2, pg. 197 -

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

; - End Program -

; - Program 7.3, pg. 198 -

(define add
  (letrec ((list-add
             (lambda (ls)
               (if (null? ls)
                   0
                   (+ (car ls) (list-add (cdr ls)))))))
    (lambda args
      (list-add args))))

; - End Program -

; - Program 7.4, pg. 199 -

(define list (lambda args args))

; - End Program -

; - Program 7.5, pg. 199 -

(define writeln
  (lambda args
    (for-each display args)
    (newline)))

; - End Program -

; - Program 7.6, pg. 199 -

(define error
  (lambda args
    (display "Error:")
    (for-each (lambda (value) (display " ") (display value)) args)
    (newline)
    (reset)))

; - End Program -

; - Program 7.7, pg. 200 -

(define add
  (lambda args
    (if (null? args)
        0
        (+ (car args) (apply add (cdr args))))))

; - End Program -

; - Program 7.8, pg. 201 -

(define compose
  (lambda (f g)
    (lambda (x)
      (f (g x))))) 

; - End Program -

; - Program 7.9, pg. 203 -

(define plus
  (lambda (x y)
    (if (zero? y)
        x
        (add1 (plus x (sub1 y)))))) 

; - End Program -

; - Program 7.10, pg. 203 -

(define times
  (lambda (x y)
    (if (zero? y)
        0
        (plus x (times x (sub1 y)))))) 

; - End Program -

; - Program 7.11, pg. 203 -

(define exponent
  (lambda (x y)
    (if (zero? y)
        1
        (times x (exponent x (sub1 y))))))  

; - End Program -

; - Program 7.12, pg. 203 -

(define super
  (lambda (x y)
    (if (zero? y)
        1
        (exponent x (super x (sub1 y))))))  

; - End Program -

; - Program 7.13, pg. 204 -

(define superduper
  (lambda (x y)
    (if (zero? y)
        1
        (super x (superduper x (sub1 y)))))) 

; - End Program -

; - Program 7.14, pg. 204 -

(define super-order
  (lambda (n)
    (cond
      ((= n 1) plus)
      ((= n 2) times)
      (else (lambda (x y)
              (cond
                ((zero? y) 1)
                (else ((super-order (sub1 n))
                       x
                       ((super-order n) x (sub1 y))))))))))

; - End Program -

; - Program 7.15, pg. 205 -

(define ackermann
  (lambda (n)
    ((super-order n) n n))) 

; - End Program -

; - Exercise 7.5, pg. 206 -

(define iota
  (lambda (n)
    (letrec ((iota-helper
               (lambda (k acc)
                 (cond
                   ((zero? k) (cons 0 acc))
                   (else (iota-helper (sub1 k) (cons k acc)))))))
      (iota-helper (sub1 n) '()))))

(define mystery
  (lambda (len base)
    (letrec
      ((mystery-help
         (lambda (n s)
           (if (zero? n)
               (list s)
               (let ((h (lambda (x) 
                          (mystery-help (sub1 n) (cons x s)))))
                 (apply append (map h (iota base))))))))
      (mystery-help len '()))))

; - End Exercise -

; - Exercise 7.8, pg. 208 -

(define andmap
  (lambda (pred ls)
    (reduce (lambda (x y) (and x y)) (map pred ls))))

; - End Exercise -

; - Exercise 7.10, pg. 209 -

(define ormap
  (lambda (pred ls)
    (if (null? ls) 
        #f 
        (or (pred (car ls)) (ormap pred (cdr ls))))))

; - End Exercise -

; - Program 7.16, pg. 212 -

(define member?-c
  (lambda (item) 
    (letrec ((helper
               (lambda (ls)
                 (if (null? ls)
                     #f
                     (or (equal? (car ls) item)                   
                         (helper (cdr ls)))))))
      helper)))

; - End Program -

; - Program 7.17, pg. 213 -

(define apply-to-all
  (lambda (proc)
    (letrec
      ((helper
         (lambda (ls)
           (if (null? ls)
               '()
               (cons (proc (car ls)) (helper (cdr ls)))))))
      helper)))

; - End Program -

; - Program 7.18, pg. 213 -

(define sum
  (letrec
    ((helper
       (lambda (ls)
         (if (null? ls)
             0
             (+ (car ls) (helper (cdr ls)))))))
    helper))

; - End Program -

; - Program 7.19, pg. 213 -

(define product
  (letrec
    ((helper
       (lambda (ls)
         (if (null? ls)
             1
             (* (car ls) (helper (cdr ls)))))))
    helper))

; - End Program -

; - Program 7.20, pg. 214 -

(define swapper-m
  (lambda (x y)
    (letrec
      ((helper
         (lambda (ls)
           (cond
             ((null? ls) '())
             ((equal? (car ls) x) (cons y (helper (cdr ls))))
             ((equal? (car ls) y) (cons x (helper (cdr ls))))
             (else (cons (car ls) (helper (cdr ls))))))))
      helper)))

; - End Program -

; - Exercise 7.14, pg. 215 -

(define round-5-places (round-n-places 5))

; - End Exercise -

; - Exercise 7.19, pg. 216 -

(define andmap-c
  (lambda (pred)
    (letrec
      ((and-help 
         (lambda (ls)
           (cond
             ((null? ls) #t)
             (else (and (pred (car ls)) (and-help (cdr ls))))))))
      and-help)))

(define all-positive? (andmap-c positive?))

(define ormap
  (lambda (pred ls)
    ((ormap-c pred) ls)))

(define some-positive? (ormap-c positive?))

; - End Exercise -

; - Exercise 7.20, pg. 217 -

(define divides-by
  (lambda (n)
    (lambda (k)
      (zero? (remainder k n)))))

; - End Exercise -

; - Program 7.23, pg. 221 -

(define flat-recur
  (lambda (seed list-proc)
    (letrec
      ((helper
         (lambda (ls)
           (if (null? ls)
               seed
               (list-proc (car ls) (helper (cdr ls)))))))
      helper)))  

; - End Program -

; - Program 7.24, pg. 222 -

(define filter-in-c
  (lambda (pred)
    (flat-recur 
      '() 
      (lambda (x y)
        (if (pred x)
            (cons x y)
            y)))))  

; - End Program -

; - Program 7.25, pg. 225 -

(define filter-in-all-c
  (lambda (pred)
    (letrec
      ((helper
         (lambda (ls)
           (if (null? ls)
               '()
               (let ((a (car ls))) 
                 (if (or (pair? a) (null? a))
                     (cons (helper a) (helper (cdr ls)))
                     (if (pred a)
                         (cons a (helper (cdr ls)))
                         (helper (cdr ls)))))))))
      helper))) 

; - End Program -

; - Program 7.26, pg. 225 -

(define filter-in-all
  (lambda (pred ls)
    ((filter-in-all-c pred) ls)))   

; - End Program -

; - Program 7.27, pg. 225 -

(define sum-all
  (letrec ((helper
             (lambda (ls)
               (if (null? ls)
                   0
                   (let ((a (car ls))) 
                     (if (or (pair? a) (null? a))
                         (+ (helper a) (helper (cdr ls)))
                         (+ a (helper (cdr ls)))))))))
    helper))  

; - End Program -

; - Program 7.28, pg. 227 -

(define deep-recur
  (lambda (seed item-proc list-proc)
    (letrec
      ((helper
         (lambda (ls)
           (if (null? ls)
               seed
               (let ((c (car ls)))
                 (if (or (pair? c) (null? c))
                     (list-proc (helper c) (helper (cdr ls)))
                     (item-proc c (helper (cdr ls)))))))))
      helper)))

; - End Program -

; - Program 8.1, pg. 232 -

(define both 
  (lambda (pred)
    (lambda (arg1 arg2)
      (and (pred arg1) (pred arg2)))))

; - End Program -

; - Program 8.2, pg. 232 -

(define neither 
  (lambda (pred)
    (lambda (arg1 arg2)
      (not (or (pred arg1) (pred arg2))))))

; - End Program -

; - Program 8.3, pg. 233 -

(define at-least-one 
  (lambda (pred)
    (lambda (arg1 arg2)
      (or (pred arg1) (pred arg2)))))

; - End Program -

; - Program 8.4, pg. 237 -

(define make-set
  (lambda args
    (letrec 
      ((list-make-set
         (lambda (args-list)
           (if (null? args-list) 
               the-empty-set
               (adjoin 
                 (car args-list) 
                 (list-make-set (cdr args-list)))))))
      (list-make-set args))))

; - End Program -

; - Program 8.5, pg. 238 -

(define none
  (lambda (pred)
    (letrec 
      ((test
         (lambda (s)
           (or (empty-set? s)
               (let ((elem (pick s)))
                 (and (not (pred elem))
                      (test ((residue elem) s))))))))
       test)))

; - End Program -

; - Program 8.6, pg. 238 -

(define there-exists
  (lambda (pred)
    (compose not (none pred))))

; - End Program -

; - Program 8.7, pg. 239 -

(define for-all
  (lambda (pred)
    (none (compose not pred))))

; - End Program -

; - Program 8.8, pg. 240 -

(define set-equal
  (lambda (obj1)
    (lambda (obj2)
      (or (and ((neither set?) obj1 obj2)
               (equal? obj1 obj2))
          (and ((both set?) obj1 obj2)
               ((subset obj1) obj2)
               ((subset obj2) obj1))))))

; - End Program -

; - Program 8.9, pg. 241 -

(define element (compose there-exists set-equal))

; - End Program -

; - Program 8.10, pg. 241 -

(define contains
  (lambda (set)
    (lambda (e)
      ((element e) set))))

; - End Program -

; - Program 8.11, pg. 242 -

(define superset
  (lambda (s1)
    (lambda (s2)
      ((for-all (contains s1)) s2))))

; - End Program -

; - Program 8.12, pg. 242 -

(define subset
  (lambda (s1)
    (lambda (s2)
      ((superset s2) s1))))

; - End Program -

; - Program 8.13, pg. 242 -

(define cardinal
  (lambda (s)
    (if (empty-set? s) 
        0
        (let ((elem (pick s)))
          (add1 (cardinal ((residue elem) s)))))))

; - End Program -

; - Program 8.14, pg. 243 -

(define intersection
  (lambda (s1 s2)
    (letrec 
      ((helper
         (lambda (s1)
           (if (empty-set? s1)
               the-empty-set
               (let ((elem (pick s1)))
                 (if ((contains s2) elem) 
                     (adjoin elem (helper ((residue elem) s1)))
                     (helper ((residue elem) s1))))))))
      (helper s1))))

; - End Program -

; - Program 8.15, pg. 244 -

(define union
  (lambda (s1 s2)
    (letrec 
      ((helper
         (lambda (s1)
           (if (empty-set? s1) 
               s2
               (let ((elem (pick s1)))
                 (if (not ((contains s2) elem))
                     (adjoin elem (helper ((residue elem) s1)))
                     (helper ((residue elem) s1))))))))
      (helper s1))))

; - End Program -

; - Program 8.16, pg. 244 -

(define difference
  (lambda (s1 s2)   
    (letrec
      ((helper
         (lambda (s1)
           (if (empty-set? s1) 
               the-empty-set
               (let ((elem (pick s1)))
                 (if (not ((contains s2) elem))
                     (adjoin elem (helper ((residue elem) s1)))
                     (helper ((residue elem) s1))))))))
      (helper s1))))

; - End Program -

; - Program 8.17, pg. 245 -

(define set-builder
  (lambda (pred base-set)
    (letrec 
      ((helper
         (lambda (s)
           (if (empty-set? s) 
               base-set
               (let ((elem (pick s))) 
                 (if (pred elem) 
                     (adjoin elem (helper ((residue elem) s)))
                     (helper ((residue elem) s))))))))
       helper)))

; - End Program -

; - Program 8.19, pg. 246 -

(define family-union
  (lambda (s)
    (if (empty-set? s)
        the-empty-set
        (let ((elem (pick s)))
          (union elem (family-union ((residue elem) s)))))))

; - End Program -

; - Program 8.20, pg. 246 -

(define family-intersection
  (lambda (s)
    (if (empty-set? s)
        the-empty-set
        (letrec
          ((fam-int
             (lambda (s)
               (let ((elem (pick s)))
                 (let ((rest ((residue elem) s)))
                   (if (empty-set? rest)
                        elem
                        (intersection elem (fam-int rest))))))))
          (fam-int s)))))

; - End Program -

; - Program 8.21, pg. 247 -

(define set-map
  (lambda (proc s)
    (if (empty-set? s)
        the-empty-set
        (let ((elem (pick s)))
          (adjoin (proc elem) 
                  (set-map proc ((residue elem) s)))))))

; - End Program -

; - Program 8.22, pg. 247 -

(define list->set
  (lambda (ls)
    (apply make-set ls)))

; - End Program -

; - Program 8.23, pg. 248 -

(define set->list
  (lambda (s)
    (if (empty-set? s)
        '()
        (let ((elem (pick s)))
          (cons elem (set->list ((residue elem) s)))))))

; - End Program -

; - Exercise 8.5, pg. 248 -

(define for-one
  (lambda (pred found-proc not-found-proc)
    (letrec ((test 
               (lambda (s)
                 (if (empty-set? s) 
                     (not-found-proc)
                     (let ((v (pick s)))
                       (if (pred v) 
                           (found-proc v)
                           (test ((residue v) s))))))))
      test)))

; - End Exercise -

; - Exercise 8.6, pg. 249 -

(define superset (compose for-all contains))

; - End Exercise -

; - Program 8.24, pg. 250 -

(define the-empty-set (cons set-tag '()))

(define empty-set?
  (lambda (s)
    (eq? s the-empty-set)))

(define set?
  (lambda (arg)
    (and (pair? arg) (eq? (car arg) set-tag))))

(define pick
  (lambda (s)
    (let ((ls (cdr s)))
      (if (null? ls)
          (error "pick: The set is empty.")
          (list-ref ls (random (length ls)))))))

; - End Program -

; - Program 8.25, pg. 251 -

(define adjoin
  (lambda (elem s)
    (cons set-tag (cons elem (cdr s)))))
    
(define residue
  (lambda (elem)
    (lambda (s)
      (let ((ls (remove elem (cdr s))))
        (cond
          ((null? ls) the-empty-set)
          (else (cons set-tag ls)))))))

; - End Program -

; - Program 8.26, pg. 252 -

(define adjoin
  (lambda (elem s)
    (cond
      ((member? elem (cdr s)) s)
      (else (cons set-tag (cons elem (cdr s)))))))

(define residue
  (lambda (elem)
    (lambda (s)
      (let ((ls (remove-1st elem (cdr s))))
        (cond
          ((null? ls) the-empty-set)
          (else (cons set-tag ls)))))))

; - End Program -

; - Exercise 8.7, pg. 253 -

(define pick
  (lambda (s)
    (car (cdr s))))

; - End Exercise -

; - Program 8.27, pg. 256 -

(define make-op
  (lambda (x y)
    (make-set (make-set x) (make-set x y))))

(define op?
  (lambda (s)
    (and (set? s)
         ((for-all set?) s)
         (= (cardinal (family-intersection s)) 1)
         (or (= (cardinal s) 1)
             ((both (lambda (x) (= (cardinal x) 2)))
              s
              (family-union s))))))

(define op-1st
  (lambda (pr)
    (pick (family-intersection pr))))

(define op-2nd
  (lambda (pr)
    (let ((fam-int (family-intersection pr)))
      (let ((diff (difference (family-union pr) fam-int)))
        (pick (if (empty-set? diff) fam-int diff))))))

; - End Program -

; - Program 8.28, pg. 257 -

(define make-op 
  (lambda (x y)
    (list x y)))

(define op?
  (lambda (arg)
    (and (pair? arg) (pair? (cdr arg)) (null? (cddr arg)))))

(define op-1st 
  (lambda (pr)
    (car pr)))

(define op-2nd
  (lambda (pr)
    (cadr pr)))

; - End Program -

; - Program 8.29, pg. 257 -

(define make-op 
  (lambda (x y)
    (cons x y)))

(define op? 
  (lambda (arg)
    (pair? arg)))

(define op-1st 
  (lambda (pr)
    (car pr)))

(define op-2nd 
  (lambda (pr)
    (cdr pr)))

; - End Program -

; - Program 8.30, pg. 258 -

(define cartesian-product
  (lambda (s1 s2)
    (if (empty-set? s1) 
        the-empty-set
        (let ((elem (pick s1)))
          (union (set-map (lambda (x) (make-op elem x)) s2)
                 (cartesian-product ((residue elem) s1) s2))))))

; - End Program -

; - Program 8.31, pg. 259 -

(define domain
  (lambda (rel)
    (set-map op-1st rel)))

(define range
  (lambda (rel)
    (set-map op-2nd rel)))

; - End Program -

; - Program 8.32, pg. 260 -

(define subrelation/1st
  (lambda (rel)
    (lambda (arg)
      ((set-builder 
         (lambda (x) ((set-equal (op-1st x)) arg)) 
         the-empty-set)
       rel))))

; - End Program -

; - Program 8.33, pg. 260 -

(define function?
  (lambda (rel)
    (or (empty-set? rel)
        (let ((subrel ((subrelation/1st rel) (op-1st (pick rel)))))
          (and (= (cardinal (set-map op-2nd subrel)) 1)
               (function? (difference rel subrel)))))))

; - End Program -

; - Program 8.34, pg. 261 -

(define value
  (lambda (fun)
    (lambda (arg)
      (op-2nd (pick ((subrelation/1st fun) arg))))))

; - End Program -


; - Program 9.1, pg. 269 -

(define view 
  (lambda (vec) 
    (let ((highest-index (sub1 (vector-length vec)))) 
      (letrec ((loop (lambda (i) 
                       (display (vector-ref vec i)) 
                       (if (< i highest-index) 
                           (begin
                             (display " ") 
                             (loop (add1 i))))))) 
        (display "#(") 
        (loop 0) 
        (display ")")))))

; - End Program -

; - Program 9.2, pg. 270 -

(define make-vector 
  (lambda args 
    (let ((fill-value 
            (if (singleton-list? args)
                '() 
                (cadr args)))) 
      ((vector-generator (lambda (i) fill-value)) (car args)))))

; - End Program -

; - Program 9.3, pg. 271 -

(define list->vector 
  (lambda (ls) 
    ((vector-generator (lambda (i) (list-ref ls i))) (length ls))))

; - End Program -

; - Program 9.4, pg. 271 -

(define vector 
  (lambda args
    (list->vector args)))

; - End Program -

; - Program 9.5, pg. 272 -

(define vector-stretch
  (lambda (vec new-size) 
    (let ((size (vector-length vec))) 
      (let ((gen-proc (lambda (i) 
                        (if (< i size) 
                            (vector-ref vec i) 
                            '()))))
        ((vector-generator gen-proc) new-size)))))

; - End Program -

; - Program 9.6, pg. 272 -

(define vector-copy
  (lambda (vec) 
    (vector-stretch vec (vector-length vec))))

; - End Program -

; - Program 9.7, pg. 272 -

(define vector-update
  (lambda (vec k val) 
    (let ((gen-proc (lambda (i) 
                      (if (= i k) 
                          val
                          (vector-ref vec i))))) 
      ((vector-generator gen-proc) (vector-length vec)))))

; - End Program -

; - Program 9.8, pg. 273 -

(define list->vector
  (lambda (ls) 
    (let ((vec (make-vector (length ls)))) 
      (letrec 
        ((convert (lambda (ls* v i) 
                    (if (null? ls*) 
                        v 
                        (let ((new-v (vector-update v i (car ls*))))
                          (convert (cdr ls*) new-v (add1 i))))))) 
        (convert ls vec 0)))))

; - End Program -

; - Program 9.9, pg. 273 -

(define vector-map
  (lambda (proc vec) 
    ((vector-generator (lambda (i) (proc (vector-ref vec i)))) 
     (vector-length vec))))

; - End Program -

; - Program 9.10, pg. 274 -

(define multiply-by-scalar 
  (lambda (c vec) 
    (vector-map (lambda (elem) (* c elem)) vec)))

; - End Program -

; - Program 9.11, pg. 274 -

(define vector-apply-elementwise-to-both 
  (lambda (proc) 
    (lambda (vec1 vec2) 
      (let ((gen-proc 
              (lambda (i) 
                (proc (vector-ref vec1 i) (vector-ref vec2 i))))) 
        ((vector-generator gen-proc) (vector-length vec1))))))

; - End Program -

; - Program 9.12, pg. 275 -

(define vec+ (vector-apply-elementwise-to-both +))

(define vec* (vector-apply-elementwise-to-both *)) 

; - End Program -

; - Program 9.13, pg. 275 -

(define vector-sum
  (lambda (vec) 
    (let ((size (vector-length vec))) 
      (letrec 
        ((helper
           (lambda (i) 
             (if (= i size) 
                 0 
                 (+ (vector-ref vec i) (helper (add1 i))))))) 
        (helper 0)))))

; - End Program -

; - Program 9.14, pg. 276 -

(define vector-product 
  (lambda (vec) 
    (let ((size (vector-length vec)))
      (letrec 
        ((helper 
           (lambda (i) 
             (if (= i size) 
                 1 
                 (* (vector-ref vec i) (helper (add1 i))))))) 
        (helper 0)))))

; - End Program -

; - Program 9.15, pg. 277 -

(define vector-accumulate 
  (lambda (proc seed) 
    (lambda (vec) 
      (let ((size (vector-length vec))) 
        (letrec 
          ((helper 
             (lambda (i) 
               (if (= i size)
                   seed 
                   (proc (vector-ref vec i) (helper (add1 i))))))) 
          (helper 0))))))

; - End Program -

; - Program 9.16, pg. 277 -

(define vector->list (vector-accumulate cons '()))

; - End Program -

; - Program 9.17, pg. 279 -

(define dot-product 
  (lambda (vec1 vec2) 
    (let ((size (vector-length vec1))) 
      (letrec 
        ((loop 
           (lambda (i acc) 
             (if (= i size) 
                 acc 
                 (loop (add1 i) 
                       (+ acc (* (vector-ref vec1 i) 
                                 (vector-ref vec2 i)))))))) 
        (loop 0 0)))))

; - End Program -

; - Program 9.18, pg. 279 -

(define vector?
  (lambda (arg)
    (and (pair? arg) (eq? (car arg) vector-tag))))

(define vector-length
  (lambda (vec)
    (car (cdr vec))))

; - End Program -

; - Program 9.19, pg. 280 -

(define vector-ref
  (lambda (vec i)
    ((cddr vec) i)))  

(define vector-generator
  (lambda (gen-proc)
    (lambda (size)
      (cons vector-tag (cons size gen-proc))))) 

; - End Program -

; - Program 9.20, pg. 280 -

(define vector-ref
  (lambda (vec i)
    (list-ref (cddr vec) i)))

(define vector-generator
  (lambda (gen-proc)
    (lambda (size)
      (cons vector-tag
            (cons size
                  (letrec
                    ((loop (lambda (i)
                             (cond
                               ((= i size) '())
                               (else (cons (gen-proc i) 
                                           (loop (add1 i))))))))
                    (loop 0)))))))  

; - End Program -

; - Program 9.21, pg. 283 -

(define vector-generator
  (lambda (gen-proc)
    (lambda (size)
      (let ((vec (make-vector size)))
        (letrec
          ((loop (lambda (i)
                   (if (< i size)
                       (begin
                         (vector-set! vec i (gen-proc i))
                         (loop (add1 i)))))))
          (loop 0))
        vec))))

; - End Program -

; - Program 9.22, pg. 283 -

(define vector-update!
  (lambda (vec i c) 
    (vector-set! vec i c) 
    vec))

; - End Program -

; - Program 9.23, pg. 284 -

(define list->vector
  (lambda (ls)
    (let ((vec (make-vector (length ls))))
      (letrec
        ((convert
           (lambda (ls i)
             (if (not (null? ls))
                 (begin
                   (vector-set! vec i (car ls))
                   (convert (cdr ls) (add1 i)))))))
        (convert ls 0))
      vec)))

; - End Program -

; - Program 9.24, pg. 286 -

(define vector-reverse 
  (lambda (vec) 
    (letrec 
      ((switch 
         (lambda (v i j)
           (if (>= i j) 
               v 
               (let ((swapv (swap-maker v))) 
                 (switch (swapv i j) (add1 i) (sub1 j))))))) 
      (switch vec 0 (sub1 (vector-length vec))))))

; - End Program -

; - Program 9.25, pg. 286 -

(define swap-maker 
  (lambda (vec) 
    (lambda (index1 index2) 
      (let ((temp (vector-ref vec index1))) 
        (vector-update 
          (vector-update vec index1 (vector-ref vec index2)) 
          index2 
          temp)))))

; - End Program -

; - Program 9.26, pg. 287 -

(define vector-reverse!
  (lambda (vec)
    (let ((swapv! (swap-maker vec)))
      (letrec 
        ((switch (lambda (i j)
                   (if (< i j)
                       (begin
                         (swapv! i j)
                         (switch (add1 i) (sub1 j)))))))
        (switch 0 (sub1 (vector-length vec))))
      vec)))

; - End Program -

; - Program 9.27, pg. 288 -

(define swap-maker
  (lambda (vec)
    (lambda (index1 index2)
      (let ((temp (vector-ref vec index1)))
        (vector-update!
          (vector-update! vec index1 (vector-ref vec index2))
          index2
          temp)))))

; - End Program -

; - Program 9.30, pg. 293 -

(define num-cols
  (lambda (mat)
    (let ((size (sub1 (vector-length mat))))
      (vector-ref mat size))))

; - End Program -

; - Program 9.31, pg. 294 -

(define num-rows
  (lambda (mat)
    (let ((size (sub1 (vector-length mat))))
      (/ size (vector-ref mat size)))))

; - End Program -

; - Program 9.32, pg. 294 -

(define matrix-ref
  (lambda (mat)
    (let ((ncols (num-cols mat)))
      (lambda (i j)
        (vector-ref mat (+ (* i ncols) j))))))

; - End Program -

; - Program 9.33, pg. 295 -

(define matrix-generator
  (lambda (gen-proc)
    (lambda (nrows ncols)
      (let ((size (* nrows ncols)))
        (let ((vec-gen-proc
                (lambda (k) 
                  (if (< k size)
                      (gen-proc (quotient k ncols) 
                                (remainder k ncols))
                      ncols))))
          ((vector-generator vec-gen-proc) 
           (add1 size)))))))

; - End Program -

; - Program 9.34, pg. 296 -

(define row-of 
  (lambda (mat)
    (let ((mat-ref (matrix-ref mat))
          (number-of-columns (num-cols mat)))
      (lambda (i)
        (let ((gen-proc (lambda (j) (mat-ref i j))))
          ((vector-generator gen-proc) number-of-columns))))))

; - End Program -

; - Program 9.35, pg. 296 -

(define column-of
  (lambda (mat)
    (let ((mat-ref (matrix-ref mat))
          (number-of-rows (num-rows mat)))
      (lambda (j)
        (let ((gen-proc (lambda (i) (mat-ref i j))))
          ((vector-generator gen-proc) number-of-rows))))))

; - End Program -

; - Program 9.37, pg. 297 -

(define matrix-transpose
  (lambda (mat)
    (let ((mat-ref (matrix-ref mat)))
      (let ((gen-proc (lambda (i j) (mat-ref j i))))
        ((matrix-generator gen-proc) 
         (num-cols mat) 
         (num-rows mat))))))

; - End Program -

; - Program 9.38, pg. 299 -

(define matrix-product
  (lambda (mat-a mat-b)
    (let ((ncols-a (num-cols mat-a))
          (a-ref (matrix-ref mat-a))
          (b-ref (matrix-ref mat-b)))
      (if (not (= ncols-a (num-rows mat-b)))
          (error "matrix-product:"
            "The matrices are not compatible.")
          (let 
            ((gen-proc 
               (lambda (i j)
                 (letrec 
                   ((loop 
                      (lambda (r acc)
                        (if (= r ncols-a)
                            acc
                            (loop (add1 r) 
                                  (+ acc (* (a-ref i r) 
                                            (b-ref r j))))))))
                   (loop 0 0)))))           
            ((matrix-generator gen-proc) 
             (num-rows mat-a) (num-cols mat-b)))))))

; - End Program -

; - Program 9.39, pg. 300 -

(define matrix-set!
  (lambda (mat)
    (let ((ncols (num-cols mat)))
      (lambda (i j obj)
        (vector-set! mat (+ (* i ncols) j) obj)))))

; - End Program -


; - Program 10.1, pg. 304 -

(define insertsort 
  (lambda (ls)
    (if (singleton-list? ls) 
        ls 
        (insert (car ls) (insertsort (cdr ls)))))) 

; - End Program -

; - Program 10.2, pg. 304 -

(define insert
  (lambda (a ls) 
    (cond
      ((null? ls) (cons a '()))
      ((< a (car ls)) (cons a ls))
      (else (cons (car ls) (insert a (cdr ls))))))) 

; - End Program -

; - Program 10.5, pg. 306 -

(define vector-insertsort!  
  (lambda (v) 
    (let ((size (vector-length v)))
      (letrec ((sortloop (lambda (k) 
                           (if (< k size) 
                               (begin 
                                 (vector-insert! k v) 
                                 (sortloop (add1 k))))))) 
        (sortloop 1))))) 

; - End Program -

; - Program 10.6, pg. 307 -

(define vector-insert!  
  (lambda (k vec) 
    (let ((val (vector-ref vec k)))
      (letrec ((insert-h 
                 (lambda (m) 
                   (if (zero? m) 
                       (vector-set! vec 0 val)
                       (let ((comp (vector-ref vec (sub1 m)))) 
                         (if (< val comp) 
                             (begin
                               (vector-set! vec m comp) 
                               (insert-h (sub1 m))) 
                             (vector-set! vec m val))))))) 
        (insert-h k))))) 

; - End Program -

; - Program 10.7, pg. 310 -

(define make-groups 
  (lambda (ls) 
    (cond 
      ((null? ls) '()) 
      ((null? (cdr ls)) (list ls)) 
      (else (let ((a (car ls)) 
                  (gp (make-groups (cdr ls)))) 
              (if (< (cadr ls) a) 
                  (cons (list a) gp) 
                  (cons (cons a (car gp)) (cdr gp)))))))) 

; - End Program -

; - Program 10.8, pg. 311 -

(define pair-merge 
  (lambda (sublists) 
    (cond 
      ((null? sublists) '()) 
      ((null? (cdr sublists)) sublists) 
      (else (cons (merge (car sublists) (cadr sublists))
                  (pair-merge (cddr sublists))))))) 

; - End Program -

; - Program 10.9, pg. 311 -

(define nat-mergesort
  (lambda (ls) 
    (if (null? ls) 
        '() 
        (letrec ((sort (lambda (gps) 
                         (if (null? (cdr gps))
                             (car gps) 
                             (sort (pair-merge gps)))))) 
          (sort (make-groups ls)))))) 

; - End Program -

; - Program 10.10, pg. 313 -

(define vector-merge!
  (lambda (newvec vec)
    (lambda (left top-left right top-right)
      (letrec
        ((mergeloop
           (lambda (left right i)
             (cond
               ((and (< left top-left) (< right top-right))
                (if (< (vector-ref vec left) (vector-ref vec right))
                    (begin
                      (vector-set! newvec i (vector-ref vec left))
                      (mergeloop (add1 left) right (add1 i)))
                    (begin
                      (vector-set! newvec i (vector-ref vec right))
                      (mergeloop left (add1 right) (add1 i)))))
               ((< left top-left)
                (vector-set! newvec i (vector-ref vec left))
                (mergeloop (add1 left) right (add1 i)))
               ((< right top-right)
                (vector-set! newvec i (vector-ref vec right))
                (mergeloop left (add1 right) (add1 i)))))))
        (mergeloop left right left)))))

; - End Program -

; - Program 10.11, pg. 314 -

(define vector-mergesort!
  (lambda (vec1)
    (let ((vec-size (vector-length vec1)))
      (let ((adjust (lambda (k) (min k vec-size)))
            (vec2 (make-vector vec-size))
            (max-index (sub1 vec-size)))
        (letrec 
          ((merge-pass
             (lambda (group-size count)
               (if (> group-size max-index)
                   (if (even? count) (vector-change! vec1 0 max-index vec2))
                   (let ((newvec (if (odd? count) vec2 vec1))
                         (vec (if (odd? count) vec1 vec2)))
                     (let ((merge! (vector-merge! newvec vec)))
                       (letrec 
                         ((group-ends
                            (lambda (left top-left right top-right)
                              (if (<= left max-index)
                                  (begin
                                    (merge! left top-left right top-right)
                                    (let ((new-right (+ top-right group-size)))
                                      (group-ends 
                                        top-right 
                                        (adjust new-right)
                                        new-right
                                        (adjust
                                          (+ new-right group-size)))))))))
                         (group-ends 0 (adjust group-size) 
                           group-size (adjust (* 2 group-size)))))
                     (merge-pass (* group-size 2) (add1 count)))))))
          (merge-pass 1 1))))))

; - End Program -

; - Program 10.12, pg. 315 -

(define vector-change!
  (lambda (vec1 j k vec2)
    (letrec ((loop (lambda (i)
                     (if (<= i k)
                         (begin
                           (vector-set! vec1 i (vector-ref vec2 i))
                           (loop (add1 i)))))))
      (loop j))))

; - End Program -

; - Program 10.13, pg. 317 -

(define quicksort
  (letrec
    ((collect
       (lambda (pivot ls lgroup rgroup)
         (if (null? ls)
             (append (quicksort lgroup) (cons pivot (quicksort rgroup)))
             (if (< pivot (car ls))
                 (collect pivot (cdr ls) lgroup (cons (car ls) rgroup))
                 (collect pivot (cdr ls) (cons (car ls) lgroup) rgroup))))))
    (lambda (ls)
      (if (or (null? ls) (null? (cdr ls)))
          ls
          (collect (car ls) (cdr ls) '() '())))))

; - End Program -

; - Program 10.14, pg. 320 -

(define vector-quicksort!
  (lambda (v)
    (letrec 
      ((qsort (lambda (low high)
                (if (< low high)
                    (let ((middle (partition v low high)))
                      (qsort low (sub1 middle))
                      (qsort (add1 middle) high))))))
      (qsort 0 (sub1 (vector-length v))))))

; - End Program -

; - Program 10.15, pg. 321 -

(define partition
  (lambda (v low high)
    (let ((pivot (vector-ref v low)))
      (letrec 
        ((search
           (lambda (left right)
             (letrec 
               ((search-up
                  (lambda (i)
                    (cond
                      ((= i (add1 right)) (sub1 i))
                      ((> (vector-ref v i) pivot) i)
                      (else (search-up (add1 i))))))
                (search-down 
                  (lambda (i)
                    (cond
                      ((or (= i (sub1 left)) (< (vector-ref v i) pivot)) i)
                      (else (search-down (sub1 i)))))))
               (let ((new-left (search-up left))
                     (new-right (search-down right)))
                 (if (< new-left new-right)
                     (begin
                       (vector-swap! v new-left new-right)
                       (search (add1 new-left) (sub1 new-right)))
                     (begin
                       (vector-swap! v low new-right)
                       new-right)))))))
        (search (add1 low) high)))))

; - End Program -

; - Program 10.16, pg. 321 -

(define vector-swap!
  (lambda (vec i j)
    (let ((temp (vector-ref vec i)))
      (vector-set! vec i (vector-ref vec j))
      (vector-set! vec j temp))))

; - End Program -

; - Program 10.18, pg. 324 -

(define random-list
  (lambda (n)
    (letrec ((build-list
               (lambda (k)
                 (if (zero? k)
                     '()
                     (cons (random n) (random-list (sub1 n)))))))
      (build-list n))))

; - End Program -

; - Program 10.19, pg. 325 -

; - If you are using PC-Scheme, replace (time-of-day) by (runtime). -
; - If you are using MacScheme, replace (time-of-day) by (time). -
; - If you are using Chez Scheme, replace (time-of-day) by (real-time)
      to get the actual elapsed time, or (cpu-time) for the cpu elapsed
      time. -
; - Most other Scheme systems have some timing mechanism that can be 
      used in place of (time-of-day). -

(define timer
  (lambda (proc arg)
    (let ((start (time-of-day)))
      (let ((val (proc arg)))
        (let ((finish (time-of-day)))
          (let ((elapsed-time (/ (- finish start) 100)))
            (writeln "Time = " elapsed-time ", Answer = " val)))))))

; - End Program -

; - Program 10.22, pg. 331 -

(define binary-search
  (lambda (rel?)
    (lambda (vec target)
      (letrec
        ((search 
           (lambda (left right)
             (if (< right left)
                 (writeln "The search failed.")
                 (let ((middle (floor (/ (+ left right) 2))))
                   (let ((mid-val (vector-ref vec middle)))
                     (cond 
                       ((rel? target mid-val) 
                        (search left (sub1 middle)))
                       ((rel? mid-val target) 
                        (search (add1 middle) right))
                       (else middle))))))))
         (search 0 (sub1 (vector-length vec)))))))

; - End Program -

; - Program 10.23, pg. 333 -

(define unlist
  (lambda (proc)
    (lambda (ls)
      (apply proc ls))))

; - End Program -

; - Program 10.25, pg. 337 -

(define find-supervisor
  (unlist
    (lambda (name id age yr-emp supervisor salary)
      (lambda (v) (if (string=? name v) supervisor #f)))))

; - End Program -

; - Program 10.26, pg. 338 -

(define closest-common-supervisor
  (letrec
    ((find-ccs
       (lambda (path1 path2)
         (let ((rest1 (cdr path1)) (rest2 (cdr path2)))
           (if (string=? (car rest1) (car rest2))
               (find-ccs rest1 rest2)
               (car path1))))))
    (lambda (test-procedure) 
      (lambda (table)
        (letrec 
          ((build-path
             (lambda (tbl u)
               (if (empty-set? tbl)
                   (list u)
                   (let ((next (pick tbl)))
                     (let ((v ((test-procedure next) u)))
                       (if (not v)
                           (build-path ((residue next) tbl) u)
                           (cons u (build-path table v)))))))))
          (lambda (x y)
            (find-ccs 
              (reverse (build-path table x))
              (reverse (build-path table y)))))))))

; - End Program -


; - Program 11.1, pg. 344 -

(define stk '())

(define empty? 
  (lambda () 
    (null? stk)))

(define top 
  (lambda () 
    (if (empty?)
        (error "top: The stack is empty.")
        (car stk))))

(define print-stack 
  (lambda () 
    (display "TOP: ")
    (for-each (lambda (x) (display x) (display " ")) stk)
    (newline)))

(define push! 
  (lambda (a) 
    (set! stk (cons a stk))))

(define pop! 
  (lambda () 
    (if (empty?)
        (error "pop!: The stack is empty.")
        (set! stk (cdr stk)))))

; - End Program -

; - Program 11.2, pg. 346 -

(define lookup   
  (lambda (obj table success-proc failure-proc)
    (letrec ((lookup (lambda (table)
                       (if (null? table)
                           (failure-proc)
                           (let ((pr (car table)))
                             (if (equal? (car pr) obj)
                                 (success-proc pr)
                                 (lookup (cdr table))))))))
      (lookup table))))        

; - End Program -

; - Program 11.3, pg. 347 -

(define assoc
  (lambda (obj table)
    (lookup obj table (lambda (pr) pr) (lambda () #f))))

; - End Program -

; - Program 11.4, pg. 347 -

(define memoize
  (lambda (proc)
    (let ((table '()))
      (lambda (arg)
        (lookup arg table 
          (lambda (pr) (cdr pr))
          (lambda ()
            (let ((val (proc arg)))
              (set! table (cons (cons arg val) table))
              val)))))))

; - End Program -

; - Program 11.5, pg. 348 -

(define memo-fib
  (memoize (lambda (n)
             (if (< n 2)
                 n
                 (+ (memo-fib (- n 1))
                    (memo-fib (- n 2)))))))  

; - End Program -

; - Program 11.6, pg. 350 -

(define vector-memoize
  (lambda (max-arg)
    (lambda (proc)
      (let ((table (make-vector (add1 max-arg) '())))
        (lambda (arg)
          (if (> arg max-arg)
              (proc arg)
              (let ((item-stored (vector-ref table arg)))
                (if (pair? item-stored)
                    (car item-stored)
                    (let ((val (proc arg)))
                      (vector-set! table arg (list val))
                      val)))))))))

; - End Program -

; - Program 11.7, pg. 352 -

(define member?
  (lambda (item ls)
    (let ((goto (lambda (label)
                  (label))))
      (letrec
        ((start
           (lambda ()
             (cond
               ((null? ls) #f)
               ((equal? (car ls) item) #t)
               (else (goto reduce)))))
         (reduce
           (lambda ()
             (set! ls (cdr ls))
             (goto start))))
        (goto start)))))

; - End Program -

; - Program 11.8, pg. 353 -

(define while-proc
  (lambda (pred-th body-th)
    (letrec ((loop (lambda ()
                     (if (pred-th) 
                         (begin 
                           (body-th) 
                           (loop))))))
      (loop))))

; - End Program -

; - Program 11.9, pg. 355 -

(define swapper
  (lambda (a b ls)
    (let ((ls* ls) (ans '()))
      (while-proc
        (lambda () (not (null? ls*)))
        (lambda ()
          (cond
            ((equal? (car ls*) a) (push! b))
            ((equal? (car ls*) b) (push! a))
            (else (push! (car ls*))))
;         (print-stack)
          (set! ls* (cdr ls*))))
      (while-proc
        (lambda () (not (empty?)))
        (lambda ()
          (set! ans (cons (top) ans))
;         (writeln "Answer = " ans)
          (pop!)
;         (print-stack)
                       ))
      ans)))

; - End Program -

; - Program 11.11, pg. 359 -

(define mystery
  (lambda (a b ls)
    (let ((ls* ls) (ans '()) (goto (lambda (label) (label))))
      (letrec
        ((push
           (lambda ()
             (cond
               ((null? ls*) (goto pop))
               ((eq? (car ls*) a) (push! b) (goto reduce))
               ((eq? (car ls*) b) (push! a) (goto reduce))
               (else (push! (car ls*)) (goto reduce)))))
         (reduce
           (lambda ()
             (set! ls* (cdr ls*))
             (goto push)))
         (pop
           (lambda ()
             (cond
               ((empty?) ans)
               (else
                 (set! ans (cons (top) ans))
                 (pop!)
                 (goto pop))))))
        (goto push)))))

; - End Program -

; - Program 11.21, pg. 368 -

(define last-pair
  (lambda (x)
    (if (pair? (cdr x))
        (last-pair (cdr x))
        x)))  

; - End Program -

; - Program 11.22, pg. 368 -

(define append!
  (lambda (ls1 ls2)
    (if (pair? ls1)
        (begin
          (set-cdr! (last-pair ls1) ls2)
          ls1)
        ls2)))

; - End Program -

; - Exercise 11.14, pg. 371 -

(define mystery
  (lambda(x)
    (let ((box (last-pair x)))
      (set-cdr! box x)
      x)))

; - End Exercise -

; - Exercise 11.16, pg. 371 -

(define efface
  (lambda (x ls)
    (cond
      ((null? ls) '())
      ((equal? (car ls) x) (cdr ls))
      (else (let ((z (efface x (cdr ls))))
              (set-cdr! ls z)
              ls)))))

(define test-efface
  (lambda ()
    (let ((x (cons 1 '())))
      (let ((y (cons 2 x)))
        (let ((z (cons 3 y)))
          (let ((a (cons 4 z)) (a* (cons 40 z)))
            (let ((b (cons 5 a)) (b* (cons 50 a)))
              (let ((c (cons 6 b)) (c* (cons 60 b)))
                (writeln x y z a a* b b* c c*)
                (efface 3 c)
                (writeln x y z a a* b b* c c*)))))))))

; - End Exercise -

; - Exercise 11.17, pg. 372 -

(define test-efface2
  (lambda ()
    (let ((ls (list 5 4 3 2 1)))
      (writeln (efface 3 ls))
      ls)))

(define test-efface3
  (lambda ()
    (let ((ls (list 5 4 3 2 1)))
      (writeln (efface 5 ls))
      ls)))

; - End Exercise -

; - Exercise 11.18, pg. 372 -

(define smudge
  (lambda (x ls)
    (letrec
      ((smudge/x
         (lambda (ls*)
           (cond
             ((null? (cdr ls*)) ls*)
             ((equal? (car ls*) x) (shift-down ls* (cdr ls*)))
             (else (smudge/x (cdr ls*)))))))
      (if (null? ls) 
          ls
          (begin
            (smudge/x ls)
            ls)))))

(define shift-down
  (lambda (box1 box2)
    (set-car! box1 (car box2))
    (set-cdr! box1 (cdr box2))))

(define test-smudge
  (lambda ()
    (let ((x (cons 1 '())))
      (let ((y (cons 2 x)))
        (let ((z (cons 3 y)))
          (let ((a (cons 4 z)) (a* (cons 40 z)))
            (let ((b (cons 5 a)) (b* (cons 50 a)))
              (let ((c (cons 6 b)) (c* (cons 60 b)))
                (writeln x y z a a* b b* c c*)
                (smudge 3 c)
                (writeln x y z a a* b b* c c*)))))))))

; - End Exercise -

; - Exercise 11.19, pg. 373 -

(define *seen-pairs* '())

(define count-pairs
  (lambda (pr)
    (if (dont-count? pr) 
        0
        (begin
          (set! *seen-pairs* (cons pr *seen-pairs*))
          (add1 (+ (count-pairs (car pr)) 
                   (count-pairs (cdr pr))))))))

(define dont-count?
  (lambda (s)
    (or (not (pair? s)) (member? s *seen-pairs*))))

(define test-count-pairs
  (lambda ()
    (let ((x (cons 'a (cons 'b (cons 'c '())))))
      (let ((y (cons x (cons x (cons x x)))))
        (set-cdr! (last-pair x) x)
        (writeln (count-pairs y))
        (count-pairs y)))))

(define count-pairs
  (lambda (pr)
    (count-pairs/seen pr '())))

; - End Exercise -

; - Exercise 11.20, pg. 375 -

(define reconfigure
  (lambda (tape character direction)
    (if (eq? direction 'left)
        (left (overwrite character tape))
        (right (overwrite character tape)))))

(define at
  (lambda (tape)
    (let ((right-part (2nd tape)))
      (car right-part))))

(define overwrite
  (lambda (char tape)
    (let ((left-part (1st tape)) (right-part (2nd tape)))
      (let ((new-right-part (cons char (cdr right-part))))
        (list left-part new-right-part)))))

(define right
  (lambda (tape)
    (let ((left-part (1st tape)) (right-part (2nd tape)))
      (let ((new-left-part (cons (car right-part) left-part))
            (new-right-part (cdr right-part)))
        (list new-left-part (check-null new-right-part))))))

(define check-null
  (lambda (part)
    (if (null? part)
        (list 0)
        part)))

(define test-reconfigure
  (lambda ()
    (let ((tape1 (list (list 'a 'b 'c 0) (list 'x 'y 0))))
      (let ((tape2 (reconfigure tape1 'u 'right))
            (tape3 (reconfigure tape1 'd 'left)))
        (let ((tape4 (reconfigure tape2 'v 'right))
              (tape5 (reconfigure tape3 'e 'left)))
          (let ((tape6 (reconfigure tape4 'w 'right))
                (tape7 (reconfigure tape5 'f 'left)))
            (let ((tape8 (reconfigure tape6 'x 'right))
                  (tape9 (reconfigure tape7 'g 'left)))
              (list tape8 tape9))))))))

; - End Exercise -

; - Exercise 11.22, pg. 378 -

(define shifter
  (letrec
    ((shift-to-0
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 0) tape)
             (else (shift-to-0 (reconfigure tape c 'right))))))))
    shift-to-0))

(define overwrite
  (lambda (char tape)
    (let ((right-part (2nd tape)))
      (set-car! right-part char)
      tape)))

; - End Exercise -

; - Exercise 11.23, pg. 379 -

(define busy-beaver
  (letrec
    ((loopright
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) 
              (loopright (reconfigure tape 'a 'right)))
             (else (maybe-done (reconfigure tape 'a 'right)))))))
     (maybe-done
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) (reconfigure tape 'a 'right))
             (else (continue (reconfigure tape 'a 'left)))))))
     (continue
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) 
              (maybe-done (reconfigure tape 'a 'left)))
             (else (loopright (reconfigure tape 'a 'right))))))))
    loopright))

(define endless-growth
  (letrec
    ((loop
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 0) 
              (loop (reconfigure tape 'a 'right))))))))
    loop))

(define perpetual-motion
  (letrec
    ((this-way
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) 
              (that-way (reconfigure tape 0 'right)))
             (else (that-way (reconfigure tape 'a 'right)))))))
     (that-way
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) 
              (this-way (reconfigure tape 0 'left)))
             (else (this-way (reconfigure tape 'a 'left))))))))
    this-way))

(define pendulum
  (letrec
    ((loopright
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) 
              (loopright (reconfigure tape 'a 'right)))
             (else (loopleft (reconfigure tape 'a 'left)))))))
     (loopleft
       (lambda (tape)
         (let ((c (at tape)))
           (cond
             ((equal? c 'a) 
              (loopleft (reconfigure tape 'a 'left)))
             (else (loopright (reconfigure tape 'a 'right))))))))
    loopright))

; - End Exercise -

; - Exercise 11.24, pg. 380 -

(define busy-beaver-lines
  '((loopright a a right loopright)
    (loopright 0 a right maybe-done)
    (maybe-done a a right halt)
    (maybe-done 0 a left continue)
    (continue a a left maybe-done)
    (continue 0 a right loopright)))

(define run-lines
  (lambda (lines tape)
    (letrec
      ((driver
         (lambda (state tape)
           (if (eq? state 'halt)
               tape
               (let ((matching-line 
                       (find-line state (at tape) lines)))
                 (driver
                   (next-state matching-line)
                   (reconfigure
                     tape 
                     (next-char matching-line)
                     (next-direction matching-line))))))))
      (driver (current-state (car lines)) tape))))

; - End Exercise -

; - Exercise 11.26, pg. 382 -

(define overwrite
  (lambda (char tape)
    (let ((left (2nd tape)) (right (3rd tape)))
      (list char left right))))

(define right
  (lambda (tape)
    (let ((char (1st tape)) (left (2nd tape)) (right (3rd tape)))
      (list (car right) (cons char left) (check-null (cdr right))))))

; - End Exercise -

; - Program 12.1, pg. 386 -

(define for-effect-only
  (lambda (item-ignored)
    "unspecified value"))

; - End Program -

; - Program 12.2, pg. 388 -

(define box-maker
  (lambda (init-value)
    (let ((contents init-value))
      (lambda msg
        (case (1st msg)
          ((type) "box")
          ((show) contents)
          ((update!) (for-effect-only (set! contents (2nd msg))))
          ((swap!) (let ((ans contents)) 
                     (set! contents (2nd msg)) 
                     ans))
          ((reset!) (for-effect-only (set! contents init-value)))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.3, pg. 388 -

(define delegate
  (lambda (obj msg)
    (apply obj msg)))

; - End Program -

; - Program 12.4, pg. 389 -

(define base-object
  (lambda msg
    (case (1st msg)
      ((type) "base-object")
      (else invalid-method-name-indicator))))

; - End Program -

; - Program 12.5, pg. 389 -

(define send
  (lambda args
    (let ((object (car args)) (message (cdr args)))
      (let ((try (apply object message)))
        (if (eq? invalid-method-name-indicator try)
            (error 
              (string-append (symbol->string (car message)) ": "
                             "Bad method name sent to object of " 
                             (object 'type) " type."))
            try)))))

; - End Program -

; - Program 12.6, pg. 390 -

(define box-maker
  (lambda (init-value)
    (let ((cell (cons init-value "any value")))
      (lambda msg
        (case (1st msg)
          ((type) "box")
          ((update!) (for-effect-only (set-car! cell (2nd msg))))
          ((swap!) (let ((ans (car cell)))
                     (set-car! cell (2nd msg))
                     ans))
          ((show) (car cell))
          ((reset!) (for-effect-only (set-car! cell init-value)))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.7, pg. 391 -

(define counter-maker
  (lambda (init-value unary-proc)
    (let ((total (box-maker init-value)))
      (lambda msg
        (case (1st msg)
          ((type) "counter")
          ((update!) (let ((result (unary-proc (send total 'show))))
                       (send total 'update! result)))
          ((swap!) (delegate base-object msg))
          (else (delegate total msg)))))))

; - End Program -

; - Program 12.8, pg. 392 -

(define counter-maker
  (lambda (init-value unary-proc)
    (let ((total (box-maker init-value)))
      (lambda msg
        (case (1st msg)
          ((type) "counter")
          ((update!) (send total 'update! 
                       (unary-proc (send total 'show))))
          ((show reset) (delegate total msg))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.9, pg. 393 -

(define accumulator-maker
  (lambda (init-value binary-proc)
    (let ((total (box-maker init-value)))
      (lambda msg
        (case (1st msg)
          ((type) "accumulator")
          ((update!) 
           (send total 'update! 
             (binary-proc (send total 'show) (2nd msg))))
          ((swap!) (delegate base-object msg))
          (else (delegate total msg)))))))

; - End Program -

; - Program 12.10, pg. 394 -

(define gauge-maker
  (lambda (init-value unary-proc-up unary-proc-down)
    (let ((total (box-maker init-value)))
      (lambda msg
        (case (1st msg)
          ((type) "gauge")
          ((up!) (send total 'update! 
                   (unary-proc-up (send total 'show))))
          ((down!) (send total 'update! 
                     (unary-proc-down (send total 'show))))
          ((swap! update!) (delegate base-object msg))
          (else (delegate total msg)))))))

; - End Program -

; - Program 12.12, pg. 398 -

(define stack-maker
  (lambda ()
    (let ((stk '()))
      (lambda msg
        (case (1st msg)
          ((type) "stack")
          ((empty?) (null? stk))
          ((push!) (for-effect-only 
                     (set! stk (cons (2nd msg) stk))))
          ((top) (if (null? stk)
                     (error "top: The stack is empty.")
                     (car stk)))
          ((pop!) (for-effect-only
                    (if (null? stk)
                        (error "pop!: The stack is empty.")
                        (set! stk (cdr stk)))))
          ((size) (length stk))
          ((print) (display "TOP: ")
                   (for-each 
                     (lambda (x) 
                       (display x)
                       (display " "))
                     stk)
                   (newline))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.13, pg. 400 -

(define queue-maker
  (lambda ()
    (let ((q '()))
      (lambda msg
        (case (1st msg)
          ((type) "queue")
          ((empty?) (null? q))
          ((enqueue!) (for-effect-only
                        (let ((list-of-item (cons (2nd msg) '())))
                          (if (null? q)
                              (set! q list-of-item)
                              (append! q list-of-item)))))
          ((front) (if (null? q)
                       (error "front: The queue is empty.")
                       (car q)))
          ((dequeue!) (for-effect-only 
                        (if (null? q)
                            (error "dequeue!: The queue is empty.")
                            (set! q (cdr q)))))
          ((size) (length q))
          ((print) (display "FRONT: ")
                   (for-each 
                     (lambda (x) (display x) (display " ")) 
                     q)
                   (newline))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.15, pg. 402 -

(define queue-maker
  (lambda ()
    (let ((q '()) (rear "any value"))
      (lambda msg
        (case (1st msg)
          ((type) "queue")
          ((empty?) (null? q))
          ((enqueue!) (for-effect-only
                        (let ((list-of-item (cons (2nd msg) '())))
                          (if (null? q)
                              (begin
                                (set! rear list-of-item)
                                (set! q list-of-item))
                              (begin
                                (set-cdr! rear list-of-item)
                                (set! rear list-of-item))))))
          ((front) (if (null? q)
                       (error "front: The queue is empty.")
                       (car q)))
          ((dequeue!) (for-effect-only
                        (if (null? q)
                            (error "dequeue!: The queue is empty.")
                            (begin
                              (set! q (cdr q))
                              (if (null? q) 
                                  (set! rear 'anything))))))
          ((size) (length q))
          ((print) (display "FRONT: ")
                   (for-each 
                     (lambda (x) (display x) (display " ")) q)
                   (newline))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.18, pg. 406 -

(define circular-list-maker
  (lambda ()
    (let ((marker '())
          (size-gauge (gauge-maker 0 add1 sub1)))
      (lambda msg
        (case (1st msg)
          ((type) "circular list")
          ((empty?) (null? marker))          
          ((insert!) (send size-gauge 'up!)
                     (for-effect-only
                       (if (null? marker)
                           (begin
                             (set! marker (cons (2nd msg) '()))
                             (set-cdr! marker marker))
                           (set-cdr! marker (cons (2nd msg) (cdr marker))))))
          ((head) (if (null? marker)
                      (error "head: No last entry in an empty list.")
                      (car (cdr marker))))
          ((delete!) (send size-gauge 'down!)
                     (for-effect-only
                       (if (null? marker)
                           (error "delete!: The circular list is empty.")
                           (if (eq? marker (cdr marker))
                               (set! marker '())
                               (set-cdr! marker (cdr (cdr marker)))))))
          ((move!) (for-effect-only
                     (if (null? marker)
                         (error "move!: The circular list is empty.") 
                         (set! marker (cdr marker)))))
          ((size) (send size-gauge 'show))
          ((print) (for-effect-only
                     (if (null? marker)
                         (display "")
                         (let ((next (cdr marker)))
                           (set-cdr! marker '())
                           (for-each (lambda (x) (display x) (display " ")) 
                             next)
                           (set-cdr! marker next)))))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.19, pg. 407 -

(define stack-maker
  (lambda ()
    (let ((c (circular-list-maker)))
      (lambda msg
        (case (1st msg)
          ((type) "stack")
          ((push!) (send c 'insert! (2nd msg)))
          ((pop!) (send c 'delete!))
          ((top) (send c 'head))
          ((print) (display "TOP: ") (send c 'print))
          ((insert! head delete! move!) (delegate base-object msg))
          (else (delegate c msg)))))))

; - End Program -

; - Program 12.20, pg. 408 -

(define queue-maker
  (lambda ()
    (let ((c (circular-list-maker)))
      (lambda msg
        (case (1st msg)
          ((type) "queue")
          ((enqueue!) (send c 'insert! (2nd msg)) (send c 'move!))
          ((dequeue!) (send c 'delete!))
          ((front) (send c 'head))
          ((print) (display "FRONT: ") (send c 'print))
          ((insert! head delete! move!) (delegate base-object msg))
          (else (delegate c msg)))))))          

; - End Program -

; - Exercise 12.21, pg. 411 -

(define memoize
  (lambda (proc)
    (let ((bucket (bucket-maker)))
      (lambda (arg)
        (send bucket 'update!-lookup arg (lambda (val) val) proc)))))

; - End Exercise -

; - Program 12.23, pg. 412 -

(define bucket-maker
  (lambda ()
    (let ((table '()))
      (lambda msg
        (case (1st msg)
          ((type) "bucket")
          ((lookup)
           (let ((key (2nd msg)) (succ (3rd msg)) (fail (4th msg)))
             (lookup key table (lambda (pr) (succ (cdr pr))) fail)))
          ((update!)
           (for-effect-only
             (let ((key (2nd msg)) 
                   (updater (3rd msg)) 
                   (initializer (4th msg)))
               (lookup key table
                 (lambda (pr)
                   (set-cdr! pr (updater (cdr pr))))
                 (lambda ()
                   (let ((pr (cons key (initializer key))))
                     (set! table (cons pr table))))))))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 12.24, pg. 412 -

(define memoize
  (lambda (proc)
    (let ((bucket (bucket-maker)))
      (lambda (arg)
        (send bucket 'update! arg (lambda (val) val) proc)
        (send bucket 'lookup arg 
          (lambda (val) val) (lambda () #f))))))

; - End Program -

; - Program 12.25, pg. 414 -

(define hash-table-maker
  (lambda (size hash-fn)
    (let ((v ((vector-generator (lambda (i) (bucket-maker))) size)))
      (lambda msg
        (case (1st msg)
          ((type) "hash table")
          (else
            (delegate (vector-ref v (hash-fn (2nd msg))) msg)))))))

; - End Program -

; - Program 12.26, pg. 415 -

(define memoize
  (lambda (proc)
    (let ((hashf (lambda (x) (remainder x 1000))))
      (let ((h (hash-table-maker 1000 hashf)))
        (lambda (arg)
          (send h 'update! arg (lambda (v) v) proc)
          (send h 'lookup arg (lambda (v) v) (lambda () #f)))))))

; - End Program -

; - Exercise 12.29, pg. 418 -

(define theater-maker
  (lambda (capacity)
    (let ((ticket-line (queue-maker))
          (vacancies (gauge-maker capacity add1 sub1)))
      (lambda msg
        (case (1st msg)
          ((type) "theater")
          ((dequeue!) (if (zero? (send vacancies 'show))
                          (display "doors closed")
                          (begin
                            (send ticket-line 'dequeue!)
                            (send vacancies 'down!))))
          ((leave!) (if (< (send vacancies 'show) capacity)
                        (send vacancies 'up!)
                        (error "leave!: The theater is empty.")))
          (else (delegate ticket-line msg)))))))

; - End Exercise -

; - Exercise 12.30, pg. 418 -

(define theater-maker
  (lambda (capacity)
    (let ((ticket-line (queue-maker))
          (vacancies (gauge-maker capacity add1 sub1)))
      (lambda msg
        (case (1st msg)
          ((type) "theater")
          ((dequeue!) (if (zero? (send vacancies 'show))
                          (display "doors closed")
                          (begin
                            (send ticket-line 'dequeue!)
                            (send vacancies 'down!))))
          ((leave!) (if (< (send vacancies 'show) capacity)
                        (send vacancies 'up!)
                        (error "leave!: The theater is empty.")))
          ((show) (send vacancies 'show))
          (else (delegate ticket-line msg)))))))

; - End Exercise -

; - Program 12.27, pg. 419 -

(define combine
  (lambda (f g)
    (lambda msg
      (let ((f-try (delegate f msg)))
        (if (eq? invalid-method-name-indicator f-try)
            (delegate g msg)
            f-try)))))

; - End Program -

; - Exercise 12.30, pg. 418 -

(define theater-maker
  (lambda (capacity)
    (let ((ticket-line (queue-maker))
          (vacancies (gauge-maker capacity add1 sub1)))
      (lambda msg
        (case (1st msg)
          ((type) "theater")
          ((dequeue!) (if (zero? (send vacancies 'show))
                          (display "doors closed")
                          (begin
                            (send ticket-line 'dequeue!)
                            (send vacancies 'down!))))
          ((leave!) (if (< (send vacancies 'show) capacity)
                        (send vacancies 'up!)
                        (error "leave! The theater is empty.")))
          (else (delegate (combine ticket-line vacancies) msg)))))))

; - End Exercise -

; - Exercise 12.32, pg. 420 -

(define theater-maker
  (lambda (capacity)
    (let ((ticket-line (queue-maker))
          (vacancies (gauge-maker capacity add1 sub1)))
      (lambda msg
        (case (1st msg)
          ((type) "theater")
          ((dequeue!) (if (zero? (send vacancies 'show))
                          (display "doors closed")
                          (begin
                            (send ticket-line 'dequeue!)
                            (send vacancies 'down!))))
          ((leave!) (if (< (send vacancies 'show) capacity)
                        (send vacancies 'up!)
                        (error "leave!: The theater is empty.")))
          ((reset! update!) (delegate base-object msg))
          (else (delegate (combine ticket-line vacancies) msg)))))))

; - End Exercise -

; - Program 12.28, pg. 421 -

(define send
  (lambda args
    (let ((try (apply (car args) args)))
      (if (eq? invalid-method-name-indicator try)
          (let ((object (car args)) (message (cdr args)))
            (error
              (string-append (symbol->string (car message)) ": "
                "Bad method name sent to object of " 
                (object object 'type) " type.")))
          try))))

; - End Program -

; - Exercise 12.33, pg. 421 -

(define counter-maker
  (lambda (init-value unary-proc)
    (let ((total (box-maker init-value)))
      (lambda message
        (let ((self (car message)) (msg (cdr message)))
          (case (1st msg)
            ((type) "counter")
            ((update!) (let ((result (unary-proc (send total 'show))))
                         (send total 'update! result)))
            ((swap!) (delegate base-object message))
            (else (delegate total message))))))))

; - End Exercise -

; - Exercise 12.34, pg. 422 -

(define cartesian-point-maker 
  (lambda (x-coord y-coord) 
    (lambda message
      (let ((self (car message)) (msg (cdr message))) 
        (case (1st msg)
          ((type) "Cartesian point")
          ((distance) (sqrt (+ (square x-coord) (square y-coord))))          
          ((closer?) (< (send self 'distance) (send (2nd msg) 'distance)))
          (else (delegate base-object message)))))))

; - End Exercise -

; - Exercise 12.35, pg. 423 -

(define manhattan-point-maker
  (lambda (x-coord y-coord)
    (let ((p (cartesian-point-maker x-coord y-coord)))
      (lambda message
        (let ((self (car message)) (msg (cdr message)))
          (case (1st msg)
            ((type) "Manhattan point")
            ((distance) (+ x-coord y-coord))
            (else (delegate p message))))))))

; - End Exercise -

; - Exercise 12.36, pg. 423 -

(define cartesian-origin-maker
  (lambda ()
    (let ((x-coord 0) (y-coord 0))
      (lambda message
        (let ((self (car message)) (msg (cdr message)))
          (case (car msg)
            ((type) "Cartesian point")
            ((distance) (sqrt (+ (square x-coord) (square y-coord))))
            ((closer?) (< (send self 'distance) (send (2nd msg) 'distance)))
            (else (delegate base-object message))))))))

; - End Exercise -


; - Program 13.1, pg. 426 -

(define unif-rand-var-0-1
  (let ((big 1000000))
    (lambda ()
      (/ (+ 1 (random big)) big))))

; - End Program -

; - Program 13.2, pg. 427 -

(define exponential-random-variable
  (lambda (mean)
    (* mean (- (log (unif-rand-var-0-1))))))

; - End Program -

; - Program 13.3, pg. 427 -

(define arrival-time-generator
  (lambda (av-arr-time)
    (+ 1 (round (exponential-random-variable (- av-arr-time 1))))))

; - End Program -

; - Program 13.4, pg. 428 -

(define normal-random-variable
  (lambda (mean std-dev)
    (letrec ((compute (lambda (i)
                        (if (zero? i)
                            0
                            (+ (- (unif-rand-var-0-1) .5) 
                               (compute (sub1 i)))))))
      (+ mean (* std-dev (compute 12))))))

; - End Program -

; - Program 13.5, pg. 428 -

(define gallons-generator
  (lambda ()
    (max 1 (round (normal-random-variable 12 4)))))

; - End Program -

; - Exercise 13.3, pg. 429 -

(define random-maker
  (lambda (m a seed)
    (lambda (n)
      (let ((u (/ seed m)))
        (set! seed (modulo (* a seed) m))
        (floor (* n u))))))

(define random-time (lambda () 1000))

(define random 
  (random-maker (- (expt 2 32) 1) (expt 7 5) (random-time)))

; - End Exercise -

; - Program 13.8, pg. 434 -

(define simulation-setup&run
  (lambda (close-time %-self-service av-arr-time 
            profit-self profit-full 
            av-time-at-self-pump av-time-at-full-pump pump-rate)
    (let ((self-service (service-maker "Self" profit-self))
          (full-service (service-maker "Full" profit-full)))    
      (simulation
        (station-maker
          %-self-service
          self-service
          full-service
          av-time-at-self-pump
          av-time-at-full-pump
          pump-rate)
        (counter-maker 0 add1)
        av-arr-time
        (* 60 close-time)))))

; - End Program -

; - Program 13.9, pg. 435 -

(define simulation
  (lambda (station clock av-arr-time close-time)
    (let ((arrival 
            (box-maker (+ (send clock 'show) 
                          (arrival-time-generator av-arr-time)))))
      (letrec
        ((loop
           (lambda ()
             (if (= (send clock 'show) close-time)
                 (prepare-for-closing)
                 (begin
                   (if (= (send clock 'show) (send arrival 'show))
                       (begin
                         (send station 'which-serve
                           (customer-maker (send arrival 'show) clock))
                         (send station 'serve)
                         (send clock 'update!)
                         (send arrival 'update!
                           (+ (send clock 'show) 
                              (arrival-time-generator av-arr-time))))
                       (begin
                         (send station 'serve)
                         (send clock 'update!)))
                   (loop)))))
         (prepare-for-closing
           (lambda ()
             (if (send station 'all-empty?)
                 (send station 'report)
                 (begin
                   (send station 'serve)
                   (send clock 'update!)
                   (prepare-for-closing))))))
        (loop)))))

; - End Program -

; - Program 13.10, pg. 436 -

(define station-maker
  (let ((check (lambda (p) (send p 'check)))
        (all-empty? (andmap-c (lambda (p) (send p 'empty?))))
        (shorter (lambda (p1 p2)
                   (if (< (send p1 'size) (send p2 'size)) p1 p2))))
    (lambda (%-self self-serv full-serv av-time-self av-time-full pump-rate)
      (let ((selfs (list (pump-maker av-time-self pump-rate self-serv)
                         (pump-maker av-time-self pump-rate self-serv)))
            (fulls (list (pump-maker av-time-full pump-rate full-serv)
                         (pump-maker av-time-full pump-rate full-serv))))
        (lambda msg 
          (case (1st msg)
            ((type) "station")
            ((report) (send self-serv 'report) (send full-serv 'report))
            ((which-serve) 
             (let ((pump (apply shorter (if (< (random 100) %-self)
                                            selfs
                                            fulls))))
               (send pump 'enqueue! (2nd msg))))
            ((all-empty?) (and (all-empty? selfs) (all-empty? fulls)))
            ((serve) (for-each check selfs) (for-each check fulls))
            (else (delegate base-object msg))))))))

; - End Program -

; - Program 13.11, pg. 437 -

(define pump-maker
  (lambda (av-time pump-rate service)
    (let ((q (queue-maker)))
      (let ((increment (lambda ()
                         (let ((gallons (send (send q 'front) 'gallons)))
                           (ceiling (+ av-time (/ gallons pump-rate))))))
            (timer (box-maker -1)))
        (lambda msg
          (case (1st msg)
            ((type) "pump")
            ((check) (if (not (send q 'empty?))
                         (let ((c (send timer 'show)))
                           (cond
                             ((negative? c) (send timer 'update! (increment)))
                             ((zero? c)
                              (let ((customer (send q 'front)))
                                (send q 'dequeue!)
                                (send customer 'record service)
                                (if (send q 'empty?)
                                    (send timer 'reset!)
                                    (send timer 'update! (increment)))))
                             (else (send timer 'update!
                                     (sub1 (send timer 'show))))))))
            (else (delegate q msg))))))))

; - End Program -

; - Program 13.12, pg. 438 -

(define customer-maker  
  (lambda (arrival-time clock)
    (let ((gallons-pumped (gallons-generator)))
      (lambda msg
        (case (1st msg)
          ((type) "customer")
          ((gallons) gallons-pumped)
          ((record) (let ((service (2nd msg))
                          (wait (- (send clock 'show) arrival-time)))
                      (send service 'number-of!)
                      (send service 'total-wait! wait)
                      (send service 'max-wait! wait)
                      (send service 'total-profit! gallons-pumped)))
          (else (delegate base-object msg)))))))

; - End Program -

; - Program 13.13, pg. 439 -

(define service-maker
  (lambda (full-or-self profit)
    (let ((number-of (counter-maker 0 add1))
          (total-wait (accumulator-maker 0 +))
          (max-wait (accumulator-maker 0 max))
          (total-profit (accumulator-maker 0 +)))
      (lambda msg
          (case (1st msg)
            ((type) "service")
            ((number-of!) (send number-of 'update!))
            ((total-wait!) (send total-wait 'update! (2nd msg)))
            ((max-wait!) (send max-wait 'update! (2nd msg)))
            ((total-profit!) 
             (send total-profit 'update! (* profit (2nd msg))))
            ((report) (for-effect-only
                          (report full-or-self
                                  (send number-of 'show)
                                  (send total-wait 'show)
                                  (send max-wait 'show)
                                  (send total-profit 'show))))
            (else (delegate base-object msg)))))))

; - End Program -

; - Program 13.14, pg. 439 -

(define report
  (lambda (full-or-self num-cust total-wait max-wait profit)
    (if (zero? num-cust)
        (writeln "   There were no " full-or-self "-Service customers.")
        (begin
          (writeln full-or-self "-Service:")
          (writeln "   The number of customers is " num-cust)
          (writeln "   The average wait is " (round (/ total-wait num-cust)))
          (writeln "   The maximum wait is " max-wait)
          (writeln "   The total profit is " profit)))))

; - End Program -

; - Program 13.15, pg. 440 -

(define prompt-read
  (lambda (prompt)
    (display prompt)
    (display " ")
    (read)))

; - End Program -

; - Program 13.16, pg. 441 -

(define gas-station-simulator
  (letrec 
    ((loop (lambda (ls)
             (if (null? ls)
                 '()
                 (let ((v (prompt-read (car ls))))
                   (cons v (loop (cdr ls))))))))
    (lambda ()
      (apply simulation-setup&run (loop station-prompts)))))

; - End Program -

; - Exercise 13.9, pg. 444 -

(define prompt-read
  (lambda items
    (for-each display items)
    (display " ")
    (read)))

; - End Exercise -

; - Program 14.1, pg. 453 -

(macro freeze
  (lambda (code)
    (cons 'lambda (cons '() (list (2nd code))))))

; - End Program -

; - Program 14.2, pg. 356 -

(extend-syntax (freeze) 
  ((freeze expr1 expr2 ...) (lambda () expr1 expr2 ...)))

; - End Program -

; - Program 14.3, pg. 456 -

(define thaw
  (lambda (thunk)
    (thunk)))  

; - End Program -

; - Program 14.4, pg. 457 -

(define make-promise
  (lambda (thunk)
    (let ((already-run? #f)
          (result "any value"))
      (lambda ()
        (if (not already-run?)
            (begin
              (set! result (thaw thunk))
              (set! already-run? #t)))
        result))))

; - End Program -

; - Program 14.5, pg. 458 -

(extend-syntax (delay)
  ((delay expr1 expr2 ...) (make-promise (freeze expr1 expr2 ...))))

; - End Program -

; - Program 14.6, pg. 458 -

(define delay-transformer
  (lambda (code)
    (list 'make-promise (cons 'freeze (cdr code)))))

(macro delay delay-transformer)

; - End Program -

; - Program 14.7, pg. 459 -

(extend-syntax (let)
  ((let ((var val) ...) expr1 expr2 ...)
   ((lambda (var ...) expr1 expr2 ...) val ...)))

; - End Program -

; - Program 14.8, pg. 460 -

(define let-transformer
  (lambda (code)
    (cons (make-lambda-expression
            (make-list-of-parameters code)
            (make-list-of-body-items code))
          (make-list-of-operands code))))

(macro let let-transformer)

; - End Program -

; - Program 14.9, pg. 461 -

(extend-syntax (letrec)
  ((letrec ((var val) ...) expr1 expr2 ...)
   (let ((var "any") ...)
     (begin (set! var val) ...)
     expr1 expr2 ...)))

; - End Program -

; - Program 14.10, pg. 462 -

(macro letrec
  (lambda (code)
    (cons 'let
      (cons (map (lambda (x) (list (1st x) "any")) (2nd code))
        (cons (cons 'begin
                (map (lambda (x) (cons 'set! x)) (2nd code)))
          (cddr code))))))                

; - End Program -

; - Program 14.11, pg. 463 -

(define cycle-proc
  (lambda (th)
    (letrec ((loop (lambda ()
                     (th)
                     (loop))))
      (loop))))

; - End Program -

; - Program 14.12, pg. 464 -

(define or-proc
  (lambda (th-list)
    (cond
      ((null? th-list) #f)
      ((null? (cdr th-list)) (thaw (car th-list)))
      (else (let ((v (thaw (car th-list))))
              (if v v (or-proc (cdr th-list))))))))

; - End Program -

; - Program 14.13, pg. 465 -

(define or-transformer
  (lambda (expr)
    (list 'or-proc
          (cons 'list
                (map (lambda (e) (list 'freeze e))
                     (cdr expr))))))

(macro or or-transformer)

; - End Program -

; - Program 14.14, pg. 465 -

(extend-syntax (or)
  ((or e ...) (or-proc (list (freeze e) ...))))

; - End Program -

; - Exercise 14.3, pg. 466 -

(extend-syntax (or)
  ((or) #f)
  ((or e) e)
  ((or e1 e2 ...) (let ((val e1) (th (freeze (or e2 ...))))
                    (if val val (th)))))

; - End Exercise -

; - Exercise 14.12, pg. 470 -

(define vector-sum
  (lambda (v)
    (let ((n (vector-length v))
          (sum 0))
      (for i 0 (add1 i) (= i n) (set! sum (+ (vector-ref v i) sum)))
      sum)))

; - End Exercise -

; - Exercise 14.16, pg. 472 -

(define member-trace
  (lambda (item ls)
    (cond
      ((null? ls) (writeln "no") #f)
      ((equal? (car ls) item) (writeln "yes") #t)
      (else (writeln "maybe") (member-trace item (cdr ls))))))

(define factorial
  (lambda (n)
    (cond
      ((zero? n) 1)
      (else (* n (factorial (sub1 n)))))))

; - End Exercise -
; - Program 15.1, pg. 477 -

(define delayed-list-car (compose car force))

; - End Program -

; - Program 15.2, pg. 478 -

(define delayed-list-cdr (compose cdr force))

; - End Program -

; - Program 15.3, pg. 478 -

(define the-null-delayed-list (delay '()))

; - End Program -

; - Program 15.4, pg. 479 -

(define random-delayed-list
  (lambda (n)
    (if (zero? n)
        the-null-delayed-list
        (delayed-list-cons 
          (+ 2 (random 11)) 
          (random-delayed-list (sub1 n))))))

; - End Program -

; - Program 15.5, pg. 483 -

(define stream-car (compose car force))

(define stream-cdr (compose cdr force))

; - End Program -

; - Program 15.6, pg. 483 -

(define random-stream-generator
  (lambda ()
    (stream-cons (+ 2 (random 11)) (random-stream-generator))))

; - End Program -

; - Program 15.7, pg. 483 -

(define random-stream (random-stream-generator))

; - End Program -

; - Program 15.8, pg. 484 -

(define the-null-stream
  (stream-cons the-end-of-stream-tag the-null-stream))

; - End Program -

; - Program 15.9, pg. 484 -

(define list->stream
  (lambda (ls)
    (if (null? ls)
        the-null-stream
        (stream-cons (car ls) (list->stream (cdr ls))))))

; - End Program -

; - Program 15.10, pg. 484 -

(define end-of-stream?
  (lambda (x)
    (eq? x the-end-of-stream-tag)))

; - End Program -

; - Program 15.11, pg. 485 -

(define stream-null? (compose end-of-stream? stream-car))

; - End Program -

; - Program 15.12, pg. 485 -

(define stream->list
  (lambda (strm n)
    (if (or (stream-null? strm) (zero? n))
        '()
        (cons (stream-car strm) 
              (stream->list (stream-cdr strm) (sub1 n))))))

(define finite-stream->list
  (lambda (finite-strm)
    (stream->list finite-strm -1)))

; - End Program -

; - Program 15.13, pg. 486 -

(define positive-integers
  (letrec 
    ((stream-builder
       (lambda (x)
         (stream-cons x (stream-builder (add1 x))))))
    (stream-builder 1)))

; - End Program -

; - Program 15.14, pg. 486 -

(define even-positive-integers
  (letrec
    ((stream-builder
       (lambda (x)
         (stream-cons x (stream-builder (+ x 2))))))
    (stream-builder 2)))

; - End Program -

; - Program 15.15, pg. 486 -

(define powers-of-2
  (letrec
    ((stream-builder
       (lambda (x)
         (stream-cons x (stream-builder (* x 2))))))
    (stream-builder 1)))

; - End Program -

; - Program 15.16, pg. 487 -

(define build-stream
  (lambda (seed proc)
    (letrec 
      ((stream-builder
         (lambda (x)
           (stream-cons x (stream-builder (proc x))))))
      (stream-builder seed))))

; - End Program -

; - Program 15.17, pg. 488 -

(define factorials
  (letrec
    ((stream-builder
       (lambda (x n)
         (stream-cons x (stream-builder (* x n) (add1 n))))))
    (stream-builder 1 1)))

; - End Program -

; - Program 15.18, pg. 488 -

(define stream-map
  (lambda (proc strm)
    (stream-cons 
      (proc (stream-car strm)) 
      (stream-map proc (stream-cdr strm)))))

; - End Program -

; - Program 15.19, pg. 489 -

(define odd-positive-integers
  (stream-map sub1 even-positive-integers))  

; - End Program -

; - Program 15.20, pg. 489 -

(define stream-apply-to-both
  (lambda (proc)
    (letrec 
      ((str-app
         (lambda (s1 s2)
           (stream-cons 
             (proc (stream-car s1) (stream-car s2))
             (str-app (stream-cdr s1) (stream-cdr s2))))))
      str-app)))

; - End Program -

; - Program 15.21, pg. 489 -

(define stream-plus (stream-apply-to-both +))

(define stream-times (stream-apply-to-both *))

; - End Program -

; - Program 15.22, pg. 490 -

(define stream-filter-out
  (lambda (test?)
    (letrec 
      ((helper
         (lambda (strm)
           (let ((a (stream-car strm)))
             (if (test? a)
                 (helper (stream-cdr strm))
                 (stream-cons a (helper (stream-cdr strm))))))))
       helper)))

; - End Program -

; - Program 15.23, pg. 490 -

(define positive-integers
  (stream-cons 1 (stream-map add1 positive-integers)))  

; - End Program -

; - Program 15.24, pg. 491 -

(define factorials
  (stream-cons 1 (stream-times factorials positive-integers)))  

; - End Program -

; - Program 15.25, pg. 491 -

(define fibonacci-numbers
  (stream-cons 0
    (stream-cons 1 
      (stream-plus 
        fibonacci-numbers
        (stream-cdr fibonacci-numbers))))) 

; - End Program -

; - Program 15.26, pg. 492 -

(define sieve
  (lambda (n strm)
    ((stream-filter-out (divides-by n)) strm))) 

; - End Program -

; - Program 15.27, pg. 492 -

(define prime-numbers
  (letrec 
    ((primes
       (lambda (s)
         (stream-cons 
           (stream-car s) 
           (primes (sieve (stream-car s) (stream-cdr s)))))))      
    (primes (stream-cdr positive-integers))))

; - End Program -

; - Exercise 15.14, pg. 495 -

(define stream-append
  (lambda (finite-stream stream)
    (cond
      ((stream-null? finite-stream) stream)
      (else (stream-cons 
              (stream-car finite-stream) 
              (stream-append 
                (stream-cdr finite-stream) 
                stream))))))

(define int-pairs-generator
  (lambda (i)
    (stream-append (diagonal i) (int-pairs-generator (add1 i)))))

(define stream-append/delay
  (lambda (finite-stream stream)
    (cond
      ((stream-null? finite-stream) (force stream))
      (else (stream-cons 
              (stream-car finite-stream) 
              (stream-append/delay 
                (stream-cdr finite-stream) 
                stream))))))

; - End Exercise -

; - Exercise 15.17, pg. 499 -

(define string-tester
  (lambda (str)
    (let ((chars (string->list str)))
      (let ((s (list->string chars)))
        (write (list s chars))
        (newline)))))

; - End Exercise -

; - Program 15.29, pg. 504 -

(define file-copier
  (lambda (infile outfile)
    (let ((p-in (open-input-file infile))
          (p-out (open-output-file outfile)))
      (letrec
        ((copier (lambda (ch)
                   (if (not (eof-object? ch))
                       (begin
                         (write-char ch p-out)
                         (copier (read-char p-in)))))))
        (copier (read-char p-in))
        (close-input-port p-in)
        (close-output-port p-out)))))

; - End Program -

; - Program 15.30, pg. 505 -

(define file->stream
  (lambda (filename)
    (let ((port-in (open-input-file filename)))
      (letrec
        ((build-input-stream
           (lambda ()
             (let ((ch (read-char port-in)))
               (if (eof-object? ch)
                   (begin
                     (close-input-port port-in)
                     the-null-stream)
                   (stream-cons ch (build-input-stream)))))))
        (build-input-stream)))))

; - End Program -

; - Program 15.31, pg. 506 -

(define formatter
  (lambda (input-file output-file line-length)
    (stream->file output-file
      (insert-newlines line-length
        (insert-double-spaces
          (remove-extra-spaces
            (remove-newlines
              (file->stream input-file))))))))

; - End Program -

; - Program 15.32, pg. 506 -

(define remove-newlines
  (lambda (str)
    (stream-map
      (lambda (ch)
        (cond 
          ((end-of-stream? ch) ch)
          ((or (char=? ch #\return) (char=? ch #\newline)) #\space)
          (else ch)))
      str)))

; - End Program -

; - Program 15.33, pg. 506 -

(define remove-extra-spaces
  (lambda (str)
    (let ((ch (stream-car str)))
      (cond 
        ((end-of-stream? ch) str)
        ((char=? ch #\space) 
         (stream-cons #\space 
           (remove-extra-spaces
             (trim-spaces (stream-cdr str)))))
        (else (stream-cons 
                ch 
                (remove-extra-spaces (stream-cdr str))))))))

; - End Program -

; - Program 15.34, pg. 507 -

(define trim-spaces
  (lambda (str)
    (cond 
      ((stream-null? str) str)
      ((char=? (stream-car str) #\space)
       (trim-spaces (stream-cdr str)))
      (else str))))

; - End Program -

; - Program 15.35, pg. 507 -

(define insert-double-spaces
  (lambda (str)
    (let ((ch (stream-car str)))    
      (cond 
        ((end-of-stream? ch) str)
        ((end-of-sentence? ch)
         (stream-cons ch
           (stream-cons #\space
             (stream-cons #\space
               (insert-double-spaces 
                 (trim-spaces (stream-cdr str)))))))
        (else (stream-cons ch
                (insert-double-spaces (stream-cdr str))))))))

; - End Program -

; - Program 15.36, pg. 507 -

(define end-of-sentence?
  (lambda (ch)
    (or (char=? ch #\.) (char=? ch #\!) (char=? ch #\?))))

; - End Program -

; - Program 15.37, pg. 508 -

(define insert-newlines
  (lambda (line-length str)
    (letrec 
      ((insert (lambda (str count)
                 (if (stream-null? str)
                     str
                     (let ((n (count-chars-to-next-space str)))
                       (if (< (+ n count) line-length)
                           (stream-cons (stream-car str)
                             (insert (stream-cdr str) (add1 count)))
                           (stream-cons #\newline
                             (insert (trim-spaces str) 0))))))))
      (insert (trim-spaces str) 0))))

; - End Program -

; - Program 15.38, pg. 508 -

(define count-chars-to-next-space
  (lambda (strm)
    (letrec
      ((count-ahead
         (lambda (str count)
           (let ((ch (stream-car str)))
             (if (or (end-of-stream? ch) (char=? ch #\space))
                 count
                 (count-ahead (stream-cdr str) (add1 count)))))))
      (count-ahead strm 0))))

; - End Program -

; - Program 15.39, pg. 509 -

(define stream->file
  (lambda (filename stream)
    (let ((port-out (open-output-file filename)))
      (letrec ((write-stream
                 (lambda (str)
                   (if (not (stream-null? str))
                       (begin
                         (write-char (stream-car str) port-out)
                         (write-stream (stream-cdr str)))))))
        (write-stream stream)
        (close-output-port port-out)))))

; - End Program -

; - Exercise 15.28, pg. 510 -

(define formatter
  (lambda (input-file output-file line-length)
    ((stream->file output-file)
     ((insert-newlines line-length)
      (insert-double-spaces
        (remove-extra-spaces
          (remove-newlines
            (file->stream input-file))))))))

; - End Exercise -

; - Exercise 15.29, pg. 511 -

(define formatter
  (lambda (output-file line-length)
    (lambda (input-file)
      ((stream->file output-file)
       ((insert-newlines line-length)
        (insert-double-spaces
          (remove-extra-spaces
            (remove-newlines
              (file->stream input-file)))))))))

; - End Exercise -

; - Exercise 15.30, pg. 511 -

(define apply-procedures
  (lambda (procedures)
    (lambda (argument)
      (if (null? procedures)
          argument
          (letrec 
            ((comp (lambda (procs)
                     ((car procs)
                      (cond
                        ((null? (cdr procs)) argument)
                        (else (comp (cdr procs))))))))
            (comp procedures))))))

; - End Exercise -

; - Exercise 15.31, pg. 511 -

(define formatter
  (lambda (output-file line-length)
    (compose
      (stream->file output-file)
      (insert-newlines line-length)
      insert-double-spaces      
      remove-extra-spaces
      remove-newlines
      file->stream)))

; - End Exercise -

; - Exercise 16.6, pg. 526 -

(define reset
  (lambda ()
    ((escaper
       (lambda ()
         (writeln "reset invoked"))))))

; - End Exercise -

; - Program 16.1, pg. 527 -

(define call/cc call-with-current-continuation)

; - End Program -

; - Program 16.2, pg. 530 -

(define receiver-1 
  (lambda (proc) 
    (proc (list 1))))

(define receiver-2 
  (lambda (proc) 
    (proc (list (proc (list 2))))))

(define receiver-3 
  (lambda (proc) 
    (proc (list (proc (list 3 proc))))))

; - End Program -

; - Program 16.3, pg. 531 -

(define result "any value")

(define resultcc "any value")

; - End Program -

; - Program 16.4, pg. 531 -

(define writeln/return
  (lambda (x)
    (writeln x)
    x))

(define answer-maker
  (lambda (x)
    (cons 'answer-is (writeln/return x))))

(define call
  (lambda (receiver)
    (receiver writeln/return)))

; - End Program -

; - Exercise 16.16, pg. 537 -

(define deep "any continuation")

(define map-sub1
  (lambda (ls)
    (if (null? ls)
        (let ((receiver (lambda (k) 
                          (set! deep k) 
                          '())))
          (call/cc receiver))
        (cons (sub1 (car ls)) (map-sub1 (cdr ls))))))

; - End Exercise -

; - Program 16.5, pg. 538 -

(define *escape/thunk* "any continuation")

(define escaper
  (lambda (proc)
    (lambda (x)
      (*escape/thunk* (lambda () (proc x))))))

; - End Program -

; - Program 16.6, pg. 539 -

(define receiver-4
  (lambda (continuation)
    (set! *escape/thunk* continuation)
    (*escape/thunk* (lambda () (writeln "escaper is defined")))))

; - End Program -

; - Program 16.7, pg. 540 -

(define escaper
  (lambda (proc)
    (lambda args
      (*escape/thunk* 
        (lambda ()
          (apply proc args))))))

; - End Program -

; - Exercise 16.22, pg. 541 -

(define new-escaper "any procedure")

(let ((receiver (lambda (continuation)
                  (set! new-escaper
                    (lambda (proc)
                      (lambda args
                        (continuation
                          (lambda ()
                            (apply proc args))))))
                  (lambda () (writeln "new-escaper is defined")))))
  ((call/cc receiver)))

; - End Exercise -

; - Program 16.8, pg. 542 -

(define how-many-til
  (lambda (n target)
    (let ((count 0))
      (cycle-proc
        (lambda ()
          (let ((r (random n)))
            (if (= r target)
                (begin (writeln count) (set! count 0))
                (set! count (+ count 1)))))))))

; - End Program -

; - Program 16.9, pg. 543 -

(define how-many-til
  (lambda (n target thresh)
    (let ((receiver
            (lambda (exit-above-threshold)
              (let ((count 0) (sum 0))
                (cycle-proc
                  (lambda ()
                    (if (= (random n) target)
                        (begin
                          (writeln "target " target 
                                   " required " count " trials")
                          (set! sum (+ sum count))
                          (set! count 0)
                          (if (> sum thresh) 
                              (exit-above-threshold sum)))
                        (set! count (+ count 1)))))))))
      (call/cc receiver))))

; - End Program -

; - Program 16.10, pg. 543 -

(define random-data
  (lambda (n thresh)
    (letrec ((loop (lambda (target)
                     (cond
                       ((negative? target) '())
                       (else (cons (how-many-til n target thresh)
                                   (loop (sub1 target))))))))
      (loop (sub1 n)))))

; - End Program -

; - Program 16.11, pg. 544 -

(define product+
  (lambda (n nums)
    (letrec
      ((product (lambda (nums)
                  (cond
                    ((null? nums) 1)
                    (else (* (car nums) (product (cdr nums))))))))
      (let ((prod (product nums)))
        (if (zero? prod) 0 (+ n prod))))))

; - End Program -

; - Program 16.12, pg. 545 -

(define product+
  (lambda (n nums)
    (letrec
      ((product (lambda (nums)
                  (cond
                    ((null? nums) 1)
                    ((zero? (car nums)) 0)
                    (else (* (car nums) (product (cdr nums))))))))
      (let ((prod (product nums)))
        (if (zero? prod) 0 (+ n prod))))))

; - End Program -

; - Program 16.13, pg. 546 -

(define product+
  (lambda (n nums)
    (let ((receiver
            (lambda (exit-on-zero)
              (letrec
                ((product (lambda (nums)
                            (cond
                              ((null? nums) 1)
                              ((zero? (car nums)) (exit-on-zero 0))
                              (else (* (car nums) 
                                       (product (cdr nums))))))))
                (let ((prod (product nums)))
                  (if (zero? prod) 0 (+ n prod)))))))
      (call/cc receiver))))

; - End Program -

; - Program 16.14, pg. 546 -

(define product+
  (lambda (n nums)
    (let ((receiver
            (lambda (exit-on-zero)
              (letrec
                ((product (lambda (nums)
                            (cond
                              ((null? nums) 1)
                              ((zero? (car nums)) (exit-on-zero 0))
                              (else (* (car nums) 
                                       (product (cdr nums))))))))
                (+ n (product nums))))))
      (call/cc receiver))))

; - End Program -

; - Program 16.15, pg. 547 -

(define product+
  (lambda (n nums)
    (let ((receiver
            (lambda (exit-on-zero)
              (letrec
                ((product
                   (lambda (nums)
                     (cond
                       ((null? nums) 1)
                       ((number? (car nums))
                        (cond
                          ((zero? (car nums)) (exit-on-zero 0))
                          (else (* (car nums) 
                                   (product (cdr nums))))))
                       (else (* (product (car nums)) 
                                (product (cdr nums))))))))
                (+ n (product nums))))))
      (call/cc receiver))))

; - End Program -

; - Program 16.16, pg. 547 -

(define *-and-count-maker
  (lambda ()
    (let ((local-counter 0))
      (lambda (n1 n2)
        (set! local-counter (+ local-counter 1))
        (writeln "Number of multiplications = " local-counter)
        (* n1 n2)))))

; - End Program -

; - Program 16.17, pg. 548 -

(define product+
  (lambda (n nums *-proc)
    (letrec 
      ((product 
         (lambda (nums)
           (cond
             ((null? nums) 1)
             ((number? (car nums))
              (cond
                ((zero? (car nums)) 0)
                (else (*-proc (car nums) 
                              (product (cdr nums))))))
             (else (*-proc (product (car nums)) 
                           (product (cdr nums))))))))
      (let ((prod (product nums)))
        (if (zero? prod) 0 (+ n prod))))))

; - End Program -

; - Program 17.1, pg. 553 -

(define countdown
  (lambda (n)
    (writeln "This only appears once")
    (let ((pair (message "Exit" (attempt (message "Enter" n)))))
      (let ((v (1st pair))
            (returner (2nd pair)))
        (writeln "    The non-negative-number: " v)
        (if (positive? v) 
            (returner (list (sub1 v) returner))
            (writeln "Blastoff"))))))

; - End Program -

; - Program 17.2, pg. 554 -

(define message
  (lambda (direction value)
    (writeln "   " direction "ing attempt with value: " value)
    value))

; - End Program -

; - Program 17.3, pg. 554 -

(define attempt
  (lambda (n)
    (let ((receiver (lambda (proc) (list n proc))))
      (receiver (lambda (x) x)))))

; - End Program -

; - Program 17.4, pg. 555 -

(define attempt
  (lambda (n)
    (let ((receiver (lambda (proc) (list n proc))))
      (call/cc receiver))))

; - End Program -

; - Program 17.5, pg. 557 -

(define receiver
  (lambda (continuation)
    (continuation continuation)))

; - End Program -

; - Program 17.6, pg. 557 -

(define tester
  (lambda (continuation)
    (writeln "beginning")
    (call/cc continuation)
    (writeln "middle")
    (call/cc continuation)
    (writeln "end")))

; - End Program -

; - Program 17.7, pg. 560 -

(define flatten-number-list
  (lambda (s)
    (letrec
      ((flatten
         (lambda (s)
           (cond
             ((null? s) '())
             ((number? s) (list (break s)))
             (else (let ((flatcar (flatten (car s))))
                     (append flatcar (flatten (cdr s)))))))))
      (flatten s))))

; - End Program -

; - Program 17.8, pg. 560 -

(define break
  (lambda (x) x))

; - End Program -

; - Program 17.9, pg. 560 -

(define break
  (lambda (x)
    (let ((break-receiver
            (lambda (continuation)
              (continuation x))))
      (call/cc break-receiver))))

; - End Program -

; - Program 17.10, pg. 561 -

(define get-back "any procedure")            

(define break
  (lambda (x)
    (let ((break-receiver
            (lambda (continuation)
              (set! get-back (lambda () (continuation x)))
              (any-action x))))
      (call/cc break-receiver))))

; - End Program -

; - Program 17.11, pg. 561 -

(define any-action
  (lambda (x)
    (writeln x)
    (get-back)))

; - End Program -

; - Program 17.12, pg. 561 -

(define any-action
  (lambda (x)
    ((escaper (lambda () x)))
    (get-back)))

; - End Program -

; - Program 17.13, pg. 562 -

(define get-back "any escape procedure")      

(define break
  (lambda (x)
    (let ((break-receiver
            (lambda (continuation)
              (set! get-back continuation)
              (any-action x))))
      (call/cc break-receiver))))

; - End Program -

; - Program 17.14, pg. 563 -

(define break-argument "any value")

(define any-action
  (lambda (x)
    (set! break-argument x)
    ((escaper (lambda () x)))))

; - End Program -

; - Program 17.15, pg. 564 -

(define get-back "any escape procedure")

(define break
  (lambda (x)
    (let ((break-receiver
            (lambda (continuation)
              (set! get-back continuation)
              (set! break-argument x)
              ((escaper (lambda () x))))))
      (call/cc break-receiver))))

; - End Program -

; - Program 17.16, pg. 564 -

(define flatten-number-list
  (lambda (s)
    (letrec
      ((flatten
         (lambda (s)
           (cond
             ((null? s) '())
             ((number? s) 
              (list
                (break 
                  (list (lambda () s)
                        (lambda (v) (set! s v))))))
             (else (let ((flatcar (flatten (car s))))
               (append flatcar (flatten (cdr s)))))))))
      (flatten s))))

; - End Program -

; - Program 17.17, pg. 564 -

(define extract
  (lambda ()
    ((1st break-argument))))

; - End Program -

; - Program 17.18, pg. 565 -

(define store
  (lambda (value)
    ((2nd break-argument) value)))

; - Exercise 17.4, pg. 565 -

(define flatten-number-list
  (lambda (s)
    (letrec
      ((flatten
         (lambda (s)
           (cond
             ((null? s) '())
             ((number? s) (break (list s)))
             (else (let ((flatcar (flatten (car s))))
                     (append flatcar (flatten (cdr s)))))))))
      (flatten s))))

; - End Exercise -

; - Exercise 17.6, pg. 565 -

(define product+
  (lambda (n nums)
    (letrec
        ((product 
           (lambda (nums)
             (cond
               ((null? nums) 1)
               ((number? (car nums))
                (* (cond
                     ((zero? (car nums)) (break-on-zero))
                     (else (car nums)))
                   (product (cdr nums))))
               (else (* (product (car nums)) (product (cdr nums))))))))
      (+ n (product nums)))))

; - End Exercise -

; - Program 17.19, pg. 569 -

(define A
  (let ((A-proc (lambda (resume v)
                  (writeln "This is A")
                  (writeln "Came from " (resume B "A"))
                  (writeln "Back in A")
                  (writeln "Came from " (resume C "A")))))
    (coroutine-maker A-proc)))

(define B
  (let ((B-proc (lambda (resume v)
                  (writeln (blanks 14) "This is B")
                  (writeln (blanks 14) 
                           "Came from " (resume C "B"))
                  (writeln (blanks 14) "Back in B")
                  (writeln (blanks 14) 
                           "Came from " (resume A "B")))))
    (coroutine-maker B-proc)))

(define C
  (let ((C-proc (lambda (resume v)
                  (writeln (blanks 28) "This is C")
                  (writeln (blanks 28) 
                           "Came from " (resume A "C"))
                  (writeln (blanks 28) "Back in C")
                  (writeln (blanks 28) 
                           "Came from " (resume B "C")))))
    (coroutine-maker C-proc)))

; - End Program -

; - Program 17.20, pg. 570 -

(define coroutine-maker
  (lambda (proc)
    (let ((saved-continuation "any continuation"))
      (let ((update-continuation! 
              (lambda (v) 
                (set! saved-continuation v))))
        (let ((resumer (resume-maker update-continuation!))
              (first-time #t))
          (lambda (value)
            (if first-time
                (begin
                  (set! first-time #f)
                  (proc resumer value))
                (saved-continuation value))))))))

; - End Program -

; - Program 17.21, pg. 570 -

(define resume-maker
  (lambda (update-proc!)
    (lambda (next-coroutine value)
      (let ((receiver (lambda (continuation)
                        (update-proc! continuation)
                        (next-coroutine value))))
        (call/cc receiver)))))

; - End Program -

; - Exercise 17.12, pg. 571 -

(define ping
  (let ((ping-proc (lambda (resume v)
                     (display "ping-")
                     (resume pong 'ignored-ping))))
    (coroutine-maker ping-proc)))



(define pong
  (let ((pong-proc (lambda (resume v)
                     (display "pong")
                     (newline)
                     (resume ping 'ignored-pong))))
    (coroutine-maker pong-proc)))

; - End Exercise -

; - Program 17.22, pg. 573 -

(define reader
  (lambda (right)
    (let ((co-proc (lambda (resume v)
                     (cycle-proc 
                       (lambda ()
                         (resume right (prompt-read "in> ")))))))
      (coroutine-maker co-proc))))

; - End Program -

; - Program 17.23, pg. 574 -

(define writer
  (lambda (left escape-on-end)
    (let ((co-proc (lambda (resume v)
                     (cycle-proc
                       (lambda ()
                         (let ((symbol (resume left 'ok)))
                           (if (eq? symbol 'end)
                               (escape-on-end symbol)
                               (writeln "out> " symbol))))))))
      (coroutine-maker co-proc))))

; - End Program -

; - Program 17.24, pg. 574 -

(define x->y
  (lambda (x y left right)
    (let ((co-proc (lambda (resume v)
                     (cycle-proc 
                       (lambda ()
                         (let ((symbol-1 (resume left 'ok)))
                           (if (eq? x symbol-1)
                               (let ((symbol-2 (resume left 'more)))
                                 (if (eq? x symbol-2)
                                     (resume right y)
                                     (begin
                                       (resume right symbol-1)
                                       (resume right symbol-2))))
                               (resume right symbol-1))))))))
      (coroutine-maker co-proc))))

; - End Program -

; - Program 17.25, pg. 575 -

(define grune
  (lambda ()
    (let ((grune-receiver 
            (lambda (escape-grune) 
              (letrec
                ((Input (reader (lambda (v) (A v))))
                 (A (x->y 'a 'b (lambda (v) (Input v)) (lambda (v) (B v))))