commit d2155a455673019bc6608fdf7495a05d987509ce parent 642a48b26f8456bb31d1248ff40971f63ebe74fb Author: Yuval Langer <yuval.langer@gmail.com> Date: Sun, 26 Mar 2023 17:16:36 +0300 Splitting the huge file into many smaller ones, more or less one per exercise. Also, more in gitignore. Diffstat:
| M | .gitignore | | | 3 | +++ |
| D | guile.scm | | | 3374 | ------------------------------------------------------------------------------- |
| A | solutions/exercise-1.1.scm | | | 88 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.10.scm | | | 108 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.11.scm | | | 36 | ++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.12.scm | | | 62 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.13.scm | | | 11 | +++++++++++ |
| A | solutions/exercise-1.14.scm | | | 24 | ++++++++++++++++++++++++ |
| A | solutions/exercise-1.16.scm | | | 77 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.17.scm | | | 36 | ++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.18.scm | | | 19 | +++++++++++++++++++ |
| A | solutions/exercise-1.19.scm | | | 71 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.2.scm | | | 30 | ++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.20.scm | | | 170 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.21.scm | | | 58 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.22.scm | | | 57 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.23.scm | | | 76 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.24.scm | | | 54 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.3.scm | | | 34 | ++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.4.scm | | | 27 | +++++++++++++++++++++++++++ |
| A | solutions/exercise-1.5.scm | | | 45 | +++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.6.scm | | | 47 | +++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.7.scm | | | 50 | ++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.8.scm | | | 49 | +++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-1.9.scm | | | 103 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.1.scm | | | 34 | ++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.17.scm | | | 12 | ++++++++++++ |
| A | solutions/exercise-2.18.scm | | | 14 | ++++++++++++++ |
| A | solutions/exercise-2.19.scm | | | 1 | + |
| A | solutions/exercise-2.2.scm | | | 34 | ++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.20.scm | | | 31 | +++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.21.scm | | | 26 | ++++++++++++++++++++++++++ |
| A | solutions/exercise-2.22.scm | | | 45 | +++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.23.scm | | | 26 | ++++++++++++++++++++++++++ |
| A | solutions/exercise-2.24.scm | | | 63 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.25.scm | | | 26 | ++++++++++++++++++++++++++ |
| A | solutions/exercise-2.26.scm | | | 30 | ++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.27.scm | | | 20 | ++++++++++++++++++++ |
| A | solutions/exercise-2.28.scm | | | 27 | +++++++++++++++++++++++++++ |
| A | solutions/exercise-2.29.scm | | | 99 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.3.scm | | | 4 | ++++ |
| A | solutions/exercise-2.30.scm | | | 35 | +++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.31.scm | | | 33 | +++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.32.scm | | | 91 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.33.scm | | | 40 | ++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.34.scm | | | 14 | ++++++++++++++ |
| A | solutions/exercise-2.35.scm | | | 22 | ++++++++++++++++++++++ |
| A | solutions/exercise-2.36.scm | | | 18 | ++++++++++++++++++ |
| A | solutions/exercise-2.37.scm | | | 98 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.38.scm | | | 122 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.39.scm | | | 29 | +++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.4.scm | | | 23 | +++++++++++++++++++++++ |
| A | solutions/exercise-2.40.scm | | | 69 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.41.scm | | | 8 | ++++++++ |
| A | solutions/exercise-2.42.scm | | | 148 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.5.scm | | | 46 | ++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.53.scm | | | 32 | ++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.54.scm | | | 44 | ++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.55.scm | | | 6 | ++++++ |
| A | solutions/exercise-2.56.scm | | | 156 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.59.scm | | | 46 | ++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.6.scm | | | 85 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.60.scm | | | 35 | +++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.61-2.62.scm | | | 55 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.64.scm | | | 96 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/exercise-2.7.scm | | | 68 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/huffman-codes-stuff.scm | | | 137 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/tests/exercise-1.21-tests.scm | | | 42 | ++++++++++++++++++++++++++++++++++++++++++ |
| A | solutions/tests/exercise-2.33-tests.scm | | | 18 | ++++++++++++++++++ |
| A | solutions/tests/exercise-2.34-tests.scm | | | 15 | +++++++++++++++ |
| A | solutions/tests/exercise-2.35-tests.scm | | | 13 | +++++++++++++ |
| A | solutions/tests/exercise-2.36-tests.scm | | | 11 | +++++++++++ |
| A | solutions/tests/exercise-2.40-tests.scm | | | 14 | ++++++++++++++ |
| A | solutions/tests/exercise-2.41-tests.scm | | | 20 | ++++++++++++++++++++ |
| A | solutions/tests/exercise-2.42-tests.scm | | | 19 | +++++++++++++++++++ |
| A | solutions/tests/exercise-2.61-tests.scm | | | 17 | +++++++++++++++++ |
| A | solutions/tests/exercise-2.62-tests.scm | | | 23 | +++++++++++++++++++++++ |
| A | solutions/tests/exercise-2.67-tests.scm | | | 5 | +++++ |
| A | solutions/tests/exercise-2.68-tests.scm | | | 11 | +++++++++++ |
| A | solutions/tests/exercise-2.69-tests.scm | | | 11 | +++++++++++ |
| A | solutions/tree-stuff.scm | | | 515 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
81 files changed, 4117 insertions(+), 3374 deletions(-)
diff --git a/.gitignore b/.gitignore @@ -1 +1,4 @@ *.log +*.scm~ +*\#* +*.scm.* diff --git a/guile.scm b/guile.scm @@ -1,3374 +0,0 @@ -#!/bin/guile \ ---no-auto-compile -!# - -(use-modules (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-26) ; cut <> <...> and cute (which is evaluated non-slots (non-<>)). - (srfi srfi-42) ; list comprehensions with list-ec. - (srfi srfi-64) ; test-begin, test-equal, and test-end. - - (statprof) - - (ice-9 pretty-print) - (ice-9 textual-ports) - (ice-9 time) - - (pict) - ) - -(use-modules (ice-9 format)) - -(define (dp . args) - (cond - ((null? args) '()) - ((null? (cdr args)) - (display (car args)) - (newline)) - (else (display (car args)) - (display " ") - (apply dp (cdr args))))) - -#! - -*Exercise 1.1:* Below is a sequence of expressions. What is the - result printed by the interpreter in response to each expression? - Assume that the sequence is to be evaluated in the order in which - it is presented. -!# - - -10 - -(test-begin "1.1") -(test-equal 10 10) -(test-end "1.1") - -(+ 5 3 4) - -12 - -(- 9 1) - -8 - -(/ 6 2) - -3 - -(+ (* 2 4) (- 4 6)) - -6 - -(define a 3) - -'nothing - -(define b (+ a 1)) - -'nothing - -(+ a b (* a b)) - -19 - -(= a b) - -#f - -(if (and (> b a) (< b (* a b))) - b - a) - -4 - -(cond ((= a 4) 6) - ((= b 4) (+ 6 7 a)) - (else 25)) - -16 - -(+ 2 (if (> b a) b a)) - -6 - -(* (cond ((> a b) a) - ((< a b) b) - (else -1)) - (+ a 1)) - - -16 - -(define (square a) - (* a a)) - -'nothing - -(define (sum-of-squares a b) - (+ (square a) - (square b))) - -'nothing - -#! - - *Exercise 1.2:* Translate the following expression into prefix - form. - - 5 + 4 + (2 - (3 - (6 + 4/5))) - ----------------------------- - 3(6 - 2)(2 - 7) - -!# - -(test-begin "1.2") -(test-equal - (/ (+ 5 - 4 - (- 2 - (- 3 - (+ 6 - (/ 4 5))))) - (* 3 - (- 6 2) - (- 2 7))) - (/ (- 37) 150)) -(test-end "1.2") - -#! - - *Exercise 1.3:* Define a procedure that takes three numbers as - arguments and returns the sum of the squares of the two larger - numbers. - -!# - -(define (exercise-1-3 a b c) - (if (< a b) - (if (< c a) - (sum-of-squares a b) - (sum-of-squares c b)) - (if (< c b) - (sum-of-squares b a) - (sum-of-squares c a)))) - -(test-begin "1.3") -(test-equal (exercise-1-3 2 3 5) 34) -(test-equal (exercise-1-3 2 5 3) 34) -(test-equal (exercise-1-3 3 2 5) 34) -(test-equal (exercise-1-3 3 5 2) 34) -(test-equal (exercise-1-3 5 2 3) 34) -(test-equal (exercise-1-3 5 3 2) 34) -(test-end "1.3") - -#! - - *Exercise 1.4:* Observe that our model of evaluation allows for - combinations whose operators are compound expressions. Use this - observation to describe the behavior of the following procedure: - - (define (a-plus-abs-b a b) - ((if (> b 0) + -) a b)) - -The result of the "if" expression will be either the procedure "+" or -the procedure "-", which is then applied to "a" and "b". - -!# - -#! - - *Exercise 1.5:* Ben Bitdiddle has invented a test to determine - whether the interpreter he is faced with is using - applicative-order evaluation or normal-order evaluation. He - defines the following two procedures: - - (define (p) (p)) - - (define (test x y) - (if (= x 0) - 0 - y)) - - Then he evaluates the expression - - (test 0 (p)) - - What behavior will Ben observe with an interpreter that uses - applicative-order evaluation? What behavior will he observe with - an interpreter that uses normal-order evaluation? Explain your - answer. (Assume that the evaluation rule for the special form - `if' is the same whether the interpreter is using normal or - applicative order: The predicate expression is evaluated first, - and the result determines whether to evaluate the consequent or - the alternative expression.) - -Applicative-order evaluation: - -(test 0 (p)) -(test 0 (p)) -(test 0 and so on) - -Normal-order evaluation: - -(test 0 (p)) -(if (= 0 0) - 0 - (p)) -(if #t - 0 - (p)) -0 - -!# - -#! - - *Exercise 1.6:* Alyssa P. Hacker doesn't see why `if' needs to be - provided as a special form. "Why can't I just define it as an - ordinary procedure in terms of `cond'?" she asks. Alyssa's friend - Eva Lu Ator claims this can indeed be done, and she defines a new - version of `if': - - (define (new-if predicate then-clause else-clause) - (cond (predicate then-clause) - (else else-clause))) - - Eva demonstrates the program for Alyssa: - - (new-if (= 2 3) 0 5) - 5 - - (new-if (= 1 1) 0 5) - 0 - - Delighted, Alyssa uses `new-if' to rewrite the square-root program: - - (define (sqrt-iter guess x) - (new-if (good-enough? guess x) - guess - (sqrt-iter (improve guess x) - x))) - - What happens when Alyssa attempts to use this to compute square - roots? Explain. - -(sqrt-iter 1 2) -(new-if (good-enough? 1 2) - guess - (sqrt-iter (improve 1 2) - 2)) -(new-if #f - guess - (new-if (good-enough? (improve 1 2) 2) - (improve 1 2) - (sqrt-iter (improve (improve 1 2) 2) - 2))) -and so on. - -new-if would first have to evaluate all of its arguments, and only then would it choose the right value using cond. - -!# - -#! - - *Exercise 1.7:* The `good-enough?' test used in computing square - roots will not be very effective for finding the square roots of - very small numbers. Also, in real computers, arithmetic operations - are almost always performed with limited precision. This makes - our test inadequate for very large numbers. Explain these - statements, with examples showing how the test fails for small and - large numbers. An alternative strategy for implementing - `good-enough?' is to watch how `guess' changes from one iteration - to the next and to stop when the change is a very small fraction - of the guess. Design a square-root procedure that uses this kind - of end test. Does this work better for small and large numbers? - -!# - - -(define (square-root x) - (define (average a b) - (/ (+ a b) 2)) - - (define (improve guess x) - ;; (dp guess x) - (average guess (/ x guess))) - - (define (good-enough? old-guess new-guess) - (define bound 0.0000000000001) - (define ratio (/ old-guess new-guess)) - - (define within-bounds - (< (- 1 bound) ratio (+ 1 bound))) - - ;; (dp bound ratio within-bounds) - - within-bounds) - - (define (square-root-iter guess x) - (define new-guess (improve guess x)) - ;; (dp new-guess) - - (if (good-enough? guess new-guess) - guess - (square-root-iter new-guess - x))) - - (square-root-iter 1 x)) - -(format #t "~f\n" (square-root 0.000000000001)) -(format #t "~f\n" (square-root (/ 1 0.000000000001))) - -#! - - *Exercise 1.8:* Newton's method for cube roots is based on the - fact that if y is an approximation to the cube root of x, then a - better approximation is given by the value - - x/y^2 + 2y - ---------- - 3 - - Use this formula to implement a cube-root procedure analogous to - the square-root procedure. (In section *Note 1-3-4:: we will see - how to implement Newton's method in general as an abstraction of - these square-root and cube-root procedures.) - -!# - -(define (cube-root x) - (define (improve guess) - ;; (dp guess x) - - (/ (+ (/ x - (* guess guess)) - (* 2 guess)) - 3)) - - (define (good-enough? old-guess new-guess) - (define bound 0.0000000000001) - (define ratio (/ old-guess new-guess)) - - (define within-bounds - (< (- 1 bound) ratio (+ 1 bound))) - - ;; (dp bound ratio within-bounds) - - within-bounds) - - (define (cube-root-iter guess) - (define new-guess (improve guess)) - ;; (dp new-guess) - - (if (good-enough? guess new-guess) - guess - (cube-root-iter new-guess))) - - (cube-root-iter 1)) - -(format #t "(cube-root ~f) => ~f\n" 0.000000000001 (cube-root 0.000000000001)) -(format #t "(cube-root ~f) => ~f\n" (/ 1 0.000000000001) (cube-root (/ 1 0.000000000001))) - -#! - - *Exercise 1.9:* Each of the following two procedures defines a - method for adding two positive integers in terms of the procedures - `inc', which increments its argument by 1, and `dec', which - decrements its argument by 1. - - (define (+ a b) - (if (= a 0) - b - (inc (+ (dec a) b)))) - - (define (+ a b) - (if (= a 0) - b - (+ (dec a) (inc b)))) - - Using the substitution model, illustrate the process generated by - each procedure in evaluating `(+ 4 5)'. Are these processes - iterative or recursive? - -First: - -(+ 4 5) -(if (= 4 0) - 5 - (inc (+ (dec 4) 5))) -(if #f - 5 - (inc (+ (dec 4) 5))) -(inc (+ (dec 4) 5)) -(inc (+ 3 5)) -(inc (if (= 3 0) - 5 - (inc (+ (dec 3) 5)))) -(inc (if #f - 5 - (inc (+ (dec 3) 5)))) -(inc - (inc (+ (dec 3) 5))) -(inc - (inc (+ 2 5))) -(inc - (inc (if (= 2 0) - 5 - (inc (+ (dec 2) 5))))) -(inc - (inc (if #f - 5 - (inc (+ (dec 2) 5))))) -(inc - (inc - (inc (+ (dec 2) 5)))) -(inc - (inc - (inc (+ 1 5)))) -(inc - (inc - (inc (if (= 1 0) - 5 - (inc (+ (dec 1) 5)))))) -(inc - (inc - (inc (if #f - 5 - (inc (+ (dec 1) 5)))))) -(inc (inc (inc (inc (+ (dec 1) 5))))) -(inc (inc (inc (inc (+ 0 5))))) -(inc (inc (inc (inc (if (= 0 0) 5 (inc (+ (dec 0) 5))))))) -(inc (inc (inc (inc (if #t 5 (inc (+ (dec 0) 5))))))) -(inc (inc (inc (inc 5)))) -(inc (inc (inc 6))) -(inc (inc 7)) -(inc 8) -9 - -Recursive. - -Second: - -(+ 4 5) -(if (= 4 0) 5 (+ (dec 4) (inc 5))) -(if #f 5 (+ (dec 4) (inc 5))) -(+ 3 6) -(if (= 3 0) 6 (+ (dec 3) (inc 6))) -(if #f 6 (+ (dec 3) (inc 6))) -(+ (dec 3) (inc 6)) -(+ 2 7) -(if (= 2 0) 7 (+ (dec 2) (inc 7))) -(if #f 7 (+ (dec 2) (inc 7))) -(+ (dec 2) (inc 7)) -(+ 1 8) -(if (= 1 0) 8 (+ (dec 1) (inc 8))) -(if #f 8 (+ (dec 1) (inc 8))) -(+ (dec 1) (inc 8)) -(+ 0 9) -(if (= 0 0) 9 (+ (dec 0) (inc 9))) -(if #f 9 (+ (dec 0) (inc 9))) -9 - -Iterative. - -!# - -#! - - *Exercise 1.10:* The following procedure computes a mathematical - function called Ackermann's function. - - (define (A x y) - (cond ((= y 0) 0) - ((= x 0) (* 2 y)) - ((= y 1) 2) - (else (A (- x 1) - (A x (- y 1)))))) - - What are the values of the following expressions? - - (A 1 10) - - (A 2 4) - - (A 3 3) - - Consider the following procedures, where `A' is the procedure - defined above: - - (define (f n) (A 0 n)) - - (define (g n) (A 1 n)) - - (define (h n) (A 2 n)) - - (define (k n) (* 5 n n)) - - Give concise mathematical definitions for the functions computed - by the procedures `f', `g', and `h' for positive integer values of - n. For example, `(k n)' computes 5n^2. - - - (define (A x y) - (cond ((= y 0) 0) - ((= x 0) (* 2 y)) - ((= y 1) 2) - (else (A (- x 1) - (A x (- y 1)))))) - -(A 1 10) -(cond ((= 10 0) 0) - ((= 1 0) (* 2 10)) - ((= 10 1) 2) - (else (A (- 1 1) - (A 1 (- 10 1))))) -(A (- 1 1) - (A 1 (- 10 1))) -(A 0 (A 1 9)) -(A 0 (A 0 (A 1 8))) -(A 0 (A 0 (A 0 (A 1 7)))) -(A 0 (A 0 (A 0 (A 0 (A 1 6))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 1 5)))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 4))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 3)))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 2))))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 1)))))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 2))))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (* 2 2))))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 8))))))) -(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 16)))))) -(A 0 (A 0 (A 0 (A 0 (A 0 32))))) -(A 0 (A 0 (A 0 (A 0 64)))) -(A 0 (A 0 (A 0 128))) -(A 0 (A 0 256)) -(A 0 512) -1024 - - (define (A x y) - (cond ((= y 0) 0) - ((= x 0) (* 2 y)) - ((= y 1) 2) - (else (A (- x 1) - (A x (- y 1)))))) - - -(A 2 4) -(cond ((= 4 0) 0) - ((= 2 0) (* 2 4)) - ((= 4 1) 2) - (else (A (- 2 1) - (A 2 (- 4 1))))) -(A 1 - (A 1 (A 2 (- 3 1)))) - -(A 1 - (A 1 (A 2 (- 3 1)))) -(A 1 - (A 1 (A 2 (- 3 1)))) - - -!# - -(define (A x y) - (cond ((= y 0) 0) - ((= x 0) (* 2 y)) - ((= y 1) 2) - (else (A (- x 1) - (A x (- y 1)))))) - -(test-begin "1.10") -'(test-equal 1024 (A 1 10)) -'(test-equal 1024 (A 2 4)) -(test-end "1.10") - -#! - - *Exercise 1.11:* A function f is defined by the rule that f(n) = n - if n<3 and f(n) = f(n - 1) + 2f(n - 2) + 3f(n - 3) if n>= 3. - Write a procedure that computes f by means of a recursive process. - Write a procedure that computes f by means of an iterative - process. - -!# - -(define (f-recursive n) - (cond - ((< n 3) n) - (else (+ (f-recursive (1- n)) - (* 2 (f-recursive (- n 2))) - (* 3 (f-recursive (- n 3))))))) - -(define (f-iterative n) - (define (f i n a b c) - (cond - ((= i n) a) - (else (f (1+ i) - n - b - c - (+ c - (* 2 b) - (* 3 a)))))) - (f 0 n 0 1 2)) - -(test-begin "1.11") -(test-equal - (map f-recursive '(0 1 2 3 4 5 6 7)) - (map f-iterative '(0 1 2 3 4 5 6 7))) -(test-end "1.11") - -#! - - *Exercise 1.12:* The following pattern of numbers is called "Pascal's - triangle". - - 1 - 1 1 - 1 2 1 - 1 3 3 1 - 1 4 6 4 1 - - The numbers at the edge of the triangle are all 1, and each number - inside the triangle is the sum of the two numbers above it.(4) - Write a procedure that computes elements of Pascal's triangle by - means of a recursive process. - -!# - -(define (pascal line column) - (cond - ((or (= column 0) - (= column line)) 1) - (else (+ (pascal (1- line) - (1- column)) - (pascal (1- line) - column))))) - -(test-begin "1.12") -(test-equal - (list (pascal 0 0) - (pascal 1 0) - (pascal 1 1) - (pascal 2 0) - (pascal 2 1) - (pascal 2 2) - (pascal 3 0) - (pascal 3 1) - (pascal 3 2) - (pascal 3 3) - (pascal 4 0) - (pascal 4 1) - (pascal 4 2) - (pascal 4 3) - (pascal 4 4) - ) - '(1 - 1 - 1 - 1 - 2 - 1 - 1 - 3 - 3 - 1 - 1 - 4 - 6 - 4 - 1)) -(test-end "1.12") - -#! - - *Exercise 1.13:* Prove that _Fib_(n) is the closest integer to - [phi]^n/[sqrt](5), where [phi] = (1 + [sqrt](5))/2. Hint: Let - [illegiblesymbol] = (1 - [sqrt](5))/2. Use induction and the - definition of the Fibonacci numbers (see section *Note 1-2-2::) to - prove that _Fib_(n) = ([phi]^n - [illegiblesymbol]^n)/[sqrt](5). - -!# - -#! oh boy. !# - -#! - -1.14 - -!# - -(define (count-change amount) - (cc amount 5)) - -(define (cc amount kinds-of-coins) - (cond ((= amount 0) 1) - ((or (< amount 0) (= kinds-of-coins 0)) 0) - (else (+ (cc amount - (- kinds-of-coins 1)) - (cc (- amount - (first-denomination kinds-of-coins)) - kinds-of-coins))))) - -(define (first-denomination kinds-of-coins) - (cond ((= kinds-of-coins 1) 1) - ((= kinds-of-coins 2) 5) - ((= kinds-of-coins 3) 10) - ((= kinds-of-coins 4) 25) - ((= kinds-of-coins 5) 50))) - -#! - -1.16 - -!# - -(define (flatten a) - (cond - ((null? a) '()) - (else (append (car a) (flatten (cdr a)))))) - -(test-begin "flatten") -(test-equal (flatten '((1 2) (3 4) (5 6))) '(1 2 3 4 5 6)) -(test-end "flatten") - -(define (cartesian a b) - (define (cartesian' a-element b) - (cond - ((null? b) '()) - (else (cons (cons a-element (car b)) - (cartesian' a-element (cdr b)))))) - (cond - ((null? a) '()) - (else (flatten (map (cut cartesian' <> b) a))))) - -(test-begin "cartesian") -(test-equal - (cartesian '(1 2 3) - '(4 5 6)) - '((1 . 4) - (1 . 5) - (1 . 6) - (2 . 4) - (2 . 5) - (2 . 6) - (3 . 4) - (3 . 5) - (3 . 6))) -(test-end "cartesian") - -(define (fast-expt-recursive b n) - (cond ((= n 0) 1) - ((even? n) (square (fast-expt-recursive b (/ n 2)))) - (else (* b (fast-expt-recursive b (- n 1)))))) - -(define (fast-expt-iterative b n) - (define (f a b n) - (cond - ((= n 0) a) - ((even? n) (f a - (* b b) - (/ n 2))) - (else (f (* a b) - b - (1- n))))) - (f 1 b n)) - -(test-begin "1.16") -(test-equal (fast-expt-recursive 2 3) (fast-expt-iterative 2 3)) -;; 1 * 2**3 = -;; 2 * 2**2 = 2 * (2**1)**2 -;; 2 * -(test-equal (fast-expt-iterative 3 5) (fast-expt-recursive 3 5)) -;; a * b^n = -;; 1 * 3^5 = -;; 3 * 3^4 = -;; 3 * 3 * 3 * 3^2 -;; 3 * 3 * 3 * 3 * 3 -(test-equal (fast-expt-iterative 5 7) (fast-expt-recursive 5 7)) -;; 5**7 = -;; 5 * (5**3)**2 = -;; 5 * (5**2)**3 -;; 5 * 5**2 * 5**3 = -;; 5 * 5**2 * 5 * 5**2 = -(test-equal (fast-expt-iterative 7 11) (fast-expt-recursive 7 11)) -(test-end "1.16") - -;; Exercise 1.17 - -(define (*-recursive a b) - (if (= b 0) - 0 - (+ a (*-recursive a (- b 1))))) - -(define (double n) - (* 2 n)) - -(define (halve n) - (/ n 2)) - -(define (fast-*-recursive a b) - (cond - ((= b 0) 0) - ((even? b) (+ (double a) - (fast-*-recursive a - (- b 2)))) - (else (+ a (fast-*-recursive a (1- b)))))) - -(test-begin "1.17") -(test-equal (*-recursive 2 3) (fast-*-recursive 2 3)) -;; a * b = -;; 2 * 3 = odd b -;; 4 * 2 = even b -;; -(test-equal (* 3 5) (*-recursive 3 5)) -(test-equal (* 5 7) (*-recursive 5 7)) -(test-equal (* 7 11) (*-recursive 7 11)) - -(test-equal (* 3 5) (fast-*-recursive 3 5)) -(test-equal (* 5 7) (fast-*-recursive 5 7)) -(test-equal (* 7 11) (fast-*-recursive 7 11)) -(test-end "1.17") - -;; Exercise 1.18 - -(define (fast-*-iterative a b) - (define (f result a b) - (cond - ((= b 0) result) - ((even? b) (f result - (double a) - (halve b))) - (else (f (+ result a) a (1- b))))) - (f 0 a b)) - -(test-begin "1.18") -(test-equal (* 3 5) (fast-*-iterative 3 5)) -;; 0 3 5 -;; -(test-equal (* 5 7) (fast-*-iterative 5 7)) -(test-equal (* 7 11) (fast-*-iterative 7 11)) -(test-end "1.18") - -;; Exercise 1.19 - -;; T -;; a <- (a + b) -;; b <- a -;; -;; Tpq = -;; a <- bq + aq + ap -;; a <- bq + a(q + p) -;; b <- bp + aq -;; -;; Tpq^2 = -;; a' <- (bp + aq)q + (bq + aq + ap)q + (bq + aq + ap)p -;; a' <- bpq + aq^2 + bq^2 + aq^2 + apq + bpq + apq + ap^2 -;; a' <- 2bpq + 2aq^2 + bq^2 + 2apq + ap^2 -;; a' <- b(2pq + q^2) + (2apq + ap^2 + 2aq^2) -;; a' <- b(2pq + q^2) + a(2pq + p^2 + 2q^2) -;; q = 2pq + q^2 -;; p + q = 2pq + p^2 + 2q^2 -;; p = (2pq + p^2 + 2q^2) - (2pq + q^2) -;; p = 2pq + p^2 + 2q^2 - 2pq - q^2 -;; p = p^2 + q^2 -;; a' <- b(2pq + q^2) + a(2pq + q^2) + a(p^2 + q^2) -;; -;; oh. i'm dumb. we already have q' and p' in terms of q and p here: -;; -;; b' <- (bp + aq)p + (bq + aq + ap)q -;; b' <- bp^2 + apq + bq^2 + aq^2 + apq -;; b' <- bp^2 + 2apq + bq^2 + aq^2 -;; b' <- bp^2 + bq^2 + 2apq + aq^2 -;; b' <- b(p^2 + q^2) + a(2pq + q^2) - -(define (fib n) - (cond - ((= n 0) 0) - ((= n 1) 1) - (else (+ (fib (1- n)) - (fib (- n 2)))))) - -(define (fast-fib n) - (define (fib-iter a b p q count) - (cond - ((= count 0) b) - ((even? count) - (fib-iter a - b - (+ (* p p) - (* q q)) - (+ (* 2 p q) - (* q q)) - (/ count 2))) - (else - (fib-iter (+ (* b q) - (* a q) - (* a p)) - (+ (* b p) - (* a q)) - p - q - (1- count))))) - (fib-iter 1 0 0 1 n)) - -(test-begin "1.19") -(test-equal (fib 0) (fast-fib 0)) -(test-equal (fib 1) (fast-fib 1)) -(test-equal (fib 2) (fast-fib 2)) -(test-equal (fib 3) (fast-fib 3)) -(test-equal (fib 4) (fast-fib 4)) -(test-equal (fib 5) (fast-fib 5)) -(test-end "1.19") - -;; Exercise 1.20 - - - -(define (gcd-iterative a b) - ;; a = b*d + r - (if (= b 0) - a - (gcd-iterative b (remainder a b)))) - -;; Normal-order - -(test-begin "1.20") -(test-equal (gcd-iterative 206 40) (gcd 206 40)) -(test-equal (if (= 40 0) - 206 - (gcd 40 (remainder 206 40))) 2) -(test-equal (if #f - 206 - (gcd 40 (remainder 206 40))) 2) -(test-equal (gcd 40 (remainder 206 40)) 2) -(test-equal (if (= (remainder 206 40) 0) ;; 1 remainder - 40 - (gcd (remainder 206 40) - (remainder 40 - (remainder 206 40)))) 2) -(test-equal (if (= 6 0) - 40 - (gcd (remainder 206 40) - (remainder 40 - (remainder 206 40)))) 2) -(test-equal (gcd (remainder 206 40) - (remainder 40 - (remainder 206 40))) 2) -(test-equal (if (= (remainder 40 - (remainder 206 40)) 0) - (remainder 206 40) - (gcd (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))))) 2) -(test-equal (if (= 4 0) ;; previous 1 and 2 here equals 3 - (remainder 206 40) - (gcd (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))))) 2) -(test-equal (gcd (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))) 2) -(test-equal 2 (if (= (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) 0) - (remainder 40 - (remainder 206 40)) - (gcd (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))))))) -(test-equal 2 (if (= 2 0) ;; 4 now plus 3 previously is 5 - (remainder 40 - (remainder 206 40)) - (gcd (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))))))) -(test-equal 2 (gcd (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))))) -(test-equal 2 (if (= (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))) 0) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (gcd - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))) - (reminder (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))))))) -(test-equal 2 (if (= 0 0) ;; 5 previously plus 7 = 12 - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (gcd - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))) - (reminder (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40))) - (remainder (remainder 40 - (remainder 206 40)) - (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))))))) -(test-equal 2 (remainder (remainder 206 40) - (remainder 40 - (remainder 206 40)))) ;; 12 previously and 4 now is 16. - -;; Now for applicative-order evaluation: -(test-equal 2 (gcd 206 40)) -(test-equal 2 (if (= 40 0) - 206 - (gcd 40 (remainder 206 40)))) -(test-equal 2 (if #f - 206 - (gcd 40 (remainder 206 40)))) -(test-equal 2 (gcd 40 (remainder 206 40))) -(test-equal 2 (gcd 40 6)) ;; 1 -(test-equal 2 (if (= 6 0) - 40 - (gcd 6 (remainder 40 6)))) -(test-equal 2 (gcd 6 (remainder 40 6))) -(test-equal 2 (gcd 6 4)) ;; 2 -(test-equal 2 (if (= 4 0) - 6 - (gcd 4 (remainder 6 4)))) -(test-equal 2 (if #f - 6 - (gcd 4 (remainder 6 4)))) -(test-equal 2 (gcd 4 (remainder 6 4))) -(test-equal 2 (gcd 4 2)) ;; 3 -(test-equal 2 (if (= 2 0) - 4 - (gcd 2 (remainder 4 2)))) -(test-equal 2 (if #f - 4 - (gcd 2 (remainder 4 2)))) -(test-equal 2 (gcd 2 (remainder 4 2))) -(test-equal 2 (gcd 2 0)) ;; 4 -(test-equal 2 (if (= 0 0) - 2 - (gcd 0 (remainder 2 0)))) -(test-equal 2 (if #t - 2 - (gcd 0 (remainder 2 0)))) -(test-equal 2 2) -(test-end "1.20") - -;; 1.21 - -(define (smallest-divisor n) - (find-divisor n 2)) - -(define (find-divisor n test-divisor) - (cond - ((> (square test-divisor) n) - n) - - ((divides? test-divisor n) - test-divisor) - - (else (find-divisor n (1+ test-divisor))))) - -(define (divides? a b) - (= (remainder b a) 0)) - -(define (prime? n) - (= n (smallest-divisor n))) - -(test-begin "prime") -(test-equal '(#t #f #t #f #t #f) (map (cut divides? 2 <>) '(2 3 4 5 6 7))) -(test-equal '(2 3 2 5 2 7) (map smallest-divisor '(2 3 4 5 6 7))) -(test-equal '(#t #t #f #t #f #t) (map prime? '(2 3 4 5 6 7))) -(test-end "prime") - -(define (expmod base exp m) - (cond - ((= exp 0) 1) - ((even? exp) - (remainder - (square (expmod base - (/ exp 2) - m)) - m)) - (else - (remainder - (* base - (expmod base - (1- exp) - m)) - m)))) - -(test-begin "expmod") -(let ((cases (map (lambda (_) (list (1+ (random 100)) - (1+ (random 100)))) - (iota 20)))) - (test-equal - (map (lambda (x) (apply (lambda (a n) (= (expmod a - n - n) - a)) - x)) cases) - (map (lambda (x) (apply (lambda (a n) (= (remainder (expt a n) - n) - a)) - x)) - cases))) -(test-end "expmod") - -(define (fermat-test n) - (define (try-it a) - (= (expmod a n n) - a)) - (try-it (1+ (random (1- n))))) - -(define (fast-prime? n times) - (cond - ((zero? times) #t) - ((fermat-test n) - (fast-prime? n (1- times))) - (else #f))) - -(test-begin "fast-prime") -(test-equal - (map (lambda (n) (fast-prime? n n)) (iota 100 2)) - (map (cut prime? <>) (iota 100 2))) -(test-end "fast-prime") - -;; Exercise 1.21 - -(test-begin "1.21") -(let ((cases '(199 1999 19999)) - (results '(199 1999 7))) - (test-equal - results - (map (lambda (case) (smallest-divisor case)) cases))) -(test-end "1.21") - -;; Exercise 1.22 - -(define (run-delay-if-full-flag d) - (if (any (cut equal? "--full" <>) - (command-line)) - (force d))) - -(run-delay-if-full-flag - (delay - (let ((port (open-output-file "primes.txt"))) - - (define (runtime) - (time-nanosecond (current-time time-process))) - - (define (display x) - (format port "~a" x)) - - (define (newline) - (format port "\n")) - - (define (timed-prime-test n) - ;; (newline) - ;; (display n) - (start-timed-test n (runtime))) - - (define (start-timed-test n start-time) - (cond - ((prime? n) - (newline) - (display "[") - (display n) - (report-prime (- (runtime) - start-time))) - (else #f))) - - (define (report-prime elapsed-time) - (display ", ") - (display elapsed-time) - (display "],") - (newline) - #t) - - (define (search-for-primes start-number end-number) - (cond - ((> start-number end-number) '()) - ((timed-prime-test start-number) - (cons start-number - (search-for-primes (+ start-number 2) end-number))) - (else (search-for-primes (+ start-number 2) end-number)))) - - (display "[") - - (search-for-primes 3 100001) - - (display "]") - (newline)))) - -;; Exercise 1.23 - -(define (next test-divisor) - (if (= test-divisor 2) - 3 - (+ test-divisor 2))) - -(define (smallest-divisor n) - (find-divisor n 2)) - -(define (find-divisor n test-divisor) - (cond - ((> (square test-divisor) n) - n) - - ((divides? test-divisor n) - test-divisor) - - (else (find-divisor n (next test-divisor))))) - -(test-begin "prime-1.23") -(test-equal '(#t #f #t #f #t #f) (map (cut divides? 2 <>) '(2 3 4 5 6 7))) -(test-equal '(2 3 2 5 2 7) (map smallest-divisor '(2 3 4 5 6 7))) -(test-equal '(#t #t #f #t #f #t) (map prime? '(2 3 4 5 6 7))) -(test-end "prime-1.23") - -(run-delay-if-full-flag - (delay - (let ((port (open-output-file "primes-half.txt"))) - - (define (runtime) - (time-nanosecond (current-time time-process))) - - (define (display x) - (format port "~a" x)) - - (define (newline) - (format port "\n")) - - (define (timed-prime-test n) - ;; (newline) - ;; (display n) - (start-timed-test n (runtime))) - - (define (start-timed-test n start-time) - (cond - ((prime? n) - (newline) - (display "[") - (display n) - (report-prime (- (runtime) - start-time))) - (else #f))) - - (define (report-prime elapsed-time) - (display ", ") - (display elapsed-time) - (display "],") - (newline) - #t) - - (define (search-for-primes start-number end-number) - (cond - ((> start-number end-number) '()) - ((timed-prime-test start-number) - (cons start-number - (search-for-primes (+ start-number 2) end-number))) - (else (search-for-primes (+ start-number 2) end-number)))) - - (display "[") - - (search-for-primes 3 100001) - - (display "]") - (newline)))) - -;; Exercise 1.24 - - -(run-delay-if-full-flag - (delay - (let ((port (open-output-file "primes-fast-prime.txt"))) - - (define (runtime) - (time-nanosecond (current-time time-process))) - - (define (display x) - (format port "~a" x)) - - (define (newline) - (format port "\n")) - - (define (timed-prime-test n) - ;; (newline) - ;; (display n) - (start-timed-test n (runtime))) - - (define (start-timed-test n start-time) - (cond - ((fast-prime? n (inexact->exact (ceiling (* n 0.01)))) - (newline) - (display "[") - (display n) - (report-prime (- (runtime) - start-time))) - (else #f))) - - (define (report-prime elapsed-time) - (display ", ") - (display elapsed-time) - (display "],") - (newline) - #t) - - (define (search-for-primes start-number end-number) - (cond - ((> start-number end-number) '()) - ((timed-prime-test start-number) - (cons start-number - (search-for-primes (+ start-number 2) end-number))) - (else (search-for-primes (+ start-number 2) end-number)))) - - (display "[") - - (search-for-primes 3 100001) - - (display "]") - (newline)))) - -;; Exercise 2.1 - -(define (make-rat n d) - (define g (gcd n d)) - (define sign (if (or (and (< n 0) - (> d 0)) - (and (> n 0) - (< d 0))) - -1 - 1)) - (cons (* sign - (abs (/ n g))) - (abs (/ d g)))) - -(test-begin "2.1") -(let () - (define (make-test) - (define n-sign (1- (* 2 - (random 2)))) - (define d-sign (1- (* 2 - (random 2)))) - (define n (* n-sign - (random 100))) - (define d (* d-sign - (1+ (random 100)))) - - (define built-in-rational (/ n d)) - (define ratsui (cons (numerator built-in-rational) - (denominator built-in-rational))) - (define matsui (make-rat n d)) - (test-equal (list n d ratsui) (list n d matsui))) - - (for-each (lambda (_) (make-test)) (iota 100))) -(test-end "2.1") - -;; Exercise 2.2 - -(define (make-point x y) - (cons x y)) - -(define (x-point p) (car p)) - -(define (y-point p) (cdr p)) - -(define (make-segment p-start p-end) - (cons p-start p-end)) - -(define (start-segment s) (car s)) - -(define (end-segment s) (cdr s)) - -(define (midpoint-segment s) - (define start (start-segment s)) - (define end (end-segment s)) - - (make-point (/ (- (x-point end) - (x-point start)) - 2) - (/ (- (y-point end) - (y-point start)) - 2))) - -(test-begin "2.2") -(test-equal - (make-point 5 2) - (midpoint-segment (make-segment (make-point 0 0) - (make-point 10 4))) -) -(test-end) - -;; Exercise 2.3 - -(define (make-rectangle segment angle) - '()) - -;; Exercise 2.4 - -(test-begin "2.4") - -(let ((cons (lambda (x y) (lambda (m) (m x y)))) - (car (lambda (z) (z (lambda (p q) p)))) - (cdr (lambda (z) (z (lambda (p q) q))))) - - - (for-each - (lambda (matsui) (test-equal 'x matsui)) - (list (car (cons 'x 'y)) - (car (lambda (m) (m 'x 'y))) - ((lambda (m) (m 'x 'y)) (lambda (p q) p)) - ((lambda (p q) p) 'x 'y))) - (for-each - (lambda (matsui) (test-equal 'y matsui)) - (list (cdr (cons 'x 'y)) - (cdr (lambda (m) (m 'x 'y))) - ((lambda (m) (m 'x 'y)) (lambda (p q) q)) - ((lambda (p q) q) 'x 'y)))) - -(test-end "2.4") - -;; Exercise 2.5 - -(define (power a b) - (define (power' a b result) - (cond - ((= b 0) result) - (else (power' a (1- b) (* a result))))) - (power' a b 1)) - -(test-begin "power") -(test-equal 8 (power 2 3)) -(test-end "power") - -(define (exercise-2.5) - (define (cons a b) - (* (power 2 a) - (power 3 b))) - - (define (car z) - (define (car' z result) - (cond - ((odd? z) result) - (else (car' (/ z 2) - (1+ result))))) - - (car' z 0)) - - (define (cdr z) - (define (cdr' z result) - (cond - ((not (= (remainder z 3) 0)) result) - (else (cdr' (/ z 3) - (1+ result))))) - - (cdr' z 0)) - - (test-begin "2.5") - (do-ec (: a 1 10) - (: b 1 10) - (test-equal - (list a b) - (list (car (cons a b)) - (cdr (cons a b))))) - (test-end "2.5")) - -(exercise-2.5) - -;; Exercise 2.6 - -(define (exercise-2.6) - (define zero - (lambda (f) - (lambda (x) - x))) - - (define (add-1 n) - (lambda (f) - (lambda (x) - (f ((n f) x))))) - - (add-1 zero) - - (lambda (f) - (lambda (x) - (f ((zero f) x)))) - - (lambda (f) - (lambda (x) - (f (((lambda (f) - (lambda (x) x)) f) x)))) - (lambda (f) - (lambda (x) - (f ((lambda (x) x) x)))) - - (define one - (lambda (f) - (lambda (x) - (f x)))) - - (add-1 one) - - (lambda (f) - (lambda (x) - (f ((one f) x)))) - - (lambda (f) - (lambda (x) - (f (((lambda (f) - (lambda (x) - (f x))) f) x)))) - - (lambda (f) - (lambda (x) - (f ((lambda (x) - (f x)) x)))) - - (lambda (f) - (lambda (x) - (f (f x)))) - - (define two - (lambda (f) - (lambda (x) - (f (f x))))) - - (define (church-+ a b) - (lambda (f) - (lambda (x) - ((b f) ((a f) x))))) - - (test-begin "2.6") - (test-equal 0 ((zero 1+) 0)) - (test-equal 1 (((add-1 zero) 1+) 0)) - (test-equal 1 ((one 1+) 0)) - (test-equal 2 (((add-1 (add-1 zero)) 1+) 0)) - (test-equal 2 (((add-1 one) 1+) 0)) - (test-equal 2 ((two 1+) 0)) - (test-equal 3 (((add-1 two) 1+) 0)) - - (do-ec (: elements (list (zip (list zero one two) - (iota 3)))) - (: a elements) - (: b elements) - (test-equal - (+ (cadr a) - (cadr b)) - (((church-+ (car a) - (car b)) 1+) 0))) - (test-end "2.6")) - -(exercise-2.6) - -(define (exercise-2.7) - (define (make-interval lower higher) - (cons lower higher)) - (define (lower-bound interval) - (car interval)) - (define (upper-bound interval) - (cdr interval)) - - (define (add-interval x y) - (make-interval (+ (lower-bound x) - (lower-bound y)) - (+ (upper-bound x) - (upper-bound y)))) - - (define (mul-interval x y) - (let* ((bound-getters (list lower-bound higher-bound)) - (ps (list-ec (: x-bound bound-getters) - (: y-bound bound-getters) - (* (x-bound x) - (y-bound y))))) - (make-interval (min ps) - (max ps)))) - - (define (div-interval x y) - (mul-interval x (make-interval (/ 1.0 (upper-bound y)) - (/ 1.0 (lower-bound y))))) - - (define (sub-interval x y) - (make-interval (- (lower-bound x) - (lower-bound y)) - (- (upper-bound x) - (upper-bound y)))) - - (define (width-interval x) - (/ (- (upper-bound x) - (lower-bound x)) - 2)) - - (width-interval (add-interval x y)) - (width-interval (make-interval (+ (lower-bound x) - (lower-bound y)) - (+ (upper-bound x) - (upper-bound y)))) - (/ (- (upper-bound (make-interval (+ (lower-bound x) - (lower-bound y)) - (+ (upper-bound x) - (upper-bound y)))) - (lower-bound (make-interval (+ (lower-bound x) - (lower-bound y)) - (+ (upper-bound x) - (upper-bound y))))) - 2) - (/ (- (+ (upper-bound x) - (upper-bound y)) - (+ (lower-bound x) - (lower-bound y))) - 2) - - (add-interval (width-interval x) - (width-interval y)) - (add-interval (/ (- (upper-bound x) (lower-bound x)) 2) - (/ (- (upper-bound y) (lower-bound y)) 2)) - (make-interval ((/ (- (upper-bound x) (lower-bound x)) 2)) - (/ (- (upper-bound y) (lower-bound y)) 2)) - ) - -;;;(exercise-2.7) - -;; Exercise 2.17 - -(define (last-pair xs) - (cond - ((pair? (cdr xs)) (last-pair (cdr xs))) - (else xs))) - -(test-begin "2.17") -(test-equal - '(3) - (last-pair '(1 2 3))) -(test-end "2.17") - -;; Exercise 2.18 - -(let* ([reverse - (lambda (xs) - (cond - ((null? xs) '()) - (else (append (reverse (cdr xs)) - (list (car xs))))))]) - - (test-begin "2.18") - (test-equal - '(3 2 1) - (reverse '(1 2 3))) - (test-end "2.18")) - -;; Exercise 2.19 XXX - -;; Exercise 2.20 - -(define (same-arity n . ns) - (define (same-arity' n ns) - (cond - ((null? ns) - (list n)) - ((or (and (even? n) - (even? (car ns))) - (and (odd? n) - (odd? (car ns)))) - (cons n - (same-arity' (car ns) - (cdr ns)))) - (else - (cons n - (same-arity' (cadr ns) - (cddr ns)))))) - (same-arity' n ns)) - - -(test-begin "2.20") -(test-equal - '(1 3 5 7) - (same-arity 1 2 3 4 5 6 7)) -(test-equal - '(2 4 6 8) - (same-arity 2 3 4 5 6 7 8)) -(test-equal '(1) (same-arity 1)) -(test-equal '(2) (same-arity 2)) -(test-end "2.20") - -;; Exercise 2.21 - -(define (exercise-2.21) - (define (square-list-1 items) - (if (null? items) - '() - (cons (* (car items) - (car items)) - (square-list-1 (cdr items))))) - - (define (square-list-2 items) - (map (lambda (item) - (* item - item)) - items)) - - (test-begin "2.21") - (test-equal - '(1 4 9 16) - (square-list-1 '(1 2 3 4))) - (test-equal - '(1 4 9 16) - (square-list-2 '(1 2 3 4))) - (test-end "2.21")) - -(exercise-2.21) - -;; Exercise 2.22 - -(define (exercise-2.22) - (define (square-list-1 items) - ;; answer is build by consing the first element of items onto the input nil - ;; (item-1 . nil) then the second onto (item-1 . nil), (item-2 . (item-1 . nil)) - ;; and the third (item-3 . (item-2 . (item-1 . nil))). - ;; In other words, you start by consing the first item onto the end of answer - ;; and you end by consing the last item of items onto the start of answer, - ;; building the cons onion inside out. - (define (iter things answer) - (if (null? things) - answer - (iter (cdr things) - (cons (* (car things) - (car things)) - answer)))) - (iter items '())) - - (define (square-list-2 items) - ;; In the second attempt you cons the answer to the first item (nil . item-1) - ;; then the answer onto the second item ((nil . item-1) item-2) and so on - ;; until you cons the answer onto the last item (... . item-n) which is the - ;; same as the first attempt, but instead of the accepted - ;; items-go-on-car-rest-of-list-goes-on-cdr, you have items-go-on-cdr-rest-of-list-goes-on-car. - ;; ((((nil . item-1) . item-2) . item-3) . item-4). - (define (iter things answer) - (if (null? things) - answer - (iter (cdr things) - (cons answer - (* (car things) - (car things)))))) - (iter items '())) - - (test-begin "2.22") - (test-equal - '(16 9 4 1) - (square-list-1 '(1 2 3 4))) - (test-equal - '((((() . 1) . 4) . 9) . 16) - (square-list-2 '(1 2 3 4))) - (test-end "2.22")) - -(exercise-2.22) - -;; Exercise 2.23 - -(define (exercise-2.23) - (define (my-for-each proc lst) - (cond - ((null? lst) - '()) - (else - (proc (car lst)) - (my-for-each proc - (cdr lst))))) - - (define xs (list 1 2 3 4)) - - (test-begin "2.23") - (test-equal - '(1 2 3 4 5 6) - (begin - (my-for-each (lambda (x) - (set! xs (append xs - (list x)))) - '(5 6)) - xs)) - (test-end "2.23")) - -(exercise-2.23) - -;; Exercise 2.24 - -;; scheme@(guile-user)> (list 1 (list 2 (list 3 4))) -;; $1 = (1 (2 (3 4))) - -;; -----> [1 |] -;; | -;; \--> [| ()] -;; | -;; \-> [2 |] -;; | -;; \-> [| ()] -;; | -;; \-> [3 |] -;; | -;; \-> [4 ()] - -;; (1 (2 (3 4))) -;; /\ -;; 1 (2 (3 4)) -;; /\ -;; 2 (3 4) -;; /\ -;; 3 4 - -(let* ([xs-34 (list 3 4)] - [xs-234 (list 2 xs-34)] - [xs-1234 (list 1 xs-234)]) - (test-begin "2.24") - (test-equal - (list 1 - (list 2 - (list 3 - 4))) - (cons 1 - (cons (cons 2 - (cons (cons 3 - (cons 4 - '())) - '())) - '()))) - (test-equal - (list 1 - (list 2 - (list 3 - 4))) - '(1 . ((2 . ((3 . (4 . ())) . ())) . ()))) - (test-equal - (list 1 (list 2 (list 3 4))) - (cons 1 - (cons (cons 2 - (cons xs-34 - '())) - '()))) - (test-equal - (list 1 (list 2 (list 3 4))) - (cons 1 - (cons xs-234 - '()))) - (test-equal - (list 1 (list 2 (list 3 4))) - xs-1234) - (test-end "2.24")) - -;; Exercise 2.25 - -(test-begin "2.25") -(test-equal - 7 - (car (cdr (car (cdr (cdr '(1 3 (5 7) 9))))))) -(test-equal - 7 - (car (car '((7))))) -(test-equal - 7 - (car ;; 7 - (cdr ;; (cons 7 '()) - (car ;; (cons 2 (cons (cons 3 ...) '())) - (cdr ;; (cons (cons 6 (cons 7 '())) '()) - (car ;; (cons 5 (cons (cons 6 (cons 7 '()) '()))) - (cdr ;; (cons (cons 5 ...) '()) - (car ;; (cons 4 (cons (cons 5 ...) '())) - (cdr ;; (cons (cons 4 ...) '()) - (car ;; (cons 3 (cons (cons 4 ...) '())) - (cdr ;; (cons (cons 3 ...) '()) - (car ;; (cons 2 (cons (cons 3 ...) '())) - (cdr ;; (cons (cons 2 ...) '()) - ;; (cons 1 (cons (cons 2 ...) '())) - '(1 (2 (3 (4 (5 (6 7))))))))))))))))))) -(test-end "2.25") - -;; Exercise 2.26 - -;; (define x (list 1 2 3)) -;; (define y (list 4 5 6)) -;; (append x y) => (1 2 3 4 5 6) -;; (cons x y) => ((1 2 3) 4 5 6) -;; (list x y) => ((1 2 3) (4 5 6)) - -;; scheme@(guile-user)> (define x (list 1 2 3)) -;; scheme@(guile-user)> (define y (list 4 5 6)) -;; scheme@(guile-user)> (append x y) -;; $1 = (1 2 3 4 5 6) -;; scheme@(guile-user)> (cons x y) -;; $2 = ((1 2 3) 4 5 6) -;; scheme@(guile-user)> (list x y) -;; $3 = ((1 2 3) (4 5 6)) - -(let ([x (list 1 2 3)] - [y (list 4 5 6)]) - (test-begin "2.26") - (test-equal - "(1 2 3 4 5 6)" - (format #f "~a" (append x y))) - (test-equal - "((1 2 3) 4 5 6)" - (format #f "~a" (cons x y))) - (test-equal - "((1 2 3) (4 5 6))" - (format #f "~a" (list x y))) - (test-end "2.26")) - -;; Exercise 2.27 - -(letrec ([deep-reverse - (lambda (xs) - (cond - ((null? xs) '()) - ((pair? xs) - (append (deep-reverse (cdr xs)) - (list (deep-reverse (car xs))))) - (else xs)))] - [x (list (list 1 2) - (list 3 4))]) - (test-begin "2.27") - (test-equal - '((3 4) (1 2)) - (reverse x)) - (test-equal - '((4 3) (2 1)) - (deep-reverse x)) - (test-end "2.27")) - -;; Exercise 2.28 - -(define (exercise-2.28) - (define (fringe a-tree) - (cond - ((null? a-tree) '()) - ((pair? a-tree) - (cond - ((pair? (car a-tree)) - (append (fringe (car a-tree)) - (fringe (cdr a-tree)))) - (else (cons (car a-tree) - (fringe (cdr a-tree)))))) - (else a-tree))) - - (define x '((1 2) (3 4))) - - (test-begin "2.28") - (test-equal - '(1 2 3 4) - (fringe x)) - (test-equal - '(1 2 3 4 1 2 3 4) - (fringe (list x x))) - (test-end "2.28")) - -(exercise-2.28) - -;; Exercise 2.29 - -(define (exercise-2.29) - '(define (make-mobile left-branch right-branch) - (list left-branch right-branch)) - - (define (make-mobile left-branch right-branch) - (cons left-branch right-branch)) - - '(define (make-branch length structure) - (list length structure)) - - (define (make-branch length structure) - (cons length structure)) - - (define (left-branch mobile) - (car mobile)) - - '(define (right-branch mobile) - (cadr mobile)) - - (define (right-branch mobile) - (cdr mobile)) - - (define (branch-length branch) - (car branch)) - - '(define (branch-structure branch) - (cadr branch)) - - (define (branch-structure branch) - (cdr branch)) - - (define (total-weight mobile) - (cond - ((number? mobile) mobile) - (else - (let ([left-branch-structure - (branch-structure (left-branch mobile))] - [right-branch-structure - (branch-structure (right-branch mobile))]) - - (+ (if (number? left-branch-structure) - left-branch-structure - (total-weight left-branch-structure)) - (if (number? right-branch-structure) - right-branch-structure - (total-weight right-branch-structure))))))) - - (define (branch-torque branch) - (* (branch-length branch) - (total-weight (branch-structure branch)))) - - (define (balanced mobile) - (= (branch-torque (left-branch mobile)) - (branch-torque (right-branch mobile)))) - - - (test-begin "2.29") - (test-equal - 10 - (total-weight - (make-mobile (make-branch 2 3) - (make-branch 5 7)))) - (test-equal - 64 - (total-weight - (make-mobile (make-branch 2 - (make-mobile (make-branch 3 5) - (make-branch 7 11))) - (make-branch 13 - (make-mobile (make-branch 17 19) - (make-branch 23 29)))))) - (test-equal - 6 - (branch-torque (make-branch 2 3))) - (test-equal - #t - (balanced (make-mobile (make-branch 3 5) - (make-branch 5 3)))) - (test-equal - #t - (balanced (make-mobile (make-branch 3 - (make-mobile (make-branch 4 1) - (make-branch 1 4))) - (make-branch 5 - (make-mobile (make-branch 1 2) - (make-branch 2 1)))))) - (test-equal - #f - (balanced (make-mobile (make-branch 3 - (make-mobile (make-branch 4 1) - (make-branch 1 3))) - (make-branch 5 - (make-mobile (make-branch 1 2) - (make-branch 2 1)))))) - (test-end "2.29")) - -(exercise-2.29) - -;; Exercise 2.30 - -(define (exercise-2.30) - (define (directly-square-tree tree) - (cond - ((null? tree) '()) - ((pair? tree) (cons (directly-square-tree (car tree)) - (directly-square-tree (cdr tree)))) - (else (* tree tree)))) - - (define (higher-order-square-tree tree) - (map (lambda (sub-tree) - (if (pair? sub-tree) - (higher-order-square-tree sub-tree) - (* sub-tree sub-tree))) - tree)) - - (define a-tree - '(1 (2 (3 4) 5) - (6 7))) - - (define a-tree-squared - '(1 (4 (9 16) 25) - (36 49))) - - (test-begin "2.30") - (test-equal - a-tree-squared - (directly-square-tree a-tree)) - (test-equal - a-tree-squared - (higher-order-square-tree a-tree)) - (test-end "2.30")) - -(exercise-2.30) - -;; Exercise 2.31 - -(define (exercise-2.31) - (define (tree-map proc tree) - (map (lambda (sub-tree) - (if (pair? sub-tree) - (tree-map proc - sub-tree) - (proc sub-tree))) - tree)) - - (define (square-tree tree) - (tree-map (lambda (x) (* x x)) - tree)) - - (define a-tree - '(1 (2 (3 4) 5) - (6 7))) - - (define a-tree-squared - '(1 (4 (9 16) 25) - (36 49))) - - (test-begin "2.31") - (test-equal - a-tree-squared - (square-tree a-tree)) - (test-equal - a-tree-squared - (square-tree a-tree)) - (test-end "2.31")) - -(exercise-2.31) - -;; Exercise 2.32 - -(define (exercise-2.32) - (define (subsets s) - (if (null? s) - (list '()) - (let ([rest (subsets (cdr s))]) - (append rest - (map (lambda (x) - (cons (car s) - x)) - rest))))) - - (subsets '()) - (if (null? '()) - (list '()) - (let ([rest (subsets (cdr s))]) - (append rest - (map (lambda (x) - (cons (car s) - x)) - rest)))) - (list '()) - - (subsets '(1)) - (if (null? '(1)) - (list '()) - (let ([rest (subsets (cdr '(1)))]) - (append rest - (map (lambda (x) - (cons (car '(1)) - x)) - rest)))) - (let ([rest (subsets (cdr '(1)))]) - (append rest - (map (lambda (x) - (cons (car '(1)) - x)) - rest))) - (let ([rest (subsets '())]) - (append rest - (map (lambda (x) - (cons (car '(1)) - x)) - rest))) - (append '(()) - (map (lambda (x) - (cons 1 x)) - '(()))) - (append '(()) - (list (cons 1 '()))) - (append (list '()) - (list (list 1))) - (list '() (list 1)) - - ;; We go deep into the list each time we [rest (subset (cdr s))]. - ;; The first rest we really get is '(). - ;; Then we append (list rest) to (map ... rest). - ;; (map ... rest) is (map ... '()), so it's '(). - ;; (list rest) is '(()), so we append '(()) to '(), - ;; which is '(()). We return that to the above procedure call - ;; and now rest is '(()). - ;; We append '(()) to (map ... '(())). - ;; This time we map over a non-empty list, so the map proc - ;; is important. It is (map (lambda (x) (cons (car s) x)) rest). - ;; That is, we attach the current first element of s to each of - ;; the elements of rest. Because this is done from the last to first - ;; items of s in the subsets call stack, we first cons the last element - ;; first while unwinding the callstack. - ;; (map ... rest) is (list (cons (car s) '())), so (map ...) - ;; is (list (list s-item-n)). rest is '(()), so attaching - ;; '(()) to (list s-item-n) is (list '() (list s-item-n)). - ;; We return that and assign to rest. - ;; Now rest is (list '() (list s-item-n)). - ;; We attach (list '() (list s-item-n)) to - ;; (list (list s-item-n-1) (list s-item-n-1 s-item-n)) - ;; thereby getting (list '() (list s-item-n) (list s-item-n-1) (list s-item-n-1 s-item-n)) - ;; and we see the pattern. Each time we go up the call stack we append the previous combinations, - ;; rest, to the list where s-item-i was consed to each of the elements of rest. - ;; So at each point we append the list, rest, where s-item-i did not appear to the list - ;; where it did appear and return that. - ;; In the end we get all combinations of subsets where any particular s-item-i appared and all - ;; combinations of subsets where s-item-i did not appear. - - (test-begin "2.32") - (test-equal - '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)) - (subsets '(1 2 3))) - (test-end "2.32")) - -(exercise-2.32) - -(define (enumerate-interval low high) - (if (> low high) - '() - (cons low - (enumerate-interval (1+ low) - high)))) - -(test-begin "enumerate-interval") -(test-equal - '() - (enumerate-interval 1 0)) -(test-equal - '(1) - (enumerate-interval 1 1)) -(test-equal - '(1 2) - (enumerate-interval 1 2)) -(test-equal - '(1 2 3) - (enumerate-interval 1 3)) -(test-end "enumerate-interval") - -(define (accumulate op initial sequence) - (if (null? sequence) - initial - (op (car sequence) - (accumulate op - initial - (cdr sequence))))) - -(test-begin "accumulate") -(test-equal - 15 - (accumulate + 0 '(1 2 3 4 5))) -(test-equal - 120 - (accumulate * 1 '(1 2 3 4 5))) -(test-equal - '(1 2 3 4 5) - (accumulate cons '() '(1 2 3 4 5))) -(test-end "accumulate") - -;; Exercise 2.33 - -(define (exercise-2.33) - (define (map-2.33 p sequence) - (accumulate (lambda (x y) - (cons (p x) - y)) - '() - sequence)) - - (define (append-2.33 seq1 seq2) - (accumulate cons - seq2 - seq1)) - - (define (length-2.33 sequence) - (accumulate (lambda (x y) (1+ y)) - 0 - sequence)) - - (test-begin "2.33") - (test-equal - '(1 4 9 16 25 36) - (map-2.33 (lambda (x) (* x x)) - (enumerate-interval 1 6))) - (test-equal - '(1 2 3 4 5 6) - (append-2.33 '(1 2 3) - '(4 5 6))) - (test-equal - 10 - (length-2.33 '(1 2 3 4 5 6 7 8 9 10))) - (test-end "2.33")) - -(exercise-2.33) - -;; Exercise 2.34 - -(define (exercise-2.34) - (define (horner-eval x coefficient-sequence) - (accumulate - (lambda (this-coeff higher-terms) - (+ (* higher-terms - x) - this-coeff)) - 0 - coefficient-sequence)) - - (test-begin "2.34") - (test-equal - (let ([x 2]) - (+ (* 1) ; a_0 - (* 3 x) ; a_1 - (* 0 x x) ; a_2 - (* 5 x x x) ; a_3 - (* 0 x x x x) ; a_4 - (* 1 x x x x x) ; a_5 - )) - (horner-eval 2 '(1 3 0 5 0 1))) - (test-end "2.34")) - -(exercise-2.34) - -(define (exercise-2.35) - (define (count-leaves-2.2.2 tree) - (cond - ((null? tree) 0) - ((not (pair? tree)) 1) - (else (+ (count-leaves (car tree)) - (count-leaves (cdr tree)))))) - - (define (count-leaves t) - (accumulate - + - 0 - (map (lambda (x) - (if (pair? x) - (count-leaves x) - 1)) - t))) - - (define t '((1 2 3) - (3 (4 5 6) - (2 3)))) - - (test-begin "2.35") - (test-equal - (count-leaves-2.2.2 t) - (count-leaves t)) - (test-end "2.35")) - -(exercise-2.35) - -;; Exercise 2.36 - -(define (accumulate-n op init seqs) - ;; Took it out of exercise-2.36 because we'll need it later in 2.37. - (if (null? (car seqs)) - '() - (cons (accumulate op - init - (map (lambda (x) (car x)) - seqs)) - (accumulate-n op - init - (map (lambda (x) (cdr x)) - seqs))))) - -(define (exercise-2.36) - (test-begin "2.36") - (test-equal - '(22 26 30) - (accumulate-n + 0 '((1 2 3) - (4 5 6) - (7 8 9) - (10 11 12)))) - (test-end "2.36")) - -(exercise-2.36) - -;; Exercise 2.37 - -(define (exercise-2.37) - (define (matrix-ref m i j) - (list-ref (list-ref m i) j)) - - (define (dot-product v w) - (accumulate + - 0 - (map * - v - w))) - - (define (dumb-dot-product v w) - (sum (list-ec (: i - (length v)) - (* (list-ref v - i) - (list-ref w - i))))) - - (define (matrix-*-vector m v) - (map (lambda (w) (dot-product v - w)) - m)) - - (define (dumb-matrix-*-vector m v) - (list-ec (: i - (length m)) - (accumulate + - 0 - (list-ec (: j - (length v)) - (* (matrix-ref m i j) - (list-ref v - j)))))) - - (define (transpose mat) - (accumulate-n cons - '() - mat)) - - (define (dumb-transpose mat) - (list-ec (: j - (length (car mat))) - (list-ec (: i - (length mat)) - (matrix-ref mat i j)))) - - (define (matrix-*-matrix m n) - (let ([cols (transpose n)]) - (map (lambda (v) - (matrix-*-vector cols v)) - m))) - - (define (dumb-matrix-*-matrix m n) - ;; p_ij = sum_k(m_ik * n_kj) - (list-ec (: i (length m)) - (list-ec (: j (length (car n))) - (sum-ec (: k (length n)) - (* (matrix-ref m i k) - (matrix-ref n k j)))))) - - (define v '(2 3 5 7)) - - (define M - '((1 2 3 4) - (4 5 6 6) - (6 7 8 9))) - - (define M-transposed - '((1 4 6) - (2 5 7) - (3 6 8) - (4 6 9))) - - (test-begin "2.37") - (test-equal - (dumb-transpose M) - (transpose M)) - (test-equal - (dumb-matrix-*-vector M - v) - (matrix-*-vector M - v)) - (test-equal - (dumb-matrix-*-matrix M - M-transposed) - (matrix-*-matrix M - M-transposed)) - (test-equal - (dumb-matrix-*-matrix '((2 3) (5 7)) - '((2 3) (5 7))) - (matrix-*-matrix '((2 3) (5 7)) - '((2 3) (5 7)))) - (test-end "2.37")) - -(exercise-2.37) - -;; Exercise 2.38 - -(define (my-fold-right op initial sequence) - (accumulate op initial sequence)) - -(define (my-fold-left op initial sequence) - (define (iter result rest) - (if (null? rest) - result - (iter (op result (car rest)) - (cdr rest)))) - (iter initial sequence)) - -(define (exercise-2.38) - (define my-fold-right-/-ratsui - (/ 1 - (/ 2 - (/ 3 - 1)))) - (define my-fold-left-/-ratsui - (/ (/ (/ 1 - 1) - 2) - 3)) - (define my-fold-right-list-ratsui - (list 1 - (list 2 - (list 3 - '())))) - (define my-fold-left-list-ratsui - (list (list (list '() - 1) - 2) - 3)) - - (test-begin "2.38") - (test-equal my-fold-right-/-ratsui - (my-fold-right / - 1 - (list 1 2 3))) - (test-equal my-fold-right-/-ratsui - (my-fold-right / - (/ 3 - 1) - (list 1 2))) - (test-equal my-fold-right-/-ratsui - (my-fold-right / - (/ 2 - (/ 3 - 1)) - (list 1))) - (test-equal my-fold-right-/-ratsui - (my-fold-right / - (/ 1 - (/ 2 - (/ 3 - 1))) - (list))) - (test-equal my-fold-left-/-ratsui - (my-fold-left / - 1 - (list 1 2 3))) - (test-equal my-fold-left-/-ratsui - (my-fold-left / - (/ 1 - 1) - (list 2 3))) - (test-equal my-fold-left-/-ratsui - (my-fold-left / (/ (/ 1 - 1) - 2) - (list 3))) - (test-equal my-fold-left-/-ratsui - (my-fold-left / (/ (/ (/ 1 - 1) - 2) - 3) - (list))) - (test-equal my-fold-right-list-ratsui - (my-fold-right list - '() - (list 1 2 3))) - (test-equal my-fold-right-list-ratsui - (my-fold-right list - (list 3 '()) - (list 1 2))) - (test-equal my-fold-right-list-ratsui - (my-fold-right list - (list 2 (list 3 '())) - (list 1))) - (test-equal my-fold-right-list-ratsui - (my-fold-right list - (list 1 (list 2 (list 3 '()))) - (list))) - (test-equal my-fold-left-list-ratsui - (my-fold-left list - '() - (list 1 2 3))) - (test-equal my-fold-left-list-ratsui - (my-fold-left list - (list '() 1) - (list 2 3))) - (test-equal my-fold-left-list-ratsui - (my-fold-left list - (list (list '() 1) 2) - (list 3))) - (test-equal my-fold-left-list-ratsui - (my-fold-left list - (list (list (list '() 1) 2) 3) - (list))) - (test-end "2.38") - - ;; if op: A -> A, - ;; (cut my-fold-right op <> <>) is equivalent to (cut my-fold-left op <> <>) - ;; iff - ;; for all a, b, c in A, - ;; (op (op a b) c) = (op a (op b c)). - ;; Did I get that right? Seems right. - ) - -(exercise-2.38) - -;; Exercise 2.39 - -(define (exercise-2.39) - (define (reverse-my-fold-right sequence) - (my-fold-right - (lambda (x y) - (append y - (list x))) - '() - sequence)) - - (define (reverse-my-fold-left sequence) - (my-fold-left - (lambda (x y) - (append (list y) - x)) - '() - sequence)) - - (test-begin "2.39") - (test-equal - '(4 3 2 1) - (reverse-my-fold-right '(1 2 3 4))) - (test-equal - '(4 3 2 1) - (reverse-my-fold-left '(1 2 3 4))) - (test-end "2.39")) - -(exercise-2.39) - -;; Exercise 2.40 - -(define (flatmap proc seq) - (accumulate append - '() - (map proc seq))) - -(define (unique-pairs n) - (flatmap (lambda (i) - (map (lambda (j) - (list i j)) - (enumerate-interval 1 (1- i)))) - (enumerate-interval 1 n))) - -(define (exercise-2.40) - (define (remove item seqeunce) - (filter (lambda (x) - (not (equal? x - item))) - sequence)) - - (define (permutations s) - (if (null? s) - (list '()) - (flatmap (lambda (x) - (map (lambda (p) - (cons x p)) - (permutations (remove x - s)))) - s))) - - (define (f n) - (accumulate - append - '() - (map (lambda (i) - (map (lambda (j) - (list i j)) - (enumerate 1 (1- i)))) - (enumerate-interval 1 n)))) - - (define (g n) - (flatmap (lambda (x) x) (enumerate-interval 1 n))) - - (define (prime-sum? pair) - (prime? (+ (car pair) - (cadr pair)))) - - (define (make-pair-sum pair) - (list (car pair) - (cadr pair) - (+ (car pair) - (cadr pair)))) - - (define (prime-sum-pairs n) - (map make-pair-sum - (filter - prime-sum? - (flatmap - (lambda (i) - (map (lambda (j) - (list i j)) - (enumerate-interval 1 (1- i)))) - (enumerate-interval 1 n))))) - - (define (my-prime-sum-pairs n) - (map make-pair-sum - (filter prime-sum? - (unique-pairs n)))) - - (test-begin "2.40") - (test-equal - '((2 1) - (3 1) (3 2) - (4 1) (4 2) (4 3)) - (unique-pairs 4)) - (test-equal - (prime-sum-pairs 20) - (my-prime-sum-pairs 20)) - (test-end "2.40")) - -(exercise-2.40) - -(define (exercise-2.41) - (define (unique-triples n) - (flatmap (lambda (pair) - (map (lambda (k) - (append pair (list k))) - (enumerate-interval 1 (1- (cadr pair))))) - (unique-pairs n))) - - (define ratsui - '((3 2 1) - (4 2 1) - (4 3 1) - (4 3 2) - (5 2 1) - (5 3 1) - (5 3 2) - (5 4 1) - (5 4 2) - (5 4 3))) - - - (test-begin "2.41") - (test-equal - ratsui - (unique-triples 5)) - (test-end "2.41")) - -(exercise-2.41) - -(define (exercise-2.42) - (define (make-position row column) - (cons row column)) - - (define (position-row position) - (car position)) - - (define (position-column position) - (cdr position)) - - (define (adjoin-position row column rest-of-queens) - (cons (make-position row column) - rest-of-queens)) - - (define empty-board '()) ;; queens 0 will return [[]]. - - (define (threatening-pair? queen-a-position queen-b-position) - (define a-row (position-row queen-a-position)) - (define b-row (position-row queen-b-position)) - - (define a-column (position-column queen-a-position)) - (define b-column (position-column queen-b-position)) - - (define rows-equal (= a-row - b-row)) - - (define on-same-diagonal (= (abs (- a-row - b-row)) - (abs (- a-column - b-column)))) - - (or rows-equal - on-same-diagonal)) - - " - Q - Q - Q - -Q1 = (2, 1) -Q2 = (3, 2) -Q1 - Q2 = (2 - 3, 1 - 2) -= (-1, -1) -Q3 = (4, 3) -Q1 - Q3 = (2 - 4, 1 - 3) -= (-2, -2) - - Q - Q - Q -Q - -Q1 = (4, 1) -Q2 = (3, 2) -Q3 = (2, 3) - -Q1 - Q2 = (4 - 3, 1 - 2) -= (1, -1) -Q1 - Q3 = (4 - 2, 1 - 3) -= (2, -2) -Q1 - Q4 = (4 - 1, 1 - 4) -= (3, -3) -" - - - (define (safe? our-column board) - (define our-row (position-row (car board))) - - (if (null? - (filter - (lambda (position) - (threatening-pair? - (make-position our-row - our-column) - position)) - (cdr board))) - #t - #f)) - - (define (queens board-size) - (define (queen-cols k) - (if (= k 0) - (list empty-board) - (filter - (lambda (positions) - (safe? k - positions)) - (flatmap - (lambda (rest-of-queens) - (map (lambda (new-row) - (adjoin-position - new-row - k - rest-of-queens)) - (enumerate-interval - 1 - board-size))) - (queen-cols (1- k)))))) - (queen-cols board-size)) - - (define (display-board board n) - (define sorted-board - (sort board - (lambda (a b) - (or - (< (position-row a) - (position-row b)) - ;; (< (position-column a) - ;; (position-column b)) - )))) - '(define sorted-board board) - - (define (display-row column n) - (pretty-print (list column n)) - (cond - ((zero? n) '()) - ((= column n) - (display "Q\n") - (display-row column (1- n))) - (else (display ".") - (display-row column (1- n))))) - - (for-each - (lambda (position) - (display-row - (position-column position) - n)) - sorted-board)) - - '(for-each (lambda (board) - (display-board board - (reduce - (lambda (x y) - (max (position-column x) - (position-column y))) - 0 - board)) - (pretty-print board)) - (flatmap queens - (enumerate-interval 1 8))) - - (test-begin "2.42") - (test-equal - #f - (safe? 2 - (list (make-position 1 2) - (make-position 2 1)))) - (test-equal - #t - (safe? 2 - (list (make-position 4 2) - (make-position 2 1)))) - (test-equal - '() - (queens 8)) - (test-end "2.42")) - -(exercise-2.42) - -;; Exercise 2.43 XXX - -;; Exercise 2.44 XXX - -(define (exercise-2.44) - (test-begin "2.44") - (test-end "2.44")) - -(exercise-2.44) - -;; Exercise 2.53 - -(define (exercise-2.53) - (test-begin "2.53") - (test-equal - '(a b c) - (list 'a 'b 'c)) - (test-equal - '((george)) - (list (list 'george))) - (test-equal - '((y1 y2)) - ;; '((x1 x2) (y1 y2)) is a pair whose first item is (x1 x2) and - ;; second is a pair whose first item is (y1 y2) and second is nil, - ;; so (cdr '((x1 x2) (y1 y2))) is ((y1 y2)). - (cdr '((x1 x2) (y1 y2)))) - (test-equal - '(y1 y2) - ;; the cadr is the first element of the pair whose first item is (y1 y2) and second is nil. - (cadr '((x1 x2) (y1 y2)))) - (test-equal - #f - (pair? (car '(a short list)))) - (test-equal - #f - ;; No symbol red in the list, so answer is false. - (memq 'red '((red shoes) (blue socks)))) - (test-equal - '(red shoes blue socks) - ;; The first element of the first pair is red, so that pair is returned. - (memq 'red '(red shoes blue socks))) - (test-end "2.53")) - -(exercise-2.53) - -(define (exercise-2.54) - (define (my-equal? a b) - (cond - ((and (null? a) - (null? b)) - #t) - ((and (symbol? a) - (symbol? b)) - (eq? a - b)) - ((and (pair? a) - (pair? b)) - (and (my-equal? (car a) - (car b)) - (my-equal? (cdr a) - (cdr b)))) - (else #f))) - - (test-begin "2.54") - (test-equal - #t - (my-equal? 'a 'a)) - (test-equal - #f - (my-equal? 'a 'b)) - (test-equal - #f - (my-equal? '(a) 'b)) - (test-equal - #t - (my-equal? '(a) '(a))) - (test-equal - #t - (my-equal? '((a b c ((d e) f) g h)) '((a b c ((d e) f) g h)))) - (test-equal - #f - (my-equal? '((a b c ((d e) f) g h)) '((a b c (d e f) g h)))) - (test-equal - #f - (my-equal? '((a b c ((d e) f) g h)) '((a b c ((d d) f) g h)))) - (test-end "2.54")) - -(exercise-2.54) - -;; Exercise 2.55 - -;; The 'foo is syntactic sugar for (quote foo). -;; If foo is 'abracadabra, which is (quote abracadabra), -;; then ''abracadabra is (quote (quote abracadabra)). - -;; Exercise 2.56 - -(define (deriv-stuff) - ;; Original: - ;; (define (make-sum a1 a2) - ;; (list '+ a1 a2)) - - (define (=number? exp num) - (and (number? exp) - (= exp num))) - - ;; Simplificating make-sum: - (define (make-sum a1 a2) - (cond - ((=number? a1 0) a2) - ((=number? a2 0) a1) - ((and (number? a1) - (number? a2)) - (+ a1 a2)) - (else (list '+ a1 a2)))) - - (define (sum? x) - (and (pair? x) - (eq? (car x) - '+))) - - (define (addend s) - (cadr s)) - - (define (augend s) - (caddr s)) - - ;; Original: - ;; (define (make-product m1 m2) - ;; (list '* m1 m2)) - - ;; Simplificating make-product: - (define (make-product m1 m2) - (cond - ((or (=number? m1 0) - (=number? m2 0)) - 0) - ((=number? m1 1) m2) - ((=number? m2 1) m1) - ((and (number? m1) - (number? m2)) - (* m1 m2)) - (else (list '* m1 m2)))) - - (define (product? x) - (and (pair? x) - (eq? (car x) - '*))) - - (define (multiplier p) - (cadr p)) - - (define (multiplicand p) - (caddr p)) - - (define (make-exponentiation b e) - (cond - ((=number? e 0) 1) - ((=number? b 1) b) - (else (list '** b e)))) - - ;; Exercise 2.56 - (define (exponentiation? e) - (and (pair? e) - (eq? (car e) - '**))) - - (define (base e) - (cadr e)) - - (define (exponent e) - (caddr e)) - - (define (variable? x) - (symbol? x)) - - (define (same-variable? v1 v2) - (and (variable? v1) - (variable? v2) - (eq? v1 v2))) - - (define (deriv exp var) - (cond - ((number? exp) 0) - ((variable? exp) - (if (same-variable? exp - var) - 1 - 0)) - ((sum? exp) - (make-sum (deriv (addend exp) - var) - (deriv (augend exp) - var))) - ((product? exp) - (make-sum - (make-product (multiplier exp) - (deriv (multiplicand exp) - var)) - (make-product (deriv (multiplier exp) - var) - (multiplicand exp)))) - ;; Exercise 2.56 - ((exponentiation? exp) - ;; d(x**n)/dx = n*x**(n-1) - (make-product (exponent exp) - (make-exponentiation (base exp) - (make-sum (exponent exp) - -1)))) - (else (error "Unknown expression - type: DERIV" exp)))) - - (test-begin "deriv-stuff") - ;; Original: - ;; (test-equal - ;; '(+ 1 0) - ;; (deriv '(+ x 3) 'x)) - ;; (test-equal - ;; '(+ (* x 0) (* 1 y)) - ;; (deriv '(* x y) 'x)) - ;; (test-equal - ;; '(+ (* (* x - ;; y) - ;; (+ 1 - ;; 0)) - ;; (* (+ (* x 0) - ;; (* 1 y)) - ;; (+ x 3))) - ;; (deriv '(* (* x y) (+ x 3)) 'x)) - - ;; Simplificating: - (test-equal - 1 - (deriv '(+ x 3) 'x)) - (test-equal - 'y - (deriv '(* x y) 'x)) - (test-equal - '(+ (* x y) - (* y - (+ x 3))) - (deriv '(* (* x y) (+ x 3)) 'x)) - (test-equal - '(* 3 (** x 2)) - (deriv '(** x 3) 'x)) - (test-equal - '() - (deriv '(** x -1) 'x)) - (test-end "deriv-stuff")) - -(deriv-stuff) - -(define (sets-stuff) - (define (element-of-set? x set) - (cond - ((null? set) #f) - ((equal? x (car set)) #t) - (else (element-of-set? x (cdr set))))) - - (define (adjoin-set x set) - (if (element-of-set? x set) - set - (cons x set))) - - (define (intersection-set set1 set2) - (cond - ((or (null? set1) - (null? set2)) - '()) - ((element-of-set? (car set1) - set2) - (adjoin-set (car set1) - (intersection-set (cdr set1) - set2))) - (else (intersection-set (cdr set1) - set2)))) - - (define (union-set set1 set2) - (cond - ((null? set1) set2) - ((null? set2) set1) - ((element-of-set? (car set1) - set2) - (union-set (cdr set1) - set2)) - (else (adjoin-set (car set1) - (union-set (cdr set1) - set2))))) - - (test-begin "2.59") - (test-equal - '(1 2 4 3 5) - (union-set '(1 3 2) '(4 3 5))) - (test-end "2.59")) - -(sets-stuff) - -;; Exercise 2.60 XXX - -(define (exercise-2.60) - ;; I don't get it. Am I supposed to let these sets explode by just appending - ;; more and more stuff to them? - - (define (element-of-set? x set) - (cond - ((null? set) #f) - ((equal? x (car set)) #t) - (else (element-of-set? x (cdr set))))) - - (define (adjoin-set x set) - (cons x set)) - - (define (union-set set1 set2) - (append set1 set2)) - - (define (intersection-set set1 set2) - (cond - ((or (null? set1) - (null? set2)) '()) - ((equal? (car set1) (element-of-set? (car set1) - set2)) - (adjoin-set (car set1) - (intersection-set (cdr set1) - set2))) - (else (intersection-set (cdr set1) - set2)))) - - (test-begin "2.60") - (test-end "2.60")) - -(exercise-2.60) - -(define (ordered-list-set-stuff) - (define (element-of-set? x set) - (cond - ((= x (car set)) - #t) - ((> x (car set)) - #f) - (else (element-of-set? x (cdr set))))) - - (define (intersection-set set1 set2) - (cond - ((null? set1) '()) - ((null? set2) '()) - ((= (car set1) - (car set2)) - (cons (car set1) - (intersection-set (cdr set1) - (cdr set2)))) - ((< (car set1) - (car set2)) - (intersection-set (cdr set1) - set2)) - ((> (car set1) - (car set2)) - (intersection-set set1 - (cdr set2))))) - - (define (adjoin-set x set) - (cond - ((null? set) (cons x '())) - ((< x (car set)) (cons x set)) - ((= x (car set)) set) - (else (cons (car set) - (adjoin-set x (cdr set)))))) - - (define (union-set set1 set2) - (cond - ((null? set1) set2) - ((null? set2) set1) - ((< (car set1) - (car set2)) - (cons (car set1) - (union-set (cdr set1) - set2))) - ((> (car set1) - (car set2)) - (cons (car set2) - (union-set set1 - (cdr set2)))) - (else (cons (car set1) - (union-set (cdr set1) - (cdr set2)))))) - (test-begin "2.61") - (test-equal - '(1) - (adjoin-set 1 '())) - (test-equal - '(1) - (adjoin-set 1 '(1))) - (test-equal - '(1 2) - (adjoin-set 1 '(2))) - (test-equal - '(1 2) - (adjoin-set 2 '(1))) - (test-equal - '(1 2 3 4 5 6) - (adjoin-set 3 '(1 2 4 5 6))) - (test-end "2.61") - - (test-begin "2.62") - (test-equal - '() - (union-set '() '())) - (test-equal - '(1) - (union-set '(1) '())) - (test-equal - '(1) - (union-set '() '(1))) - (test-equal - '(1) - (union-set '(1) '(1))) - (test-equal - '(1 2) - (union-set '(1 2) '(1))) - (test-equal - '(1 2) - (union-set '(1) '(1 2))) - (test-equal - '(1 2 3) - (union-set '(2 3) '(1 2 3))) - (test-end "2.62")) - -(ordered-list-set-stuff) diff --git a/solutions/exercise-1.1.scm b/solutions/exercise-1.1.scm @@ -0,0 +1,88 @@ +(define-library (solutions exercise-1.1) + (import (scheme base)) + (import (srfi srfi-64)) + (export sum-of-squares) + + (begin + 10 + + (test-begin "1.1") + + (test-equal 10 10) + + (test-equal + (+ 5 3 4) + + 12) + + (test-equal + (- 9 1) + + 8) + + (test-equal + (/ 6 2) + + 3) + + (test-equal + (+ (* 2 4) (- 4 6)) + + 6) + + (define a 3) + + ;; nothing + + (define b (+ a 1)) + + ;; nothing + + (test-equal + (+ a b (* a b)) + + 19) + + (test-equal + (= a b) + + #f) + + (test-equal + (if (and (> b a) (< b (* a b))) + b + a) + + 4) + + (test-equal + (cond ((= a 4) 6) + ((= b 4) (+ 6 7 a)) + (else 25)) + + 16) + + (test-equal + (+ 2 (if (> b a) b a)) + + 6) + + (test-equal + (* (cond ((> a b) a) + ((< a b) b) + (else -1)) + (+ a 1)) + 16) + + (define (square a) + (* a a)) + + ;; nothing + + (define (sum-of-squares a b) + (+ (square a) + (square b))) + + ;; nothing + + (test-end "1.1"))) diff --git a/solutions/exercise-1.10.scm b/solutions/exercise-1.10.scm @@ -0,0 +1,108 @@ + +#! + +*Exercise 1.10:* The following procedure computes a mathematical +function called Ackermann's function. + +(define (A x y) + (cond ((= y 0) 0) + ((= x 0) (* 2 y)) + ((= y 1) 2) + (else (A (- x 1) + (A x (- y 1)))))) + +What are the values of the following expressions? + +(A 1 10) + +(A 2 4) + +(A 3 3) + +Consider the following procedures, where `A' is the procedure +defined above: + +(define (f n) (A 0 n)) + +(define (g n) (A 1 n)) + +(define (h n) (A 2 n)) + +(define (k n) (* 5 n n)) + +Give concise mathematical definitions for the functions computed +by the procedures `f', `g', and `h' for positive integer values of +n. For example, `(k n)' computes 5n^2. + + +(define (A x y) + (cond ((= y 0) 0) + ((= x 0) (* 2 y)) + ((= y 1) 2) + (else (A (- x 1) + (A x (- y 1)))))) + +(A 1 10) +(cond ((= 10 0) 0) + ((= 1 0) (* 2 10)) + ((= 10 1) 2) + (else (A (- 1 1) + (A 1 (- 10 1))))) +(A (- 1 1) + (A 1 (- 10 1))) +(A 0 (A 1 9)) +(A 0 (A 0 (A 1 8))) +(A 0 (A 0 (A 0 (A 1 7)))) +(A 0 (A 0 (A 0 (A 0 (A 1 6))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 1 5)))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 4))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 3)))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 2))))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 1)))))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 2))))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (* 2 2))))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 8))))))) +(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 16)))))) +(A 0 (A 0 (A 0 (A 0 (A 0 32))))) +(A 0 (A 0 (A 0 (A 0 64)))) +(A 0 (A 0 (A 0 128))) +(A 0 (A 0 256)) +(A 0 512) +1024 + +(define (A x y) + (cond ((= y 0) 0) + ((= x 0) (* 2 y)) + ((= y 1) 2) + (else (A (- x 1) + (A x (- y 1)))))) + + +(A 2 4) +(cond ((= 4 0) 0) + ((= 2 0) (* 2 4)) + ((= 4 1) 2) + (else (A (- 2 1) + (A 2 (- 4 1))))) +(A 1 + (A 1 (A 2 (- 3 1)))) + +(A 1 + (A 1 (A 2 (- 3 1)))) +(A 1 + (A 1 (A 2 (- 3 1)))) + + +!# + +(define (A x y) + (cond ((= y 0) 0) + ((= x 0) (* 2 y)) + ((= y 1) 2) + (else (A (- x 1) + (A x (- y 1)))))) + +(test-begin "1.10") +'(test-equal 1024 (A 1 10)) +'(test-equal 1024 (A 2 4)) +(test-end "1.10") diff --git a/solutions/exercise-1.11.scm b/solutions/exercise-1.11.scm @@ -0,0 +1,36 @@ + +#! + +*Exercise 1.11:* A function f is defined by the rule that f(n) = n +if n<3 and f(n) = f(n - 1) + 2f(n - 2) + 3f(n - 3) if n>= 3. +Write a procedure that computes f by means of a recursive process. +Write a procedure that computes f by means of an iterative +process. + +!# + +(define (f-recursive n) + (cond + ((< n 3) n) + (else (+ (f-recursive (1- n)) + (* 2 (f-recursive (- n 2))) + (* 3 (f-recursive (- n 3))))))) + +(define (f-iterative n) + (define (f i n a b c) + (cond + ((= i n) a) + (else (f (1+ i) + n + b + c + (+ c + (* 2 b) + (* 3 a)))))) + (f 0 n 0 1 2)) + +(test-begin "1.11") +(test-equal + (map f-recursive '(0 1 2 3 4 5 6 7)) + (map f-iterative '(0 1 2 3 4 5 6 7))) +(test-end "1.11") diff --git a/solutions/exercise-1.12.scm b/solutions/exercise-1.12.scm @@ -0,0 +1,62 @@ + +#! + +*Exercise 1.12:* The following pattern of numbers is called "Pascal's + triangle". + +1 +1 1 +1 2 1 +1 3 3 1 +1 4 6 4 1 + +The numbers at the edge of the triangle are all 1, and each number +inside the triangle is the sum of the two numbers above it.(4) +Write a procedure that computes elements of Pascal's triangle by +means of a recursive process. + +!# + +(define (pascal line column) + (cond + ((or (= column 0) + (= column line)) 1) + (else (+ (pascal (1- line) + (1- column)) + (pascal (1- line) + column))))) + +(test-begin "1.12") +(test-equal + (list (pascal 0 0) + (pascal 1 0) + (pascal 1 1) + (pascal 2 0) + (pascal 2 1) + (pascal 2 2) + (pascal 3 0) + (pascal 3 1) + (pascal 3 2) + (pascal 3 3) + (pascal 4 0) + (pascal 4 1) + (pascal 4 2) + (pascal 4 3) + (pascal 4 4) + ) + '(1 + 1 + 1 + 1 + 2 + 1 + 1 + 3 + 3 + 1 + 1 + 4 + 6 + 4 + 1)) +(test-end "1.12") diff --git a/solutions/exercise-1.13.scm b/solutions/exercise-1.13.scm @@ -0,0 +1,11 @@ +#! + +*Exercise 1.13:* Prove that _Fib_(n) is the closest integer to +[phi]^n/[sqrt](5), where [phi] = (1 + [sqrt](5))/2. Hint: Let +[illegiblesymbol] = (1 - [sqrt](5))/2. Use induction and the +definition of the Fibonacci numbers (see section *Note 1-2-2::) to +prove that _Fib_(n) = ([phi]^n - [illegiblesymbol]^n)/[sqrt](5). + +!# + +#! oh boy. XXX !# diff --git a/solutions/exercise-1.14.scm b/solutions/exercise-1.14.scm @@ -0,0 +1,24 @@ +#! + +1.14 + +!# + +(define (count-change amount) + (cc amount 5)) + +(define (cc amount kinds-of-coins) + (cond ((= amount 0) 1) + ((or (< amount 0) (= kinds-of-coins 0)) 0) + (else (+ (cc amount + (- kinds-of-coins 1)) + (cc (- amount + (first-denomination kinds-of-coins)) + kinds-of-coins))))) + +(define (first-denomination kinds-of-coins) + (cond ((= kinds-of-coins 1) 1) + ((= kinds-of-coins 2) 5) + ((= kinds-of-coins 3) 10) + ((= kinds-of-coins 4) 25) + ((= kinds-of-coins 5) 50))) diff --git a/solutions/exercise-1.16.scm b/solutions/exercise-1.16.scm @@ -0,0 +1,77 @@ + +#! + +1.16 + +!# + +(define (flatten a) + (cond + ((null? a) '()) + (else (append (car a) (flatten (cdr a)))))) + +(test-begin "flatten") +(test-equal (flatten '((1 2) (3 4) (5 6))) '(1 2 3 4 5 6)) +(test-end "flatten") + +(define (cartesian a b) + (define (cartesian' a-element b) + (cond + ((null? b) '()) + (else (cons (cons a-element (car b)) + (cartesian' a-element (cdr b)))))) + (cond + ((null? a) '()) + (else (flatten (map (cut cartesian' <> b) a))))) + +(test-begin "cartesian") +(test-equal + (cartesian '(1 2 3) + '(4 5 6)) + '((1 . 4) + (1 . 5) + (1 . 6) + (2 . 4) + (2 . 5) + (2 . 6) + (3 . 4) + (3 . 5) + (3 . 6))) +(test-end "cartesian") + +(define (fast-expt-recursive b n) + (cond ((= n 0) 1) + ((even? n) (square (fast-expt-recursive b (/ n 2)))) + (else (* b (fast-expt-recursive b (- n 1)))))) + +(define (fast-expt-iterative b n) + (define (f a b n) + (cond + ((= n 0) a) + ((even? n) (f a + (* b b) + (/ n 2))) + (else (f (* a b) + b + (1- n))))) + (f 1 b n)) + +(test-begin "1.16") +(test-equal (fast-expt-recursive 2 3) (fast-expt-iterative 2 3)) +;; 1 * 2**3 = +;; 2 * 2**2 = 2 * (2**1)**2 +;; 2 * +(test-equal (fast-expt-iterative 3 5) (fast-expt-recursive 3 5)) +;; a * b^n = +;; 1 * 3^5 = +;; 3 * 3^4 = +;; 3 * 3 * 3 * 3^2 +;; 3 * 3 * 3 * 3 * 3 +(test-equal (fast-expt-iterative 5 7) (fast-expt-recursive 5 7)) +;; 5**7 = +;; 5 * (5**3)**2 = +;; 5 * (5**2)**3 +;; 5 * 5**2 * 5**3 = +;; 5 * 5**2 * 5 * 5**2 = +(test-equal (fast-expt-iterative 7 11) (fast-expt-recursive 7 11)) +(test-end "1.16") diff --git a/solutions/exercise-1.17.scm b/solutions/exercise-1.17.scm @@ -0,0 +1,36 @@ + +;; Exercise 1.17 + +(define (*-recursive a b) + (if (= b 0) + 0 + (+ a (*-recursive a (- b 1))))) + +(define (double n) + (* 2 n)) + +(define (halve n) + (/ n 2)) + +(define (fast-*-recursive a b) + (cond + ((= b 0) 0) + ((even? b) (+ (double a) + (fast-*-recursive a + (- b 2)))) + (else (+ a (fast-*-recursive a (1- b)))))) + +(test-begin "1.17") +(test-equal (*-recursive 2 3) (fast-*-recursive 2 3)) +;; a * b = +;; 2 * 3 = odd b +;; 4 * 2 = even b +;; +(test-equal (* 3 5) (*-recursive 3 5)) +(test-equal (* 5 7) (*-recursive 5 7)) +(test-equal (* 7 11) (*-recursive 7 11)) + +(test-equal (* 3 5) (fast-*-recursive 3 5)) +(test-equal (* 5 7) (fast-*-recursive 5 7)) +(test-equal (* 7 11) (fast-*-recursive 7 11)) +(test-end "1.17") diff --git a/solutions/exercise-1.18.scm b/solutions/exercise-1.18.scm @@ -0,0 +1,19 @@ +;; Exercise 1.18 + +(define (fast-*-iterative a b) + (define (f result a b) + (cond + ((= b 0) result) + ((even? b) (f result + (double a) + (halve b))) + (else (f (+ result a) a (1- b))))) + (f 0 a b)) + +(test-begin "1.18") +(test-equal (* 3 5) (fast-*-iterative 3 5)) +;; 0 3 5 +;; +(test-equal (* 5 7) (fast-*-iterative 5 7)) +(test-equal (* 7 11) (fast-*-iterative 7 11)) +(test-end "1.18") diff --git a/solutions/exercise-1.19.scm b/solutions/exercise-1.19.scm @@ -0,0 +1,71 @@ + +;; Exercise 1.19 + +;; T +;; a <- (a + b) +;; b <- a +;; +;; Tpq = +;; a <- bq + aq + ap +;; a <- bq + a(q + p) +;; b <- bp + aq +;; +;; Tpq^2 = +;; a' <- (bp + aq)q + (bq + aq + ap)q + (bq + aq + ap)p +;; a' <- bpq + aq^2 + bq^2 + aq^2 + apq + bpq + apq + ap^2 +;; a' <- 2bpq + 2aq^2 + bq^2 + 2apq + ap^2 +;; a' <- b(2pq + q^2) + (2apq + ap^2 + 2aq^2) +;; a' <- b(2pq + q^2) + a(2pq + p^2 + 2q^2) +;; q = 2pq + q^2 +;; p + q = 2pq + p^2 + 2q^2 +;; p = (2pq + p^2 + 2q^2) - (2pq + q^2) +;; p = 2pq + p^2 + 2q^2 - 2pq - q^2 +;; p = p^2 + q^2 +;; a' <- b(2pq + q^2) + a(2pq + q^2) + a(p^2 + q^2) +;; +;; oh. i'm dumb. we already have q' and p' in terms of q and p here: +;; +;; b' <- (bp + aq)p + (bq + aq + ap)q +;; b' <- bp^2 + apq + bq^2 + aq^2 + apq +;; b' <- bp^2 + 2apq + bq^2 + aq^2 +;; b' <- bp^2 + bq^2 + 2apq + aq^2 +;; b' <- b(p^2 + q^2) + a(2pq + q^2) + +(define (fib n) + (cond + ((= n 0) 0) + ((= n 1) 1) + (else (+ (fib (1- n)) + (fib (- n 2)))))) + +(define (fast-fib n) + (define (fib-iter a b p q count) + (cond + ((= count 0) b) + ((even? count) + (fib-iter a + b + (+ (* p p) + (* q q)) + (+ (* 2 p q) + (* q q)) + (/ count 2))) + (else + (fib-iter (+ (* b q) + (* a q) + (* a p)) + (+ (* b p) + (* a q)) + p + q + (1- count))))) + (fib-iter 1 0 0 1 n)) + +(test-begin "1.19") +(test-equal (fib 0) (fast-fib 0)) +(test-equal (fib 1) (fast-fib 1)) +(test-equal (fib 2) (fast-fib 2)) +(test-equal (fib 3) (fast-fib 3)) +(test-equal (fib 4) (fast-fib 4)) +(test-equal (fib 5) (fast-fib 5)) +(test-end "1.19") diff --git a/solutions/exercise-1.2.scm b/solutions/exercise-1.2.scm @@ -0,0 +1,30 @@ +(define-library (solutions exercise-1.2) + (import (scheme base)) + (import (srfi srfi-64)) + + (begin + + #! + + *Exercise 1.2:* Translate the following expression into prefix + form. + + 5 + 4 + (2 - (3 - (6 + 4/5))) + ----------------------------- + 3(6 - 2)(2 - 7) + + !# + + (test-begin "1.2") + (test-equal + (/ (+ 5 + 4 + (- 2 + (- 3 + (+ 6 + (/ 4 5))))) + (* 3 + (- 6 2) + (- 2 7))) + (/ (- 37) 150)) + (test-end "1.2"))) diff --git a/solutions/exercise-1.20.scm b/solutions/exercise-1.20.scm @@ -0,0 +1,170 @@ + +;; Exercise 1.20 + + + +(define (gcd-iterative a b) + ;; a = b*d + r + (if (= b 0) + a + (gcd-iterative b (remainder a b)))) + +;; Normal-order + +(test-begin "1.20") +(test-equal (gcd-iterative 206 40) (gcd 206 40)) +(test-equal (if (= 40 0) + 206 + (gcd 40 (remainder 206 40))) 2) +(test-equal (if #f + 206 + (gcd 40 (remainder 206 40))) 2) +(test-equal (gcd 40 (remainder 206 40)) 2) +(test-equal (if (= (remainder 206 40) 0) ;; 1 remainder + 40 + (gcd (remainder 206 40) + (remainder 40 + (remainder 206 40)))) 2) +(test-equal (if (= 6 0) + 40 + (gcd (remainder 206 40) + (remainder 40 + (remainder 206 40)))) 2) +(test-equal (gcd (remainder 206 40) + (remainder 40 + (remainder 206 40))) 2) +(test-equal (if (= (remainder 40 + (remainder 206 40)) 0) + (remainder 206 40) + (gcd (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))))) 2) +(test-equal (if (= 4 0) ;; previous 1 and 2 here equals 3 + (remainder 206 40) + (gcd (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))))) 2) +(test-equal (gcd (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))) 2) +(test-equal 2 (if (= (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) 0) + (remainder 40 + (remainder 206 40)) + (gcd (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))))))) +(test-equal 2 (if (= 2 0) ;; 4 now plus 3 previously is 5 + (remainder 40 + (remainder 206 40)) + (gcd (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))))))) +(test-equal 2 (gcd (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))))) +(test-equal 2 (if (= (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))) 0) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (gcd + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))) + (reminder (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))))))) +(test-equal 2 (if (= 0 0) ;; 5 previously plus 7 = 12 + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (gcd + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))) + (reminder (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40))) + (remainder (remainder 40 + (remainder 206 40)) + (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))))))) +(test-equal 2 (remainder (remainder 206 40) + (remainder 40 + (remainder 206 40)))) ;; 12 previously and 4 now is 16. + +;; Now for applicative-order evaluation: +(test-equal 2 (gcd 206 40)) +(test-equal 2 (if (= 40 0) + 206 + (gcd 40 (remainder 206 40)))) +(test-equal 2 (if #f + 206 + (gcd 40 (remainder 206 40)))) +(test-equal 2 (gcd 40 (remainder 206 40))) +(test-equal 2 (gcd 40 6)) ;; 1 +(test-equal 2 (if (= 6 0) + 40 + (gcd 6 (remainder 40 6)))) +(test-equal 2 (gcd 6 (remainder 40 6))) +(test-equal 2 (gcd 6 4)) ;; 2 +(test-equal 2 (if (= 4 0) + 6 + (gcd 4 (remainder 6 4)))) +(test-equal 2 (if #f + 6 + (gcd 4 (remainder 6 4)))) +(test-equal 2 (gcd 4 (remainder 6 4))) +(test-equal 2 (gcd 4 2)) ;; 3 +(test-equal 2 (if (= 2 0) + 4 + (gcd 2 (remainder 4 2)))) +(test-equal 2 (if #f + 4 + (gcd 2 (remainder 4 2)))) +(test-equal 2 (gcd 2 (remainder 4 2))) +(test-equal 2 (gcd 2 0)) ;; 4 +(test-equal 2 (if (= 0 0) + 2 + (gcd 0 (remainder 2 0)))) +(test-equal 2 (if #t + 2 + (gcd 0 (remainder 2 0)))) +(test-equal 2 2) +(test-end "1.20") diff --git a/solutions/exercise-1.21.scm b/solutions/exercise-1.21.scm @@ -0,0 +1,58 @@ +(define-library (solutions exercise-1.21) + (import (scheme base)) + (import (srfi srfi-1)) + (import (srfi srfi-64)) + (import (only (guile) random)) + (export prime? expmod fast-prime? smallest-divisor divides?) + + ;; XXX + + (begin + (define (smallest-divisor n) + (find-divisor n 2)) + + (define (find-divisor n test-divisor) + (cond + ((> (square test-divisor) n) + n) + + ((divides? test-divisor n) + test-divisor) + + (else (find-divisor n (+ 1 test-divisor))))) + + (define (divides? a b) + (= (remainder b a) 0)) + + (define (prime? n) + (= n (smallest-divisor n))) + + (define (expmod base exp m) + (cond + ((= exp 0) 1) + ((even? exp) + (remainder + (square (expmod base + (/ exp 2) + m)) + m)) + (else + (remainder + (* base + (expmod base + (- exp 1) + m)) + m)))) + + (define (fermat-test n) + (define (try-it a) + (= (expmod a n n) + a)) + (try-it (+ 1 (random (- n 1))))) + + (define (fast-prime? n times) + (cond + ((zero? times) #t) + ((fermat-test n) + (fast-prime? n (- times 1))) + (else #f))))) diff --git a/solutions/exercise-1.22.scm b/solutions/exercise-1.22.scm @@ -0,0 +1,57 @@ + +;; Exercise 1.22 + +(define (run-delay-if-full-flag d) + (if (any (cut equal? "--full" <>) + (command-line)) + (force d))) + +(run-delay-if-full-flag + (delay + (let ((port (open-output-file "primes.txt"))) + + (define (runtime) + (time-nanosecond (current-time time-process))) + + (define (display x) + (format port "~a" x)) + + (define (newline) + (format port "\n")) + + (define (timed-prime-test n) + ;; (newline) + ;; (display n) + (start-timed-test n (runtime))) + + (define (start-timed-test n start-time) + (cond + ((prime? n) + (newline) + (display "[") + (display n) + (report-prime (- (runtime) + start-time))) + (else #f))) + + (define (report-prime elapsed-time) + (display ", ") + (display elapsed-time) + (display "],") + (newline) + #t) + + (define (search-for-primes start-number end-number) + (cond + ((> start-number end-number) '()) + ((timed-prime-test start-number) + (cons start-number + (search-for-primes (+ start-number 2) end-number))) + (else (search-for-primes (+ start-number 2) end-number)))) + + (display "[") + + (search-for-primes 3 100001) + + (display "]") + (newline)))) diff --git a/solutions/exercise-1.23.scm b/solutions/exercise-1.23.scm @@ -0,0 +1,76 @@ + +;; Exercise 1.23 + +(define (next test-divisor) + (if (= test-divisor 2) + 3 + (+ test-divisor 2))) + +(define (smallest-divisor n) + (find-divisor n 2)) + +(define (find-divisor n test-divisor) + (cond + ((> (square test-divisor) n) + n) + + ((divides? test-divisor n) + test-divisor) + + (else (find-divisor n (next test-divisor))))) + +(test-begin "prime-1.23") +(test-equal '(#t #f #t #f #t #f) (map (cut divides? 2 <>) '(2 3 4 5 6 7))) +(test-equal '(2 3 2 5 2 7) (map smallest-divisor '(2 3 4 5 6 7))) +(test-equal '(#t #t #f #t #f #t) (map prime? '(2 3 4 5 6 7))) +(test-end "prime-1.23") + +(run-delay-if-full-flag + (delay + (let ((port (open-output-file "primes-half.txt"))) + + (define (runtime) + (time-nanosecond (current-time time-process))) + + (define (display x) + (format port "~a" x)) + + (define (newline) + (format port "\n")) + + (define (timed-prime-test n) + ;; (newline) + ;; (display n) + (start-timed-test n (runtime))) + + (define (start-timed-test n start-time) + (cond + ((prime? n) + (newline) + (display "[") + (display n) + (report-prime (- (runtime) + start-time))) + (else #f))) + + (define (report-prime elapsed-time) + (display ", ") + (display elapsed-time) + (display "],") + (newline) + #t) + + (define (search-for-primes start-number end-number) + (cond + ((> start-number end-number) '()) + ((timed-prime-test start-number) + (cons start-number + (search-for-primes (+ start-number 2) end-number))) + (else (search-for-primes (+ start-number 2) end-number)))) + + (display "[") + + (search-for-primes 3 100001) + + (display "]") + (newline)))) diff --git a/solutions/exercise-1.24.scm b/solutions/exercise-1.24.scm @@ -0,0 +1,54 @@ + +;; Exercise 1.24 + +;; I haven't got any idea what the hell I'm doing. XXX + +(run-delay-if-full-flag + (delay + (let ((port (open-output-file "primes-fast-prime.txt"))) + + (define (runtime) + (time-nanosecond (current-time time-process))) + + (define (display x) + (format port "~a" x)) + + (define (newline) + (format port "\n")) + + (define (timed-prime-test n) + ;; (newline) + ;; (display n) + (start-timed-test n (runtime))) + + (define (start-timed-test n start-time) + (cond + ((fast-prime? n (inexact->exact (ceiling (* n 0.01)))) + (newline) + (display "[") + (display n) + (report-prime (- (runtime) + start-time))) + (else #f))) + + (define (report-prime elapsed-time) + (display ", ") + (display elapsed-time) + (display "],") + (newline) + #t) + + (define (search-for-primes start-number end-number) + (cond + ((> start-number end-number) '()) + ((timed-prime-test start-number) + (cons start-number + (search-for-primes (+ start-number 2) end-number))) + (else (search-for-primes (+ start-number 2) end-number)))) + + (display "[") + + (search-for-primes 3 100001) + + (display "]") + (newline)))) diff --git a/solutions/exercise-1.3.scm b/solutions/exercise-1.3.scm @@ -0,0 +1,34 @@ +(define-library (solutions exercise-1.3) + (import (scheme base)) + (import (srfi srfi-64)) + (import (guile-1.1)) + + (begin + + #! + + *Exercise 1.3:* Define a procedure that takes three numbers as + arguments and returns the sum of the squares of the two larger + numbers. + + !# + + + + (define (exercise-1-3 a b c) + (if (< a b) + (if (< c a) + (sum-of-squares a b) + (sum-of-squares c b)) + (if (< c b) + (sum-of-squares b a) + (sum-of-squares c a)))) + + (test-begin "1.3") + (test-equal (exercise-1-3 2 3 5) 34) + (test-equal (exercise-1-3 2 5 3) 34) + (test-equal (exercise-1-3 3 2 5) 34) + (test-equal (exercise-1-3 3 5 2) 34) + (test-equal (exercise-1-3 5 2 3) 34) + (test-equal (exercise-1-3 5 3 2) 34) + (test-end "1.3"))) diff --git a/solutions/exercise-1.4.scm b/solutions/exercise-1.4.scm @@ -0,0 +1,27 @@ +(define-library (solutions exercise-1.4) + (import (scheme base)) + (import (srfi srfi-64)) + + + (begin + (define (a-plus-abs-b a b) + ((if (> b 0) + -) a b)) + + ;; The result of the "if" expression will be either the procedure "+" or + ;; the procedure "-", which is then applied to "a" and "b". + + + (test-begin "1.4") + (test-equal + (+ 2 3) + (a-plus-abs-b 2 3)) + (test-equal + (+ -2 3) + (a-plus-abs-b -2 3)) + (test-equal + (- 2 -3) + (a-plus-abs-b 2 -3)) + (test-equal + (- -2 -3) + (a-plus-abs-b -2 -3)) + (test-end "1.4"))) diff --git a/solutions/exercise-1.5.scm b/solutions/exercise-1.5.scm @@ -0,0 +1,45 @@ +#! + +*Exercise 1.5:* Ben Bitdiddle has invented a test to determine +whether the interpreter he is faced with is using +applicative-order evaluation or normal-order evaluation. He +defines the following two procedures: + +(define (p) (p)) + +(define (test x y) + (if (= x 0) + 0 + y)) + +Then he evaluates the expression + +(test 0 (p)) + +What behavior will Ben observe with an interpreter that uses +applicative-order evaluation? What behavior will he observe with +an interpreter that uses normal-order evaluation? Explain your +answer. (Assume that the evaluation rule for the special form + `if' is the same whether the interpreter is using normal or + applicative order: The predicate expression is evaluated first, + and the result determines whether to evaluate the consequent or + the alternative expression.) + +Applicative-order evaluation: + +(test 0 (p)) +(test 0 (p)) +(test 0 and so on) + +Normal-order evaluation: + +(test 0 (p)) +(if (= 0 0) + 0 + (p)) +(if #t + 0 + (p)) +0 + +!# diff --git a/solutions/exercise-1.6.scm b/solutions/exercise-1.6.scm @@ -0,0 +1,47 @@ +#! + +*Exercise 1.6:* Alyssa P. Hacker doesn't see why `if' needs to be +provided as a special form. "Why can't I just define it as an + ordinary procedure in terms of `cond'?" she asks. Alyssa's friend +Eva Lu Ator claims this can indeed be done, and she defines a new +version of `if': + +(define (new-if predicate then-clause else-clause) + (cond (predicate then-clause) + (else else-clause))) + +Eva demonstrates the program for Alyssa: + +(new-if (= 2 3) 0 5) +5 + +(new-if (= 1 1) 0 5) +0 + +Delighted, Alyssa uses `new-if' to rewrite the square-root program: + +(define (sqrt-iter guess x) + (new-if (good-enough? guess x) + guess + (sqrt-iter (improve guess x) + x))) + +What happens when Alyssa attempts to use this to compute square +roots? Explain. + +(sqrt-iter 1 2) +(new-if (good-enough? 1 2) + guess + (sqrt-iter (improve 1 2) + 2)) +(new-if #f + guess + (new-if (good-enough? (improve 1 2) 2) + (improve 1 2) + (sqrt-iter (improve (improve 1 2) 2) + 2))) +and so on. + +new-if would first have to evaluate all of its arguments, and only then would it choose the right value using cond. + +!# diff --git a/solutions/exercise-1.7.scm b/solutions/exercise-1.7.scm @@ -0,0 +1,50 @@ + +#! + +*Exercise 1.7:* The `good-enough?' test used in computing square +roots will not be very effective for finding the square roots of +very small numbers. Also, in real computers, arithmetic operations +are almost always performed with limited precision. This makes +our test inadequate for very large numbers. Explain these +statements, with examples showing how the test fails for small and +large numbers. An alternative strategy for implementing +`good-enough?' is to watch how `guess' changes from one iteration +to the next and to stop when the change is a very small fraction +of the guess. Design a square-root procedure that uses this kind +of end test. Does this work better for small and large numbers? + +!# + + +(define (square-root x) + (define (average a b) + (/ (+ a b) 2)) + + (define (improve guess x) + ;; (dp guess x) + (average guess (/ x guess))) + + (define (good-enough? old-guess new-guess) + (define bound 0.0000000000001) + (define ratio (/ old-guess new-guess)) + + (define within-bounds + (< (- 1 bound) ratio (+ 1 bound))) + + ;; (dp bound ratio within-bounds) + + within-bounds) + + (define (square-root-iter guess x) + (define new-guess (improve guess x)) + ;; (dp new-guess) + + (if (good-enough? guess new-guess) + guess + (square-root-iter new-guess + x))) + + (square-root-iter 1 x)) + +(format #t "~f\n" (square-root 0.000000000001)) +(format #t "~f\n" (square-root (/ 1 0.000000000001))) diff --git a/solutions/exercise-1.8.scm b/solutions/exercise-1.8.scm @@ -0,0 +1,49 @@ +#! + +*Exercise 1.8:* Newton's method for cube roots is based on the +fact that if y is an approximation to the cube root of x, then a +better approximation is given by the value + +x/y^2 + 2y +---------- +3 + +Use this formula to implement a cube-root procedure analogous to +the square-root procedure. (In section *Note 1-3-4:: we will see + how to implement Newton's method in general as an abstraction of + these square-root and cube-root procedures.) + +!# + +(define (cube-root x) + (define (improve guess) + ;; (dp guess x) + + (/ (+ (/ x + (* guess guess)) + (* 2 guess)) + 3)) + + (define (good-enough? old-guess new-guess) + (define bound 0.0000000000001) + (define ratio (/ old-guess new-guess)) + + (define within-bounds + (< (- 1 bound) ratio (+ 1 bound))) + + ;; (dp bound ratio within-bounds) + + within-bounds) + + (define (cube-root-iter guess) + (define new-guess (improve guess)) + ;; (dp new-guess) + + (if (good-enough? guess new-guess) + guess + (cube-root-iter new-guess))) + + (cube-root-iter 1)) + +(format #t "(cube-root ~f) => ~f\n" 0.000000000001 (cube-root 0.000000000001)) +(format #t "(cube-root ~f) => ~f\n" (/ 1 0.000000000001) (cube-root (/ 1 0.000000000001))) diff --git a/solutions/exercise-1.9.scm b/solutions/exercise-1.9.scm @@ -0,0 +1,103 @@ +#! + +*Exercise 1.9:* Each of the following two procedures defines a +method for adding two positive integers in terms of the procedures +`inc', which increments its argument by 1, and `dec', which +decrements its argument by 1. + +(define (+ a b) + (if (= a 0) + b + (inc (+ (dec a) b)))) + +(define (+ a b) + (if (= a 0) + b + (+ (dec a) (inc b)))) + +Using the substitution model, illustrate the process generated by +each procedure in evaluating `(+ 4 5)'. Are these processes +iterative or recursive? + +First: + +(+ 4 5) +(if (= 4 0) + 5 + (inc (+ (dec 4) 5))) +(if #f + 5 + (inc (+ (dec 4) 5))) +(inc (+ (dec 4) 5)) +(inc (+ 3 5)) +(inc (if (= 3 0) + 5 + (inc (+ (dec 3) 5)))) +(inc (if #f + 5 + (inc (+ (dec 3) 5)))) +(inc + (inc (+ (dec 3) 5))) +(inc + (inc (+ 2 5))) +(inc + (inc (if (= 2 0) + 5 + (inc (+ (dec 2) 5))))) +(inc + (inc (if #f + 5 + (inc (+ (dec 2) 5))))) +(inc + (inc + (inc (+ (dec 2) 5)))) +(inc + (inc + (inc (+ 1 5)))) +(inc + (inc + (inc (if (= 1 0) + 5 + (inc (+ (dec 1) 5)))))) +(inc + (inc + (inc (if #f + 5 + (inc (+ (dec 1) 5)))))) +(inc (inc (inc (inc (+ (dec 1) 5))))) +(inc (inc (inc (inc (+ 0 5))))) +(inc (inc (inc (inc (if (= 0 0) 5 (inc (+ (dec 0) 5))))))) +(inc (inc (inc (inc (if #t 5 (inc (+ (dec 0) 5))))))) +(inc (inc (inc (inc 5)))) +(inc (inc (inc 6))) +(inc (inc 7)) +(inc 8) +9 + +Recursive. + +Second: + +(+ 4 5) +(if (= 4 0) 5 (+ (dec 4) (inc 5))) +(if #f 5 (+ (dec 4) (inc 5))) +(+ 3 6) +(if (= 3 0) 6 (+ (dec 3) (inc 6))) +(if #f 6 (+ (dec 3) (inc 6))) +(+ (dec 3) (inc 6)) +(+ 2 7) +(if (= 2 0) 7 (+ (dec 2) (inc 7))) +(if #f 7 (+ (dec 2) (inc 7))) +(+ (dec 2) (inc 7)) +(+ 1 8) +(if (= 1 0) 8 (+ (dec 1) (inc 8))) +(if #f 8 (+ (dec 1) (inc 8))) +(+ (dec 1) (inc 8)) +(+ 0 9) +(if (= 0 0) 9 (+ (dec 0) (inc 9))) +(if #f 9 (+ (dec 0) (inc 9))) +9 + +Iterative. + +!# diff --git a/solutions/exercise-2.1.scm b/solutions/exercise-2.1.scm @@ -0,0 +1,34 @@ +;; Exercise 2.1 + +(define (make-rat n d) + (define g (gcd n d)) + (define sign (if (or (and (< n 0) + (> d 0)) + (and (> n 0) + (< d 0))) + -1 + 1)) + (cons (* sign + (abs (/ n g))) + (abs (/ d g)))) + +(test-begin "2.1") +(let () + (define (make-test) + (define n-sign (1- (* 2 + (random 2)))) + (define d-sign (1- (* 2 + (random 2)))) + (define n (* n-sign + (random 100))) + (define d (* d-sign + (1+ (random 100)))) + + (define built-in-rational (/ n d)) + (define ratsui (cons (numerator built-in-rational) + (denominator built-in-rational))) + (define matsui (make-rat n d)) + (test-equal (list n d ratsui) (list n d matsui))) + + (for-each (lambda (_) (make-test)) (iota 100))) +(test-end "2.1") diff --git a/solutions/exercise-2.17.scm b/solutions/exercise-2.17.scm @@ -0,0 +1,12 @@ +;; Exercise 2.17 + +(define (last-pair xs) + (cond + ((pair? (cdr xs)) (last-pair (cdr xs))) + (else xs))) + +(test-begin "2.17") +(test-equal + '(3) + (last-pair '(1 2 3))) +(test-end "2.17") diff --git a/solutions/exercise-2.18.scm b/solutions/exercise-2.18.scm @@ -0,0 +1,14 @@ +;; Exercise 2.18 + +(let* ([reverse + (lambda (xs) + (cond + ((null? xs) '()) + (else (append (reverse (cdr xs)) + (list (car xs))))))]) + + (test-begin "2.18") + (test-equal + '(3 2 1) + (reverse '(1 2 3))) + (test-end "2.18")) diff --git a/solutions/exercise-2.19.scm b/solutions/exercise-2.19.scm @@ -0,0 +1 @@ +;; Exercise 2.19 XXX diff --git a/solutions/exercise-2.2.scm b/solutions/exercise-2.2.scm @@ -0,0 +1,34 @@ +;; Exercise 2.2 + +(define (make-point x y) + (cons x y)) + +(define (x-point p) (car p)) + +(define (y-point p) (cdr p)) + +(define (make-segment p-start p-end) + (cons p-start p-end)) + +(define (start-segment s) (car s)) + +(define (end-segment s) (cdr s)) + +(define (midpoint-segment s) + (define start (start-segment s)) + (define end (end-segment s)) + + (make-point (/ (- (x-point end) + (x-point start)) + 2) + (/ (- (y-point end) + (y-point start)) + 2))) + +(test-begin "2.2") +(test-equal + (make-point 5 2) + (midpoint-segment (make-segment (make-point 0 0) + (make-point 10 4))) + ) +(test-end) diff --git a/solutions/exercise-2.20.scm b/solutions/exercise-2.20.scm @@ -0,0 +1,31 @@ +;; Exercise 2.20 + +(define (same-arity n . ns) + (define (same-arity' n ns) + (cond + ((null? ns) + (list n)) + ((or (and (even? n) + (even? (car ns))) + (and (odd? n) + (odd? (car ns)))) + (cons n + (same-arity' (car ns) + (cdr ns)))) + (else + (cons n + (same-arity' (cadr ns) + (cddr ns)))))) + (same-arity' n ns)) + + +(test-begin "2.20") +(test-equal + '(1 3 5 7) + (same-arity 1 2 3 4 5 6 7)) +(test-equal + '(2 4 6 8) + (same-arity 2 3 4 5 6 7 8)) +(test-equal '(1) (same-arity 1)) +(test-equal '(2) (same-arity 2)) +(test-end "2.20") diff --git a/solutions/exercise-2.21.scm b/solutions/exercise-2.21.scm @@ -0,0 +1,26 @@ +;; Exercise 2.21 + +(define (exercise-2.21) + (define (square-list-1 items) + (if (null? items) + '() + (cons (* (car items) + (car items)) + (square-list-1 (cdr items))))) + + (define (square-list-2 items) + (map (lambda (item) + (* item + item)) + items)) + + (test-begin "2.21") + (test-equal + '(1 4 9 16) + (square-list-1 '(1 2 3 4))) + (test-equal + '(1 4 9 16) + (square-list-2 '(1 2 3 4))) + (test-end "2.21")) + +(exercise-2.21) diff --git a/solutions/exercise-2.22.scm b/solutions/exercise-2.22.scm @@ -0,0 +1,45 @@ +;; Exercise 2.22 + +(define (exercise-2.22) + (define (square-list-1 items) + ;; answer is build by consing the first element of items onto the input nil + ;; (item-1 . nil) then the second onto (item-1 . nil), (item-2 . (item-1 . nil)) + ;; and the third (item-3 . (item-2 . (item-1 . nil))). + ;; In other words, you start by consing the first item onto the end of answer + ;; and you end by consing the last item of items onto the start of answer, + ;; building the cons onion inside out. + (define (iter things answer) + (if (null? things) + answer + (iter (cdr things) + (cons (* (car things) + (car things)) + answer)))) + (iter items '())) + + (define (square-list-2 items) + ;; In the second attempt you cons the answer to the first item (nil . item-1) + ;; then the answer onto the second item ((nil . item-1) item-2) and so on + ;; until you cons the answer onto the last item (... . item-n) which is the + ;; same as the first attempt, but instead of the accepted + ;; items-go-on-car-rest-of-list-goes-on-cdr, you have items-go-on-cdr-rest-of-list-goes-on-car. + ;; ((((nil . item-1) . item-2) . item-3) . item-4). + (define (iter things answer) + (if (null? things) + answer + (iter (cdr things) + (cons answer + (* (car things) + (car things)))))) + (iter items '())) + + (test-begin "2.22") + (test-equal + '(16 9 4 1) + (square-list-1 '(1 2 3 4))) + (test-equal + '((((() . 1) . 4) . 9) . 16) + (square-list-2 '(1 2 3 4))) + (test-end "2.22")) + +(exercise-2.22) diff --git a/solutions/exercise-2.23.scm b/solutions/exercise-2.23.scm @@ -0,0 +1,26 @@ +;; Exercise 2.23 + +(define (exercise-2.23) + (define (my-for-each proc lst) + (cond + ((null? lst) + '()) + (else + (proc (car lst)) + (my-for-each proc + (cdr lst))))) + + (define xs (list 1 2 3 4)) + + (test-begin "2.23") + (test-equal + '(1 2 3 4 5 6) + (begin + (my-for-each (lambda (x) + (set! xs (append xs + (list x)))) + '(5 6)) + xs)) + (test-end "2.23")) + +(exercise-2.23) diff --git a/solutions/exercise-2.24.scm b/solutions/exercise-2.24.scm @@ -0,0 +1,63 @@ +;; Exercise 2.24 + +;; scheme@(guile-user)> (list 1 (list 2 (list 3 4))) +;; $1 = (1 (2 (3 4))) + +;; -----> [1 |] +;; | +;; \--> [| ()] +;; | +;; \-> [2 |] +;; | +;; \-> [| ()] +;; | +;; \-> [3 |] +;; | +;; \-> [4 ()] + +;; (1 (2 (3 4))) +;; /\ +;; 1 (2 (3 4)) +;; /\ +;; 2 (3 4) +;; /\ +;; 3 4 + +(let* ([xs-34 (list 3 4)] + [xs-234 (list 2 xs-34)] + [xs-1234 (list 1 xs-234)]) + (test-begin "2.24") + (test-equal + (list 1 + (list 2 + (list 3 + 4))) + (cons 1 + (cons (cons 2 + (cons (cons 3 + (cons 4 + '())) + '())) + '()))) + (test-equal + (list 1 + (list 2 + (list 3 + 4))) + '(1 . ((2 . ((3 . (4 . ())) . ())) . ()))) + (test-equal + (list 1 (list 2 (list 3 4))) + (cons 1 + (cons (cons 2 + (cons xs-34 + '())) + '()))) + (test-equal + (list 1 (list 2 (list 3 4))) + (cons 1 + (cons xs-234 + '()))) + (test-equal + (list 1 (list 2 (list 3 4))) + xs-1234) + (test-end "2.24")) diff --git a/solutions/exercise-2.25.scm b/solutions/exercise-2.25.scm @@ -0,0 +1,26 @@ +;; Exercise 2.25 + +(test-begin "2.25") +(test-equal + 7 + (car (cdr (car (cdr (cdr '(1 3 (5 7) 9))))))) +(test-equal + 7 + (car (car '((7))))) +(test-equal + 7 + (car ;; 7 + (cdr ;; (cons 7 '()) + (car ;; (cons 2 (cons (cons 3 ...) '())) + (cdr ;; (cons (cons 6 (cons 7 '())) '()) + (car ;; (cons 5 (cons (cons 6 (cons 7 '()) '()))) + (cdr ;; (cons (cons 5 ...) '()) + (car ;; (cons 4 (cons (cons 5 ...) '())) + (cdr ;; (cons (cons 4 ...) '()) + (car ;; (cons 3 (cons (cons 4 ...) '())) + (cdr ;; (cons (cons 3 ...) '()) + (car ;; (cons 2 (cons (cons 3 ...) '())) + (cdr ;; (cons (cons 2 ...) '()) + ;; (cons 1 (cons (cons 2 ...) '())) + '(1 (2 (3 (4 (5 (6 7))))))))))))))))))) +(test-end "2.25") diff --git a/solutions/exercise-2.26.scm b/solutions/exercise-2.26.scm @@ -0,0 +1,30 @@ +;; Exercise 2.26 + +;; (define x (list 1 2 3)) +;; (define y (list 4 5 6)) +;; (append x y) => (1 2 3 4 5 6) +;; (cons x y) => ((1 2 3) 4 5 6) +;; (list x y) => ((1 2 3) (4 5 6)) + +;; scheme@(guile-user)> (define x (list 1 2 3)) +;; scheme@(guile-user)> (define y (list 4 5 6)) +;; scheme@(guile-user)> (append x y) +;; $1 = (1 2 3 4 5 6) +;; scheme@(guile-user)> (cons x y) +;; $2 = ((1 2 3) 4 5 6) +;; scheme@(guile-user)> (list x y) +;; $3 = ((1 2 3) (4 5 6)) + +(let ([x (list 1 2 3)] + [y (list 4 5 6)]) + (test-begin "2.26") + (test-equal + "(1 2 3 4 5 6)" + (format #f "~a" (append x y))) + (test-equal + "((1 2 3) 4 5 6)" + (format #f "~a" (cons x y))) + (test-equal + "((1 2 3) (4 5 6))" + (format #f "~a" (list x y))) + (test-end "2.26")) diff --git a/solutions/exercise-2.27.scm b/solutions/exercise-2.27.scm @@ -0,0 +1,20 @@ +;; Exercise 2.27 + +(letrec ([deep-reverse + (lambda (xs) + (cond + ((null? xs) '()) + ((pair? xs) + (append (deep-reverse (cdr xs)) + (list (deep-reverse (car xs))))) + (else xs)))] + [x (list (list 1 2) + (list 3 4))]) + (test-begin "2.27") + (test-equal + '((3 4) (1 2)) + (reverse x)) + (test-equal + '((4 3) (2 1)) + (deep-reverse x)) + (test-end "2.27")) diff --git a/solutions/exercise-2.28.scm b/solutions/exercise-2.28.scm @@ -0,0 +1,27 @@ +;; Exercise 2.28 + +(define (exercise-2.28) + (define (fringe a-tree) + (cond + ((null? a-tree) '()) + ((pair? a-tree) + (cond + ((pair? (car a-tree)) + (append (fringe (car a-tree)) + (fringe (cdr a-tree)))) + (else (cons (car a-tree) + (fringe (cdr a-tree)))))) + (else a-tree))) + + (define x '((1 2) (3 4))) + + (test-begin "2.28") + (test-equal + '(1 2 3 4) + (fringe x)) + (test-equal + '(1 2 3 4 1 2 3 4) + (fringe (list x x))) + (test-end "2.28")) + +(exercise-2.28) diff --git a/solutions/exercise-2.29.scm b/solutions/exercise-2.29.scm @@ -0,0 +1,99 @@ +;; Exercise 2.29 + +(define (exercise-2.29) + '(define (make-mobile left-branch right-branch) + (list left-branch right-branch)) + + (define (make-mobile left-branch right-branch) + (cons left-branch right-branch)) + + '(define (make-branch length structure) + (list length structure)) + + (define (make-branch length structure) + (cons length structure)) + + (define (left-branch mobile) + (car mobile)) + + '(define (right-branch mobile) + (cadr mobile)) + + (define (right-branch mobile) + (cdr mobile)) + + (define (branch-length branch) + (car branch)) + + '(define (branch-structure branch) + (cadr branch)) + + (define (branch-structure branch) + (cdr branch)) + + (define (total-weight mobile) + (cond + ((number? mobile) mobile) + (else + (let ([left-branch-structure + (branch-structure (left-branch mobile))] + [right-branch-structure + (branch-structure (right-branch mobile))]) + + (+ (if (number? left-branch-structure) + left-branch-structure + (total-weight left-branch-structure)) + (if (number? right-branch-structure) + right-branch-structure + (total-weight right-branch-structure))))))) + + (define (branch-torque branch) + (* (branch-length branch) + (total-weight (branch-structure branch)))) + + (define (balanced mobile) + (= (branch-torque (left-branch mobile)) + (branch-torque (right-branch mobile)))) + + + (test-begin "2.29") + (test-equal + 10 + (total-weight + (make-mobile (make-branch 2 3) + (make-branch 5 7)))) + (test-equal + 64 + (total-weight + (make-mobile (make-branch 2 + (make-mobile (make-branch 3 5) + (make-branch 7 11))) + (make-branch 13 + (make-mobile (make-branch 17 19) + (make-branch 23 29)))))) + (test-equal + 6 + (branch-torque (make-branch 2 3))) + (test-equal + #t + (balanced (make-mobile (make-branch 3 5) + (make-branch 5 3)))) + (test-equal + #t + (balanced (make-mobile (make-branch 3 + (make-mobile (make-branch 4 1) + (make-branch 1 4))) + (make-branch 5 + (make-mobile (make-branch 1 2) + (make-branch 2 1)))))) + (test-equal + #f + (balanced (make-mobile (make-branch 3 + (make-mobile (make-branch 4 1) + (make-branch 1 3))) + (make-branch 5 + (make-mobile (make-branch 1 2) + (make-branch 2 1)))))) + (test-end "2.29")) + +(exercise-2.29) diff --git a/solutions/exercise-2.3.scm b/solutions/exercise-2.3.scm @@ -0,0 +1,4 @@ +;; Exercise 2.3 + +(define (make-rectangle segment angle) + '()) diff --git a/solutions/exercise-2.30.scm b/solutions/exercise-2.30.scm @@ -0,0 +1,35 @@ +;; Exercise 2.30 + +(define (exercise-2.30) + (define (directly-square-tree tree) + (cond + ((null? tree) '()) + ((pair? tree) (cons (directly-square-tree (car tree)) + (directly-square-tree (cdr tree)))) + (else (* tree tree)))) + + (define (higher-order-square-tree tree) + (map (lambda (sub-tree) + (if (pair? sub-tree) + (higher-order-square-tree sub-tree) + (* sub-tree sub-tree))) + tree)) + + (define a-tree + '(1 (2 (3 4) 5) + (6 7))) + + (define a-tree-squared + '(1 (4 (9 16) 25) + (36 49))) + + (test-begin "2.30") + (test-equal + a-tree-squared + (directly-square-tree a-tree)) + (test-equal + a-tree-squared + (higher-order-square-tree a-tree)) + (test-end "2.30")) + +(exercise-2.30) diff --git a/solutions/exercise-2.31.scm b/solutions/exercise-2.31.scm @@ -0,0 +1,33 @@ +;; Exercise 2.31 + +(define (exercise-2.31) + (define (tree-map proc tree) + (map (lambda (sub-tree) + (if (pair? sub-tree) + (tree-map proc + sub-tree) + (proc sub-tree))) + tree)) + + (define (square-tree tree) + (tree-map (lambda (x) (* x x)) + tree)) + + (define a-tree + '(1 (2 (3 4) 5) + (6 7))) + + (define a-tree-squared + '(1 (4 (9 16) 25) + (36 49))) + + (test-begin "2.31") + (test-equal + a-tree-squared + (square-tree a-tree)) + (test-equal + a-tree-squared + (square-tree a-tree)) + (test-end "2.31")) + +(exercise-2.31) diff --git a/solutions/exercise-2.32.scm b/solutions/exercise-2.32.scm @@ -0,0 +1,91 @@ +;; Exercise 2.32 + +(define (exercise-2.32) + (define (subsets s) + (if (null? s) + (list '()) + (let ([rest (subsets (cdr s))]) + (append rest + (map (lambda (x) + (cons (car s) + x)) + rest))))) + + (subsets '()) + (if (null? '()) + (list '()) + (let ([rest (subsets (cdr s))]) + (append rest + (map (lambda (x) + (cons (car s) + x)) + rest)))) + (list '()) + + (subsets '(1)) + (if (null? '(1)) + (list '()) + (let ([rest (subsets (cdr '(1)))]) + (append rest + (map (lambda (x) + (cons (car '(1)) + x)) + rest)))) + (let ([rest (subsets (cdr '(1)))]) + (append rest + (map (lambda (x) + (cons (car '(1)) + x)) + rest))) + (let ([rest (subsets '())]) + (append rest + (map (lambda (x) + (cons (car '(1)) + x)) + rest))) + (append '(()) + (map (lambda (x) + (cons 1 x)) + '(()))) + (append '(()) + (list (cons 1 '()))) + (append (list '()) + (list (list 1))) + (list '() (list 1)) + + ;; We go deep into the list each time we [rest (subset (cdr s))]. + ;; The first rest we really get is '(). + ;; Then we append (list rest) to (map ... rest). + ;; (map ... rest) is (map ... '()), so it's '(). + ;; (list rest) is '(()), so we append '(()) to '(), + ;; which is '(()). We return that to the above procedure call + ;; and now rest is '(()). + ;; We append '(()) to (map ... '(())). + ;; This time we map over a non-empty list, so the map proc + ;; is important. It is (map (lambda (x) (cons (car s) x)) rest). + ;; That is, we attach the current first element of s to each of + ;; the elements of rest. Because this is done from the last to first + ;; items of s in the subsets call stack, we first cons the last element + ;; first while unwinding the callstack. + ;; (map ... rest) is (list (cons (car s) '())), so (map ...) + ;; is (list (list s-item-n)). rest is '(()), so attaching + ;; '(()) to (list s-item-n) is (list '() (list s-item-n)). + ;; We return that and assign to rest. + ;; Now rest is (list '() (list s-item-n)). + ;; We attach (list '() (list s-item-n)) to + ;; (list (list s-item-n-1) (list s-item-n-1 s-item-n)) + ;; thereby getting (list '() (list s-item-n) (list s-item-n-1) (list s-item-n-1 s-item-n)) + ;; and we see the pattern. Each time we go up the call stack we append the previous combinations, + ;; rest, to the list where s-item-i was consed to each of the elements of rest. + ;; So at each point we append the list, rest, where s-item-i did not appear to the list + ;; where it did appear and return that. + ;; In the end we get all combinations of subsets where any particular s-item-i appared and all + ;; combinations of subsets where s-item-i did not appear. + + (test-begin "2.32") + (test-equal + '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)) + (subsets '(1 2 3))) + (test-end "2.32")) + +(exercise-2.32) diff --git a/solutions/exercise-2.33.scm b/solutions/exercise-2.33.scm @@ -0,0 +1,40 @@ +(define-library (solutions exercise-2.33) + (import (scheme base)) + (import (utils)) + (export map-2.33 append-2.33 length-2.33) + + (begin + (define (map-2.33 p sequence) + (accumulate (lambda (x y) + (cons (p x) + y)) + '() + sequence)) + + (define (append-2.33 seq1 seq2) + (accumulate cons + seq2 + seq1)) + + (define (length-2.33 sequence) + (accumulate (lambda (x y) (+ 1 y)) + 0 + sequence)) + + + (define (map p sequence) + (accumulate (lambda (x y) + (cons (p x) + y)) + '() + sequence)) + + (define (append seq1 seq2) + (accumulate cons + seq2 + seq1)) + + (define (length sequence) + (accumulate (lambda (x y) (+ 1 y)) + 0 + sequence)))) diff --git a/solutions/exercise-2.34.scm b/solutions/exercise-2.34.scm @@ -0,0 +1,14 @@ +(define-library (solutions exercise-2.34) + (import (scheme base)) + (import (utils)) + (export horner-eval) + + (begin + (define (horner-eval x coefficient-sequence) + (accumulate + (lambda (this-coeff higher-terms) + (+ (* higher-terms + x) + this-coeff)) + 0 + coefficient-sequence)))) diff --git a/solutions/exercise-2.35.scm b/solutions/exercise-2.35.scm @@ -0,0 +1,22 @@ +(define-library (solutions exercise-2.35) + (import (scheme base)) + (import (sicp utils)) + (export count-leaves count-leaves-2.2.2) + + (begin + (define (count-leaves-2.2.2 tree) + (cond + ((null? tree) 0) + ((not (pair? tree)) 1) + (else (+ (count-leaves (car tree)) + (count-leaves (cdr tree)))))) + + (define (count-leaves t) + (accumulate + + + 0 + (map (lambda (x) + (if (pair? x) + (count-leaves x) + 1)) + t))))) diff --git a/solutions/exercise-2.36.scm b/solutions/exercise-2.36.scm @@ -0,0 +1,18 @@ +(define-library (solutions exercise-2.36) + (import (scheme base)) + (import (sicp utils)) + (export accumulate-n) + + (begin + (define (accumulate-n op init seqs) + ;; Took it out of exercise-2.36 because we'll need it later in 2.37. + (if (null? (car seqs)) + '() + (cons (accumulate op + init + (map (lambda (x) (car x)) + seqs)) + (accumulate-n op + init + (map (lambda (x) (cdr x)) + seqs))))))) diff --git a/solutions/exercise-2.37.scm b/solutions/exercise-2.37.scm @@ -0,0 +1,98 @@ +;; Exercise 2.37 + +(define (exercise-2.37) + (define (matrix-ref m i j) + (list-ref (list-ref m i) j)) + + (define (dot-product v w) + (accumulate + + 0 + (map * + v + w))) + + (define (dumb-dot-product v w) + (sum (list-ec (: i + (length v)) + (* (list-ref v + i) + (list-ref w + i))))) + + (define (matrix-*-vector m v) + (map (lambda (w) (dot-product v + w)) + m)) + + (define (dumb-matrix-*-vector m v) + (list-ec (: i + (length m)) + (accumulate + + 0 + (list-ec (: j + (length v)) + (* (matrix-ref m i j) + (list-ref v + j)))))) + + (define (transpose mat) + (accumulate-n cons + '() + mat)) + + (define (dumb-transpose mat) + (list-ec (: j + (length (car mat))) + (list-ec (: i + (length mat)) + (matrix-ref mat i j)))) + + (define (matrix-*-matrix m n) + (let ([cols (transpose n)]) + (map (lambda (v) + (matrix-*-vector cols v)) + m))) + + (define (dumb-matrix-*-matrix m n) + ;; p_ij = sum_k(m_ik * n_kj) + (list-ec (: i (length m)) + (list-ec (: j (length (car n))) + (sum-ec (: k (length n)) + (* (matrix-ref m i k) + (matrix-ref n k j)))))) + + (define v '(2 3 5 7)) + + (define M + '((1 2 3 4) + (4 5 6 6) + (6 7 8 9))) + + (define M-transposed + '((1 4 6) + (2 5 7) + (3 6 8) + (4 6 9))) + + (test-begin "2.37") + (test-equal + (dumb-transpose M) + (transpose M)) + (test-equal + (dumb-matrix-*-vector M + v) + (matrix-*-vector M + v)) + (test-equal + (dumb-matrix-*-matrix M + M-transposed) + (matrix-*-matrix M + M-transposed)) + (test-equal + (dumb-matrix-*-matrix '((2 3) (5 7)) + '((2 3) (5 7))) + (matrix-*-matrix '((2 3) (5 7)) + '((2 3) (5 7)))) + (test-end "2.37")) + +(exercise-2.37) diff --git a/solutions/exercise-2.38.scm b/solutions/exercise-2.38.scm @@ -0,0 +1,122 @@ +;; Exercise 2.38 + +(define (my-fold-right op initial sequence) + (accumulate op initial sequence)) + +(define (my-fold-left op initial sequence) + (define (iter result rest) + (if (null? rest) + result + (iter (op result (car rest)) + (cdr rest)))) + (iter initial sequence)) + +(define (exercise-2.38) + (define my-fold-right-/-ratsui + (/ 1 + (/ 2 + (/ 3 + 1)))) + (define my-fold-left-/-ratsui + (/ (/ (/ 1 + 1) + 2) + 3)) + (define my-fold-right-list-ratsui + (list 1 + (list 2 + (list 3 + '())))) + (define my-fold-left-list-ratsui + (list (list (list '() + 1) + 2) + 3)) + + (test-begin "2.38") + (test-equal my-fold-right-/-ratsui + (my-fold-right / + 1 + (list 1 2 3))) + (test-equal my-fold-right-/-ratsui + (my-fold-right / + (/ 3 + 1) + (list 1 2))) + (test-equal my-fold-right-/-ratsui + (my-fold-right / + (/ 2 + (/ 3 + 1)) + (list 1))) + (test-equal my-fold-right-/-ratsui + (my-fold-right / + (/ 1 + (/ 2 + (/ 3 + 1))) + (list))) + (test-equal my-fold-left-/-ratsui + (my-fold-left / + 1 + (list 1 2 3))) + (test-equal my-fold-left-/-ratsui + (my-fold-left / + (/ 1 + 1) + (list 2 3))) + (test-equal my-fold-left-/-ratsui + (my-fold-left / (/ (/ 1 + 1) + 2) + (list 3))) + (test-equal my-fold-left-/-ratsui + (my-fold-left / (/ (/ (/ 1 + 1) + 2) + 3) + (list))) + (test-equal my-fold-right-list-ratsui + (my-fold-right list + '() + (list 1 2 3))) + (test-equal my-fold-right-list-ratsui + (my-fold-right list + (list 3 '()) + (list 1 2))) + (test-equal my-fold-right-list-ratsui + (my-fold-right list + (list 2 (list 3 '())) + (list 1))) + (test-equal my-fold-right-list-ratsui + (my-fold-right list + (list 1 (list 2 (list 3 '()))) + (list))) + (test-equal my-fold-left-list-ratsui + (my-fold-left list + '() + (list 1 2 3))) + (test-equal my-fold-left-list-ratsui + (my-fold-left list + (list '() 1) + (list 2 3))) + (test-equal my-fold-left-list-ratsui + (my-fold-left list + (list (list '() 1) 2) + (list 3))) + (test-equal my-fold-left-list-ratsui + (my-fold-left list + (list (list (list '() 1) 2) 3) + (list))) + (test-end "2.38") + + ;; if op: A -> A, + ;; (cut my-fold-right op <> <>) is equivalent to (cut my-fold-left op <> <>) + ;; iff + ;; for all a, b, c in A, + ;; (op (op a b) c) = (op a (op b c)). + ;; Did I get that right? Seems right. + ) + +(exercise-2.38) + diff --git a/solutions/exercise-2.39.scm b/solutions/exercise-2.39.scm @@ -0,0 +1,29 @@ +;; Exercise 2.39 + +(define (exercise-2.39) + (define (reverse-my-fold-right sequence) + (my-fold-right + (lambda (x y) + (append y + (list x))) + '() + sequence)) + + (define (reverse-my-fold-left sequence) + (my-fold-left + (lambda (x y) + (append (list y) + x)) + '() + sequence)) + + (test-begin "2.39") + (test-equal + '(4 3 2 1) + (reverse-my-fold-right '(1 2 3 4))) + (test-equal + '(4 3 2 1) + (reverse-my-fold-left '(1 2 3 4))) + (test-end "2.39")) + +(exercise-2.39) diff --git a/solutions/exercise-2.4.scm b/solutions/exercise-2.4.scm @@ -0,0 +1,23 @@ +;; Exercise 2.4 + +(test-begin "2.4") + +(let ((cons (lambda (x y) (lambda (m) (m x y)))) + (car (lambda (z) (z (lambda (p q) p)))) + (cdr (lambda (z) (z (lambda (p q) q))))) + + + (for-each + (lambda (matsui) (test-equal 'x matsui)) + (list (car (cons 'x 'y)) + (car (lambda (m) (m 'x 'y))) + ((lambda (m) (m 'x 'y)) (lambda (p q) p)) + ((lambda (p q) p) 'x 'y))) + (for-each + (lambda (matsui) (test-equal 'y matsui)) + (list (cdr (cons 'x 'y)) + (cdr (lambda (m) (m 'x 'y))) + ((lambda (m) (m 'x 'y)) (lambda (p q) q)) + ((lambda (p q) q) 'x 'y)))) + +(test-end "2.4") diff --git a/solutions/exercise-2.40.scm b/solutions/exercise-2.40.scm @@ -0,0 +1,69 @@ +(define-library (solutions exercise-2.40) + (import (scheme base)) + (import (srfi :1)) + (import (sicp utils)) + (import (solutions exercise-1.21)) + (export unique-pairs prime-sum-pairs my-prime-sum-pairs) + + (begin + (define (unique-pairs n) + (flatmap (lambda (i) + (map (lambda (j) + (list i j)) + (enumerate-interval 1 (- i 1)))) + (enumerate-interval 1 n))) + + (define (remove item seqeunce) + (filter (lambda (x) + (not (equal? x + item))) + sequence)) + + (define (permutations s) + (if (null? s) + (list '()) + (flatmap (lambda (x) + (map (lambda (p) + (cons x p)) + (permutations (remove x + s)))) + s))) + + (define (f n) + (accumulate + append + '() + (map (lambda (i) + (map (lambda (j) + (list i j)) + (enumerate 1 (- i 1)))) + (enumerate-interval 1 n)))) + + (define (g n) + (flatmap (lambda (x) x) (enumerate-interval 1 n))) + + (define (prime-sum? pair) + (prime? (+ (car pair) + (cadr pair)))) + + (define (make-pair-sum pair) + (list (car pair) + (cadr pair) + (+ (car pair) + (cadr pair)))) + + (define (prime-sum-pairs n) + (map make-pair-sum + (filter + prime-sum? + (flatmap + (lambda (i) + (map (lambda (j) + (list i j)) + (enumerate-interval 1 (- i 1)))) + (enumerate-interval 1 n))))) + + (define (my-prime-sum-pairs n) + (map make-pair-sum + (filter prime-sum? + (unique-pairs n)))))) diff --git a/solutions/exercise-2.41.scm b/solutions/exercise-2.41.scm @@ -0,0 +1,8 @@ +(define-library (solutions exercise-2.41) + (begin + (define (unique-triples n) + (flatmap (lambda (pair) + (map (lambda (k) + (append pair (list k))) + (enumerate-interval 1 (1- (cadr pair))))) + (unique-pairs n))))) diff --git a/solutions/exercise-2.42.scm b/solutions/exercise-2.42.scm @@ -0,0 +1,148 @@ +(define-library (solutions exercise-2.42) + (import (scheme base)) + (import (srfi :1)) + (import (sicp utils)) + (export safe? queens make-position) + + (begin + (define (make-position row column) + (cons row column)) + + (define (position-row position) + (car position)) + + (define (position-column position) + (cdr position)) + + (define (adjoin-position row column rest-of-queens) + (cons (make-position row column) + rest-of-queens)) + + (define empty-board '()) ;; queens 0 will return [[]]. + + (define (threatening-pair? queen-a-position queen-b-position) + (define a-row (position-row queen-a-position)) + (define b-row (position-row queen-b-position)) + + (define a-column (position-column queen-a-position)) + (define b-column (position-column queen-b-position)) + + (define rows-equal (= a-row + b-row)) + + (define on-same-diagonal (= (abs (- a-row + b-row)) + (abs (- a-column + b-column)))) + + (or rows-equal + on-same-diagonal)) + + " + Q + Q + Q + +Q1 = (2, 1) +Q2 = (3, 2) +Q1 - Q2 = (2 - 3, 1 - 2) += (-1, -1) +Q3 = (4, 3) +Q1 - Q3 = (2 - 4, 1 - 3) += (-2, -2) + + Q + Q + Q +Q + +Q1 = (4, 1) +Q2 = (3, 2) +Q3 = (2, 3) + +Q1 - Q2 = (4 - 3, 1 - 2) += (1, -1) +Q1 - Q3 = (4 - 2, 1 - 3) += (2, -2) +Q1 - Q4 = (4 - 1, 1 - 4) += (3, -3) +" + + + (define (safe? our-column board) + (define our-row (position-row (car board))) + + (if (null? + (filter + (lambda (position) + (threatening-pair? + (make-position our-row + our-column) + position)) + (cdr board))) + #t + #f)) + + (define (queens board-size) + (define (queen-cols k) + (if (= k 0) + (list empty-board) + (filter + (lambda (positions) + (safe? k + positions)) + (flatmap + (lambda (rest-of-queens) + (map (lambda (new-row) + (adjoin-position + new-row + k + rest-of-queens)) + (enumerate-interval + 1 + board-size))) + (queen-cols (- k 1)))))) + (queen-cols board-size)) + + (define (display-board board n) + (define sorted-board + (sort board + (lambda (a b) + (or + (< (position-row a) + (position-row b)) + ;; (< (position-column a) + ;; (position-column b)) + )))) + '(define sorted-board board) + + (define (display-row column n) + (pretty-print (list column n)) + (cond + ((zero? n) '()) + ((= column n) + (display "Q\n") + (display-row column (- n 1))) + (else (display ".") + (display-row column (- n 1))))) + + (for-each + (lambda (position) + (display-row + (position-column position) + n)) + sorted-board)) + + '(for-each (lambda (board) + (display-board board + (reduce + (lambda (x y) + (max (position-column x) + (position-column y))) + 0 + board)) + (pretty-print board)) + (flatmap queens + (enumerate-interval 1 8))) + + )) diff --git a/solutions/exercise-2.5.scm b/solutions/exercise-2.5.scm @@ -0,0 +1,46 @@ +;; Exercise 2.5 + +(define (power a b) + (define (power' a b result) + (cond + ((= b 0) result) + (else (power' a (1- b) (* a result))))) + (power' a b 1)) + +(test-begin "power") +(test-equal 8 (power 2 3)) +(test-end "power") + +(define (exercise-2.5) + (define (cons a b) + (* (power 2 a) + (power 3 b))) + + (define (car z) + (define (car' z result) + (cond + ((odd? z) result) + (else (car' (/ z 2) + (1+ result))))) + + (car' z 0)) + + (define (cdr z) + (define (cdr' z result) + (cond + ((not (= (remainder z 3) 0)) result) + (else (cdr' (/ z 3) + (1+ result))))) + + (cdr' z 0)) + + (test-begin "2.5") + (do-ec (: a 1 10) + (: b 1 10) + (test-equal + (list a b) + (list (car (cons a b)) + (cdr (cons a b))))) + (test-end "2.5")) + +(exercise-2.5) diff --git a/solutions/exercise-2.53.scm b/solutions/exercise-2.53.scm @@ -0,0 +1,32 @@ +(define (exercise-2.53) + (test-begin "2.53") + (test-equal + '(a b c) + (list 'a 'b 'c)) + (test-equal + '((george)) + (list (list 'george))) + (test-equal + '((y1 y2)) + ;; '((x1 x2) (y1 y2)) is a pair whose first item is (x1 x2) and + ;; second is a pair whose first item is (y1 y2) and second is nil, + ;; so (cdr '((x1 x2) (y1 y2))) is ((y1 y2)). + (cdr '((x1 x2) (y1 y2)))) + (test-equal + '(y1 y2) + ;; the cadr is the first element of the pair whose first item is (y1 y2) and second is nil. + (cadr '((x1 x2) (y1 y2)))) + (test-equal + #f + (pair? (car '(a short list)))) + (test-equal + #f + ;; No symbol red in the list, so answer is false. + (memq 'red '((red shoes) (blue socks)))) + (test-equal + '(red shoes blue socks) + ;; The first element of the first pair is red, so that pair is returned. + (memq 'red '(red shoes blue socks))) + (test-end "2.53")) + +(exercise-2.53) diff --git a/solutions/exercise-2.54.scm b/solutions/exercise-2.54.scm @@ -0,0 +1,44 @@ + +(define (exercise-2.54) + (define (my-equal? a b) + (cond + ((and (null? a) + (null? b)) + #t) + ((and (symbol? a) + (symbol? b)) + (eq? a + b)) + ((and (pair? a) + (pair? b)) + (and (my-equal? (car a) + (car b)) + (my-equal? (cdr a) + (cdr b)))) + (else #f))) + + (test-begin "2.54") + (test-equal + #t + (my-equal? 'a 'a)) + (test-equal + #f + (my-equal? 'a 'b)) + (test-equal + #f + (my-equal? '(a) 'b)) + (test-equal + #t + (my-equal? '(a) '(a))) + (test-equal + #t + (my-equal? '((a b c ((d e) f) g h)) '((a b c ((d e) f) g h)))) + (test-equal + #f + (my-equal? '((a b c ((d e) f) g h)) '((a b c (d e f) g h)))) + (test-equal + #f + (my-equal? '((a b c ((d e) f) g h)) '((a b c ((d d) f) g h)))) + (test-end "2.54")) + +(exercise-2.54) diff --git a/solutions/exercise-2.55.scm b/solutions/exercise-2.55.scm @@ -0,0 +1,6 @@ +;; Exercise 2.55 + +;; The 'foo is syntactic sugar for (quote foo). +;; If foo is 'abracadabra, which is (quote abracadabra), +;; then ''abracadabra is (quote (quote abracadabra)). + diff --git a/solutions/exercise-2.56.scm b/solutions/exercise-2.56.scm @@ -0,0 +1,156 @@ +;; Exercise 2.56 + +(define (deriv-stuff) + ;; Original: + ;; (define (make-sum a1 a2) + ;; (list '+ a1 a2)) + + (define (=number? exp num) + (and (number? exp) + (= exp num))) + + ;; Simplificating make-sum: + (define (make-sum a1 a2) + (cond + ((=number? a1 0) a2) + ((=number? a2 0) a1) + ((and (number? a1) + (number? a2)) + (+ a1 a2)) + (else (list '+ a1 a2)))) + + (define (sum? x) + (and (pair? x) + (eq? (car x) + '+))) + + (define (addend s) + (cadr s)) + + (define (augend s) + (caddr s)) + + ;; Original: + ;; (define (make-product m1 m2) + ;; (list '* m1 m2)) + + ;; Simplificating make-product: + (define (make-product m1 m2) + (cond + ((or (=number? m1 0) + (=number? m2 0)) + 0) + ((=number? m1 1) m2) + ((=number? m2 1) m1) + ((and (number? m1) + (number? m2)) + (* m1 m2)) + (else (list '* m1 m2)))) + + (define (product? x) + (and (pair? x) + (eq? (car x) + '*))) + + (define (multiplier p) + (cadr p)) + + (define (multiplicand p) + (caddr p)) + + (define (make-exponentiation b e) + (cond + ((=number? e 0) 1) + ((=number? b 1) b) + (else (list '** b e)))) + + ;; Exercise 2.56 + (define (exponentiation? e) + (and (pair? e) + (eq? (car e) + '**))) + + (define (base e) + (cadr e)) + + (define (exponent e) + (caddr e)) + + (define (variable? x) + (symbol? x)) + + (define (same-variable? v1 v2) + (and (variable? v1) + (variable? v2) + (eq? v1 v2))) + + (define (deriv exp var) + (cond + ((number? exp) 0) + ((variable? exp) + (if (same-variable? exp + var) + 1 + 0)) + ((sum? exp) + (make-sum (deriv (addend exp) + var) + (deriv (augend exp) + var))) + ((product? exp) + (make-sum + (make-product (multiplier exp) + (deriv (multiplicand exp) + var)) + (make-product (deriv (multiplier exp) + var) + (multiplicand exp)))) + ;; Exercise 2.56 + ((exponentiation? exp) + ;; d(x**n)/dx = n*x**(n-1) + (make-product (exponent exp) + (make-exponentiation (base exp) + (make-sum (exponent exp) + -1)))) + (else (error "Unknown expression + type: DERIV" exp)))) + + (test-begin "deriv-stuff") + ;; Original: + ;; (test-equal + ;; '(+ 1 0) + ;; (deriv '(+ x 3) 'x)) + ;; (test-equal + ;; '(+ (* x 0) (* 1 y)) + ;; (deriv '(* x y) 'x)) + ;; (test-equal + ;; '(+ (* (* x + ;; y) + ;; (+ 1 + ;; 0)) + ;; (* (+ (* x 0) + ;; (* 1 y)) + ;; (+ x 3))) + ;; (deriv '(* (* x y) (+ x 3)) 'x)) + + ;; Simplificating: + (test-equal + 1 + (deriv '(+ x 3) 'x)) + (test-equal + 'y + (deriv '(* x y) 'x)) + (test-equal + '(+ (* x y) + (* y + (+ x 3))) + (deriv '(* (* x y) (+ x 3)) 'x)) + (test-equal + '(* 3 (** x 2)) + (deriv '(** x 3) 'x)) + (test-equal + '() + (deriv '(** x -1) 'x)) + (test-end "deriv-stuff")) + +(deriv-stuff) diff --git a/solutions/exercise-2.59.scm b/solutions/exercise-2.59.scm @@ -0,0 +1,46 @@ + +(define (sets-stuff) + (define (element-of-set? x set) + (cond + ((null? set) #f) + ((equal? x (car set)) #t) + (else (element-of-set? x (cdr set))))) + + (define (adjoin-set x set) + (if (element-of-set? x set) + set + (cons x set))) + + (define (intersection-set set1 set2) + (cond + ((or (null? set1) + (null? set2)) + '()) + ((element-of-set? (car set1) + set2) + (adjoin-set (car set1) + (intersection-set (cdr set1) + set2))) + (else (intersection-set (cdr set1) + set2)))) + + (define (union-set set1 set2) + (cond + ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) + set2) + (union-set (cdr set1) + set2)) + (else (adjoin-set (car set1) + (union-set (cdr set1) + set2))))) + + (test-begin "2.59") + (test-equal + '(1 2 4 3 5) + (union-set '(1 3 2) '(4 3 5))) + (test-end "2.59")) + +(sets-stuff) + diff --git a/solutions/exercise-2.6.scm b/solutions/exercise-2.6.scm @@ -0,0 +1,85 @@ + +;; Exercise 2.6 + +(define (exercise-2.6) + (define zero + (lambda (f) + (lambda (x) + x))) + + (define (add-1 n) + (lambda (f) + (lambda (x) + (f ((n f) x))))) + + (add-1 zero) + + (lambda (f) + (lambda (x) + (f ((zero f) x)))) + + (lambda (f) + (lambda (x) + (f (((lambda (f) + (lambda (x) x)) f) x)))) + (lambda (f) + (lambda (x) + (f ((lambda (x) x) x)))) + + (define one + (lambda (f) + (lambda (x) + (f x)))) + + (add-1 one) + + (lambda (f) + (lambda (x) + (f ((one f) x)))) + + (lambda (f) + (lambda (x) + (f (((lambda (f) + (lambda (x) + (f x))) f) x)))) + + (lambda (f) + (lambda (x) + (f ((lambda (x) + (f x)) x)))) + + (lambda (f) + (lambda (x) + (f (f x)))) + + (define two + (lambda (f) + (lambda (x) + (f (f x))))) + + (define (church-+ a b) + (lambda (f) + (lambda (x) + ((b f) ((a f) x))))) + + (test-begin "2.6") + (test-equal 0 ((zero 1+) 0)) + (test-equal 1 (((add-1 zero) 1+) 0)) + (test-equal 1 ((one 1+) 0)) + (test-equal 2 (((add-1 (add-1 zero)) 1+) 0)) + (test-equal 2 (((add-1 one) 1+) 0)) + (test-equal 2 ((two 1+) 0)) + (test-equal 3 (((add-1 two) 1+) 0)) + + (do-ec (: elements (list (zip (list zero one two) + (iota 3)))) + (: a elements) + (: b elements) + (test-equal + (+ (cadr a) + (cadr b)) + (((church-+ (car a) + (car b)) 1+) 0))) + (test-end "2.6")) + +(exercise-2.6) diff --git a/solutions/exercise-2.60.scm b/solutions/exercise-2.60.scm @@ -0,0 +1,35 @@ +;; Exercise 2.60 XXX + +(define (exercise-2.60) + ;; I don't get it. Am I supposed to let these sets explode by just appending + ;; more and more stuff to them? + + (define (element-of-set? x set) + (cond + ((null? set) #f) + ((equal? x (car set)) #t) + (else (element-of-set? x (cdr set))))) + + (define (adjoin-set x set) + (cons x set)) + + (define (union-set set1 set2) + (append set1 set2)) + + (define (intersection-set set1 set2) + (cond + ((or (null? set1) + (null? set2)) '()) + ((equal? (car set1) (element-of-set? (car set1) + set2)) + (adjoin-set (car set1) + (intersection-set (cdr set1) + set2))) + (else (intersection-set (cdr set1) + set2)))) + + (test-begin "2.60") + (test-end "2.60")) + +(exercise-2.60) + diff --git a/solutions/exercise-2.61-2.62.scm b/solutions/exercise-2.61-2.62.scm @@ -0,0 +1,55 @@ +(define-library (solutions exercise-2.61-2.62) + (import (scheme base)) + + (begin + (define (element-of-set? x set) + (cond + ((= x (car set)) + #t) + ((> x (car set)) + #f) + (else (element-of-set? x (cdr set))))) + + (define (intersection-set set1 set2) + (cond + ((null? set1) '()) + ((null? set2) '()) + ((= (car set1) + (car set2)) + (cons (car set1) + (intersection-set (cdr set1) + (cdr set2)))) + ((< (car set1) + (car set2)) + (intersection-set (cdr set1) + set2)) + ((> (car set1) + (car set2)) + (intersection-set set1 + (cdr set2))))) + + (define (adjoin-set x set) + (cond + ((null? set) (cons x '())) + ((< x (car set)) (cons x set)) + ((= x (car set)) set) + (else (cons (car set) + (adjoin-set x (cdr set)))))) + + (define (union-set set1 set2) + (cond + ((null? set1) set2) + ((null? set2) set1) + ((< (car set1) + (car set2)) + (cons (car set1) + (union-set (cdr set1) + set2))) + ((> (car set1) + (car set2)) + (cons (car set2) + (union-set set1 + (cdr set2)))) + (else (cons (car set1) + (union-set (cdr set1) + (cdr set2)))))))) diff --git a/solutions/exercise-2.64.scm b/solutions/exercise-2.64.scm @@ -0,0 +1,96 @@ + +(define (ordered-list-set-stuff) + (define (element-of-set? x set) + (cond + ((= x (car set)) + #t) + ((> x (car set)) + #f) + (else (element-of-set? x (cdr set))))) + + (define (intersection-set set1 set2) + (cond + ((null? set1) '()) + ((null? set2) '()) + ((= (car set1) + (car set2)) + (cons (car set1) + (intersection-set (cdr set1) + (cdr set2)))) + ((< (car set1) + (car set2)) + (intersection-set (cdr set1) + set2)) + ((> (car set1) + (car set2)) + (intersection-set set1 + (cdr set2))))) + + (define (adjoin-set x set) + (cond + ((null? set) (cons x '())) + ((< x (car set)) (cons x set)) + ((= x (car set)) set) + (else (cons (car set) + (adjoin-set x (cdr set)))))) + + (define (union-set set1 set2) + (cond + ((null? set1) set2) + ((null? set2) set1) + ((< (car set1) + (car set2)) + (cons (car set1) + (union-set (cdr set1) + set2))) + ((> (car set1) + (car set2)) + (cons (car set2) + (union-set set1 + (cdr set2)))) + (else (cons (car set1) + (union-set (cdr set1) + (cdr set2)))))) + (test-begin "2.61") + (test-equal + '(1) + (adjoin-set 1 '())) + (test-equal + '(1) + (adjoin-set 1 '(1))) + (test-equal + '(1 2) + (adjoin-set 1 '(2))) + (test-equal + '(1 2) + (adjoin-set 2 '(1))) + (test-equal + '(1 2 3 4 5 6) + (adjoin-set 3 '(1 2 4 5 6))) + (test-end "2.61") + + (test-begin "2.62") + (test-equal + '() + (union-set '() '())) + (test-equal + '(1) + (union-set '(1) '())) + (test-equal + '(1) + (union-set '() '(1))) + (test-equal + '(1) + (union-set '(1) '(1))) + (test-equal + '(1 2) + (union-set '(1 2) '(1))) + (test-equal + '(1 2) + (union-set '(1) '(1 2))) + (test-equal + '(1 2 3) + (union-set '(2 3) '(1 2 3))) + (test-end "2.62")) + +(ordered-list-set-stuff) diff --git a/solutions/exercise-2.7.scm b/solutions/exercise-2.7.scm @@ -0,0 +1,68 @@ + +(define (exercise-2.7) + (define (make-interval lower higher) + (cons lower higher)) + (define (lower-bound interval) + (car interval)) + (define (upper-bound interval) + (cdr interval)) + + (define (add-interval x y) + (make-interval (+ (lower-bound x) + (lower-bound y)) + (+ (upper-bound x) + (upper-bound y)))) + + (define (mul-interval x y) + (let* ((bound-getters (list lower-bound higher-bound)) + (ps (list-ec (: x-bound bound-getters) + (: y-bound bound-getters) + (* (x-bound x) + (y-bound y))))) + (make-interval (min ps) + (max ps)))) + + (define (div-interval x y) + (mul-interval x (make-interval (/ 1.0 (upper-bound y)) + (/ 1.0 (lower-bound y))))) + + (define (sub-interval x y) + (make-interval (- (lower-bound x) + (lower-bound y)) + (- (upper-bound x) + (upper-bound y)))) + + (define (width-interval x) + (/ (- (upper-bound x) + (lower-bound x)) + 2)) + + (width-interval (add-interval x y)) + (width-interval (make-interval (+ (lower-bound x) + (lower-bound y)) + (+ (upper-bound x) + (upper-bound y)))) + (/ (- (upper-bound (make-interval (+ (lower-bound x) + (lower-bound y)) + (+ (upper-bound x) + (upper-bound y)))) + (lower-bound (make-interval (+ (lower-bound x) + (lower-bound y)) + (+ (upper-bound x) + (upper-bound y))))) + 2) + (/ (- (+ (upper-bound x) + (upper-bound y)) + (+ (lower-bound x) + (lower-bound y))) + 2) + + (add-interval (width-interval x) + (width-interval y)) + (add-interval (/ (- (upper-bound x) (lower-bound x)) 2) + (/ (- (upper-bound y) (lower-bound y)) 2)) + (make-interval ((/ (- (upper-bound x) (lower-bound x)) 2)) + (/ (- (upper-bound y) (lower-bound y)) 2)) + ) + +;;;(exercise-2.7) diff --git a/solutions/huffman-codes-stuff.scm b/solutions/huffman-codes-stuff.scm @@ -0,0 +1,137 @@ +(define-library (huffman-codes-stuff) + (import (scheme base)) + (import (scheme cxr)) + + (begin + (define (make-leaf symbol weight) + (list 'leaf symbol weight)) + + (define (leaf? object) + (eq? (car object) 'leaf)) + + (define (symbol-leaf x) (cadr x)) + (define (weight-leaf x) (caddr x)) + + (define (make-code-tree left right) + (list left + right + (append (symbols left) + (symbols right)) + (+ (weight left) + (weight right)))) + + (define (left-branch tree) (car tree)) + (define (right-branch tree) (cadr tree)) + + (define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) + + (define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + + (define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ([next-branch + (choose-branch + (car bits) + current-branch)]) + (if (leaf? next-branch) + (cons + (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) + next-branch))))) + (decode-1 bits tree)) + (define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "Bad bit: + CHOOSE-BRANCH" bit)))) + + (define (adjoin-set x set) + (cond + ((null? set) (list x)) + ((< (weight x) + (car set)) + (cons x set)) + (else (cons (car set) + (adjoin-set x + (cdr set)))))) + + (define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ([pair (car pairs)]) + (adjoin-set + (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + + ;; Exercise 2.67 + + (define sample-tree + (make-code-tree + (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree + (make-leaf 'D 1) + (make-leaf 'C 1))))) + + (define sample-message + '(0 1 1 0 0 1 0 1 0 1 1 1 0)) + + + ;; Exercise 2.68 + + (define (element-of-set? x elements) + (cond + ((null? elements) #f) + ((eq? x (car elements)) #t) + (else (element-of-set? x (cdr elements))))) + + (define (encode-symbol symbol tree) + (define (encode-symbol' bits current-tree) + (cond + ((leaf? current-tree) bits) + ((element-of-set? symbol + (symbols (left-branch current-tree))) + (encode-symbol' (cons 0 bits) + (left-branch current-tree))) + ((element-of-set? symbol + (symbols (right-branch current-tree))) + (encode-symbol' (cons 1 bits) + (right-branch current-tree))) + (else (error "Symbol is unknown: " symbol)))) + + (reverse (encode-symbol' '() tree))) + + (define (encode message tree) + (if (null? message) + '() + (append + (encode-symbol (car message) + tree) + (encode (cdr message) + tree)))) + + (define (successive-merge leaf-set) + (define (successive-merge' leaf-set) + (cond + ((null? leaf-set) '()) + ((null? (cdr leaf-set)) + (car leaf-set)) + (else (make-code-tree (car leaf-set) + (successive-merge' (cdr leaf-set)))))) + + (successive-merge' (reverse leaf-set))) + + (define (generate-huffman-tree pairs) + (successive-merge + (make-leaf-set pairs))))) diff --git a/solutions/tests/exercise-1.21-tests.scm b/solutions/tests/exercise-1.21-tests.scm @@ -0,0 +1,42 @@ +(import (srfi :26)) +(import (srfi :64)) +(import (solutions exercise-1.21)) + +(test-begin "prime") +(test-equal '(#t #f #t #f #t #f) (map (cut divides? 2 <>) '(2 3 4 5 6 7))) +(test-equal '(2 3 2 5 2 7) (map smallest-divisor '(2 3 4 5 6 7))) +(test-equal '(#t #t #f #t #f #t) (map prime? '(2 3 4 5 6 7))) +(test-end "prime") + +(test-begin "expmod") +(let ((cases (map (lambda (_) (list (+ 1 (random 100)) + (+ 1 (random 100)))) + (iota 20)))) + (test-equal + (map (lambda (x) (apply (lambda (a n) (= (expmod a + n + n) + a)) + x)) cases) + (map (lambda (x) (apply (lambda (a n) (= (remainder (expt a n) + n) + a)) + x)) + cases))) +(test-end "expmod") + +(test-begin "fast-prime") +(test-equal + (map (lambda (n) (fast-prime? n n)) (iota 100 2)) + (map (cut prime? <>) (iota 100 2))) +(test-end "fast-prime") + +;; XXX + +(test-begin "1.21") +(let ((cases '(199 1999 19999)) + (results '(199 1999 7))) + (test-equal + results + (map (lambda (case) (smallest-divisor case)) cases))) +(test-end "1.21") diff --git a/solutions/tests/exercise-2.33-tests.scm b/solutions/tests/exercise-2.33-tests.scm @@ -0,0 +1,18 @@ +(import (srfi :64)) +(import (utils)) +(import (solutions exercise-2.33)) + +(test-begin "2.33") +(test-equal + '(1 4 9 16 25 36) + (map-2.33 (lambda (x) (* x x)) + (enumerate-interval 1 6))) +(test-equal + '(1 2 3 4 5 6) + (append-2.33 '(1 2 3) + '(4 5 6))) +(test-equal + 10 + (length-2.33 '(1 2 3 4 5 6 7 8 9 10))) +(test-end "2.33") + diff --git a/solutions/tests/exercise-2.34-tests.scm b/solutions/tests/exercise-2.34-tests.scm @@ -0,0 +1,15 @@ +(import (srfi :64)) +(import (solutions exercise-2.34)) + +(test-begin "2.34") +(test-equal + (let ([x 2]) + (+ (* 1) ; a_0 + (* 3 x) ; a_1 + (* 0 x x) ; a_2 + (* 5 x x x) ; a_3 + (* 0 x x x x) ; a_4 + (* 1 x x x x x) ; a_5 + )) + (horner-eval 2 '(1 3 0 5 0 1))) +(test-end "2.34") diff --git a/solutions/tests/exercise-2.35-tests.scm b/solutions/tests/exercise-2.35-tests.scm @@ -0,0 +1,13 @@ +(import (srfi :64)) +(import (solutions exercise-2.35)) + +(define t '((1 2 3) + (3 (4 5 6) + (2 3)))) + +(test-begin "2.35") +(test-equal + (count-leaves-2.2.2 t) + (count-leaves t)) +(test-end "2.35") + diff --git a/solutions/tests/exercise-2.36-tests.scm b/solutions/tests/exercise-2.36-tests.scm @@ -0,0 +1,11 @@ +(import (srfi :64)) +(import (solutions exercise-2.36)) + +(test-begin "2.36") +(test-equal + '(22 26 30) + (accumulate-n + 0 '((1 2 3) + (4 5 6) + (7 8 9) + (10 11 12)))) +(test-end "2.36") diff --git a/solutions/tests/exercise-2.40-tests.scm b/solutions/tests/exercise-2.40-tests.scm @@ -0,0 +1,14 @@ +(import (srfi :64)) +(import (solutions exercise-2.40)) + + +(test-begin "2.40") +(test-equal + '((2 1) + (3 1) (3 2) + (4 1) (4 2) (4 3)) + (unique-pairs 4)) +(test-equal + (prime-sum-pairs 20) + (my-prime-sum-pairs 20)) +(test-end "2.40") diff --git a/solutions/tests/exercise-2.41-tests.scm b/solutions/tests/exercise-2.41-tests.scm @@ -0,0 +1,20 @@ +(import (srfi :64)) +(import (solutions exercise-2.41)) + +(define ratsui + '((3 2 1) + (4 2 1) + (4 3 1) + (4 3 2) + (5 2 1) + (5 3 1) + (5 3 2) + (5 4 1) + (5 4 2) + (5 4 3))) + +(test-begin "2.41") +(test-equal + ratsui + (unique-triples 5)) +(test-end "2.41") diff --git a/solutions/tests/exercise-2.42-tests.scm b/solutions/tests/exercise-2.42-tests.scm @@ -0,0 +1,19 @@ +(import (srfi :64)) +(import (sicp utils)) +(import (solutions exercise-2.42)) + +(test-begin "2.42") +(test-equal + #f + (safe? 2 + (list (make-position 1 2) + (make-position 2 1)))) +(test-equal + #t + (safe? 2 + (list (make-position 4 2) + (make-position 2 1)))) +(test-equal + '() + (queens 8)) +(test-end "2.42") diff --git a/solutions/tests/exercise-2.61-tests.scm b/solutions/tests/exercise-2.61-tests.scm @@ -0,0 +1,17 @@ +(test-begin "2.61") +(test-equal + '(1) + (adjoin-set 1 '())) +(test-equal + '(1) + (adjoin-set 1 '(1))) +(test-equal + '(1 2) + (adjoin-set 1 '(2))) +(test-equal + '(1 2) + (adjoin-set 2 '(1))) +(test-equal + '(1 2 3 4 5 6) + (adjoin-set 3 '(1 2 4 5 6))) +(test-end "2.61") diff --git a/solutions/tests/exercise-2.62-tests.scm b/solutions/tests/exercise-2.62-tests.scm @@ -0,0 +1,23 @@ +(test-begin "2.62") +(test-equal + '() + (union-set '() '())) +(test-equal + '(1) + (union-set '(1) '())) +(test-equal + '(1) + (union-set '() '(1))) +(test-equal + '(1) + (union-set '(1) '(1))) +(test-equal + '(1 2) + (union-set '(1 2) '(1))) +(test-equal + '(1 2) + (union-set '(1) '(1 2))) +(test-equal + '(1 2 3) + (union-set '(2 3) '(1 2 3))) +(test-end "2.62") diff --git a/solutions/tests/exercise-2.67-tests.scm b/solutions/tests/exercise-2.67-tests.scm @@ -0,0 +1,5 @@ +(test-begin "2.67") +(test-equal + '(A D A B B C A) ;; Is this it? Did I fuck any shit up? Manuel de Coding, the Portuguese decoder, agrees with this. + (decode sample-message sample-tree)) +(test-end "2.67") diff --git a/solutions/tests/exercise-2.68-tests.scm b/solutions/tests/exercise-2.68-tests.scm @@ -0,0 +1,11 @@ +(import (srfi :64)) + +(test-begin "2.68") +(test-equal + sample-message + (encode + (decode sample-message + sample-tree) + sample-tree)) +(test-end "2.68") + diff --git a/solutions/tests/exercise-2.69-tests.scm b/solutions/tests/exercise-2.69-tests.scm @@ -0,0 +1,11 @@ +(import (srfi :64)) + +(test-begin "2.69") +(test-equal + (make-leaf 'A 1) + (generate-huffman-tree '((A 1)))) +(test-equal + (make-code-tree (make-leaf 'A 1) + (make-leaf 'B 1)) + (generate-huffman-tree '((A 1) (B 1)))) +(test-end "2.69") diff --git a/solutions/tree-stuff.scm b/solutions/tree-stuff.scm @@ -0,0 +1,515 @@ +(define-library (trees-stuff) + (import (scheme base)) + + (begin + (define (entry tree) (car tree)) + (define (left-branch tree) (cadr tree)) + (define (right-branch tree) (caddr tree)) + (define (make-tree entry left right) (list entry left right)) + + (define (element-of-set? x set) + (cond + ((null? set) #f) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))) + (else #t))) + + (define (tree->list-1 tree) + (if (null? tree) + '() + (append + (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) + + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list + (right-branch tree) + result-list))))) + (define (tree->list-2 tree) + (copy-to-list tree '())) + + (define tree-1 + (make-tree 7 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (make-tree 9 + '() + (make-tree 11 '() '())))) + + (define tree-2 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 7 + (make-tree 5 '() '()) + (make-tree 9 + '() + (make-tree 11 '() '()))))) + + (define tree-3 + (make-tree 5 + (make-tree 3 + (make-tree 1 '() '()) + '()) + (make-tree 9 + (make-tree 7 '() '()) + (make-tree 11 '() '())))) + + ;; Exercise 2.63 XXX + + (test-begin "2.63") + + ;; These tests show that the algorithms are the same for the three input trees. Sadly, I wouldn't know how to prove mathematical equivalency. + (test-equal + (tree->list-1 tree-1) + (tree->list-2 tree-1)) + (test-equal + (tree->list-1 tree-2) + (tree->list-2 tree-2)) + (test-equal + (tree->list-1 tree-3) + (tree->list-2 tree-3)) + + ;; tree->list-1 uses append for each pair of branches, so for level 1 we have + ;; 1 append, for level 2 we have 2 appends, level 3 has 4 appends. + ;; For an input of length n, an append has n steps, so for level 1 we append + ;; one half of the tree to the other. + ;; Therefore, for input of size n to tree->list-1: + ;; * Level 1 append would have the input of size n/2. + ;; * A level 2 append would have input of size n / 4. + ;; * A level 3 append, n / 8. + ;; * A level 4 append, n / 16. + ;; * A level n append, n / 2^n. + ;; XXX + + (test-equal + '(1 3 5 7 9 11) + (tree->list-1 tree-1)) + (test-equal + '(1 3 5 7 9 11) + (tree->list-1 + (make-tree 7 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (make-tree 9 + '() + (make-tree 11 '() '()))))) + (test-equal + '(1 3 5 7 9 11) + (append + (tree->list-1 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons + 7 + (tree->list-1 + (make-tree 9 + '() + (make-tree 11 '() '()))))))) + (test-equal + '(1 3 5 7 9 11) + (append + (tree->list-1 + (append + (make-tree 1 '() '()) + (cons + 3 + (tree->list-1 + (make-tree 5 '() '())))) + (cons + 7 + (tree->list-1 + (make-tree 9 + '() + (make-tree 11 '() '()))))))) + (test-equal + '(1 3 5 7 9 11) + (append + (tree->list-1 + (append + (make-tree 1 '() '()) + (cons + 3 + (tree->list-1 + (append + '() + (cons + 5 + (tree->list-1 '())))))) + (cons + 7 + (tree->list-1 + (make-tree 9 + '() + (make-tree 11 '() '()))))))) + (test-equal + '(1 3 5 7 9 11) + (append + (tree->list-1 + (append + (make-tree 1 '() '()) + (cons + 3 + (tree->list-1 + (append + '() + (cons + 5 + '()))))) + (cons + 7 + (tree->list-1 + (make-tree 9 + '() + (make-tree 11 '() '()))))))) + (test-equal ;; 1 + '(1 3 5 7 9 11) + (tree->list-2 + (make-tree 7 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (make-tree 9 + '() + (make-tree 11 '() '()))))) + (test-equal ;; 2 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 7 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (make-tree 9 + '() + (make-tree 11 '() '()))) + '())) + (test-equal ;; 3 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 7 + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (make-tree 9 + '() + (make-tree 11 '() '()))) + '())) + (test-equal ;; 4 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (copy-to-list + (make-tree 9 + '() + (make-tree 11 '() '())) + '())))) + (test-equal ;; 5 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (copy-to-list + '() + (cons 9 + (copy-to-list + (make-tree 11 '() '()) + '())))))) + (test-equal ;; 6 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (copy-to-list + '() + (cons 9 + (copy-to-list + '() + (cons 11 + (copy-to-list '() '())))))))) + (test-equal ;; 7 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (copy-to-list + '() + (cons 9 + (copy-to-list + '() + (cons 11 + (copy-to-list '() '())))))))) + (test-equal ;; 8 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (copy-to-list + '() + (cons 9 + (copy-to-list + '() + (cons 11 + '()))))))) + (test-equal ;; 9 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (copy-to-list + '() + (cons 9 + (cons 11 + '())))))) + (test-equal ;; 10 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 3 + (make-tree 1 '() '()) + (make-tree 5 '() '())) + (cons 7 + (cons 9 + (cons 11 + '()))))) + (test-equal ;; 11 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 1 '() '()) + (cons 3 + (copy-to-list + (make-tree 5 '() '()) + (cons 7 + (cons 9 + (cons 11 + '()))))))) + (test-equal ;; 12 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 1 '() '()) + (cons 3 + (copy-to-list + '() + (cons 5 + (copy-to-list + '() + (cons 7 + (cons 9 + (cons 11 + '()))))))))) + (test-equal ;; 13 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 1 '() '()) + (cons 3 + (copy-to-list + '() + (cons 5 + (cons 7 + (cons 9 + (cons 11 + '())))))))) + (test-equal ;; 14 + '(1 3 5 7 9 11) + (copy-to-list + (make-tree 1 '() '()) + (cons 3 + (cons 5 + (cons 7 + (cons 9 + (cons 11 + '()))))))) + (test-equal ;; 15 + '(1 3 5 7 9 11) + (copy-to-list + '() + (cons 1 + (copy-to-list + '() + (cons 3 + (cons 5 + (cons 7 + (cons 9 + (cons 11 + '()))))))))) + (test-equal ;; 16 + '(1 3 5 7 9 11) + (copy-to-list + '() + (cons 1 + (cons 3 + (cons 5 + (cons 7 + (cons 9 + (cons 11 + '())))))))) + (test-equal ;; 17 + '(1 3 5 7 9 11) + (cons 1 + (cons 3 + (cons 5 + (cons 7 + (cons 9 + (cons 11 + '()))))))) + (test-end "2.63") + + + ;; Exercise 2.64 XXX + + (define (list->tree elements) + (car (partial-tree + elements + (length elements)))) + + (define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let ([left-size + (quotient (- n 1) 2)]) + (let ([left-result + (partial-tree + elts left-size)]) + (let ([left-tree + (car left-result)] + [non-left-elts + (cdr left-result)] + [right-size + (- n (+ left-size 1))]) + (let ([this-entry + (car non-left-elts)] + [right-result + (partial-tree + (cdr non-left-elts) + right-size)]) + (let ([right-tree + (car right-result)] + [remaining-elts + (cdr right-result)]) + (cons (make-tree this-entry + left-tree + right-tree) + remaining-elts)))))))) + + (test-begin "2.64") + (test-equal + (make-tree 1 '() '()) + (list->tree '(1)))) + (test-equal + (make-tree 1 + '() + (make-tree 2 '() '())) + (list->tree '(1 2))) + (test-equal + (make-tree 2 + (make-tree 1 '() '()) + (make-tree 3 '() '())) + (list->tree '(1 2 3))) + (test-equal + (make-tree 2 + (make-tree 1 '() '()) + (make-tree 3 + '() + (make-tree 4 '() '()))) + (list->tree '(1 2 3 4))) + (test-equal + (make-tree 3 + (make-tree 1 + '() + (make-tree 2 '() '())) + (make-tree 4 + '() + (make-tree 5 '() '()))) + (list->tree '(1 2 3 4 5))) + (test-equal + (make-tree 3 + (make-tree 1 + '() + (make-tree 2 '() '())) + (make-tree 5 + (make-tree 4 '() '()) + (make-tree 6 '() '()))) + (list->tree '(1 2 3 4 5 6))) + (test-equal + (make-tree 4 + (make-tree 2 + (make-tree 1 '() '()) + (make-tree 3 '() '())) + (make-tree 6 + (make-tree 5 '() '()) + (make-tree 7 '() '()))) + (list->tree '(1 2 3 4 5 6 7))) + (test-equal + (make-tree 4 + (make-tree 2 + (make-tree 1 '() '()) + (make-tree 3 '() '())) + (make-tree 6 + (make-tree 5 '() '()) + (make-tree 7 '() '()))) + (list->tree '(1 2 3 4 5 6 7 8))) + (test-end "2.64") + + ;; Exercise 2.65 XXX + + ;; Exercise 2.66 + + (define (make-entry key value) + (cons key value)) + + (define (key entry) + (car entry)) + + (define (value entry) + (cdr entry)) + + (define (lookup given-key set-of-records) + (cond + ((null? set-of-records) #f) + ((< given-key (key (entry set-of-records))) + (lookup given-key (left-branch set-of-records))) + ((> given-key (key (entry set-of-records))) + (lookup given-key (right-branch set-of-records))) + (else (entry set-of-records)))) + + (test-begin "2.66") + (test-equal + #f + (lookup 4 '())) + (test-equal + (make-entry 4 "moo") + (lookup 4 + (make-tree (make-entry 4 "moo") '() '()))) + (test-equal + (make-entry 4 "moo") + (lookup 4 + (make-tree (make-entry 3 "foo") + '() + (make-tree (make-entry 4 "moo") '() '())))) + (test-equal + (make-entry 4 "moo") + (lookup 4 + (make-tree (make-entry 5 "foo") + (make-tree (make-entry 4 "moo") '() '()) + '()))) + (test-end "2.66"))