Commit Diff
Diff:
/dev/null
665c255dd18a42b23f14a5dad17cc3139d573d4a
Commit:
665c255dd18a42b23f14a5dad17cc3139d573d4a (main)
Tree:
19c468b89be8f5fc35b9b58a9b5571bcfc1513a9
Author:
jrmu <jrmu@ircnow.org>
Committer:
jrmu <jrmu@ircnow.org>
Date:
Fri Aug 4 04:57:27 2023 UTC
Message:
Import sources
blob - /dev/null
blob + c36ac117f8404a5a2e661117bda79ee3a88dd847 (mode 644)
--- /dev/null
+++ #ex1-17.scm#
@@ -0,0 +1,34 @@
+(define (* a b)
+ (if (= b 0)
+ 0
+ (+ a (* a (- b 1)))))
+
+;; a * b = {
+;; 0 if b = 0,
+;; 2 * a * (b/2) if b is even,
+;; a + a * (b-1) if b is odd
+;; }
+
+(define (fast-mult a b)
+ (cond ((= b 0) 0)
+ ((even? b) (double (* a (halve b))))
+ (else (+ a (* a (- b 1))))))
+(define (double x)
+ (+ x x))
+(define (halve x)
+ (/ x 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-mult 0 0) 0)
+(test-case (fast-mult 0 1) 0)
+(test-case (fast-mult 0 8) 0)
+(test-case (fast-mult 5 0) 0)
+(test-case (fast-mult 2 1) 2)
+(test-case (fast-mult 3 3) 9)
+(test-case (fast-mult 5 4) 20)
+(test-case (fast-mult 12 13) 156)
+(test-case (fast-mult 12 24) 288)
+
blob - /dev/null
blob + 9fcd7a9b932ef88eeb5a3e96c1e9708e08588808 (mode 644)
--- /dev/null
+++ #ex1-17.sicp#
@@ -0,0 +1 @@
+(define (* a b)
blob - /dev/null
blob + 35a7f803e0d3197d31240c0d9d881495b450ee2f (mode 644)
--- /dev/null
+++ #ex1-29.scm#
@@ -0,0 +1,42 @@
+(define (sum term a next b)
+ (if (> a b)
+ 0
+ (+ (term a)
+ (sum term (next a) next b))))
+
+;; (define (simpsons-rule f a b n)
+;; (let ((h (/ (- b a) n)))
+;; (define (running-sum k)
+;; (let ((akh (+ a (* k h))))
+;; (if (= k n)
+;; (f akh)
+;; (+ (cond ((= k 0) (f akh))
+;; ((even? k) (* 2 (f akh)))
+;; ((odd? k) (* 4 (f akh))))
+;; (running-sum (+ k 1))))))
+;; (* (/ h 3)
+;; (running-sum 0))))
+
+(define (simpsons-rule f a b n)
+ (let ((h (/ (- b a) n)))
+ (define (simpsons-term k)
+ (let ((akh (+ a (* k h))))
+ (* (f akh)
+ (cond ((or (= k 0) (= k n)) 1)
+ ((odd? k) 4)
+ ((even? k) 2)))))
+ (* (/ h 3)
+ (sum simpsons-term 0 1+ n))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (cube x) (* x x x))
+
+(test-case (simpsons-rule cube 0.0 1.0 5) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 10) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 100) 0.25)
+
blob - /dev/null
blob + e74e9585493f60492d1f046003c349f4f7dd6531 (mode 644)
--- /dev/null
+++ #ex1-46.lisp#
@@ -0,0 +1,25 @@
+(defun iterative-improve (good-enough? improve)
+ (lambda (first-guess)
+ (labels ((improve-iter (guess)
+ (let ((improved-guess (funcall improve guess)))
+ (if (funcall good-enough? guess improved-guess)
+ improved-guess
+ (improve-iter improved-guess)))))
+ (improve-iter first-guess))))
+(defun improved-sqrt (num)
+ (funcall (iterative-improve
+ (lambda (x y)
+ (let ((ratio (/ x y)))
+ (and (< ratio 1.001) (> ratio 0.999))))
+ (lambda (guess)
+ (average guess (/ num guess))))
+ 1.0))
+(defvar *tolerance* 0.00001)
+(defun improved-fixed-point (f first-guess)
+ (funcall (iterative-improve
+ (lambda (x y)
+ (< (abs (- x y)) *tolerance*))
+ (lambda (guess)
+ (funcall f guess)))
+ first-guess))
+
blob - /dev/null
blob + 502e2391c7380ce9e44e7cca4ffcddefc1aa06e1 (mode 644)
--- /dev/null
+++ #ex2-1.scm#
@@ -0,0 +1,102 @@
+(define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+(define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+(define (equal-rat? x y)
+ (= (* (numer x) (denom y))
+ (* (numer y) (denom x))))
+
+(define (print-rat x)
+ (newline)
+ (display (numer x))
+ (display "/")
+ (display (denom x)))
+
+
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+;; (define (make-rat n d)
+;; (let ((g (gcd n d)))
+;; (cons (/ n g) (/ d g))))
+(define (numer x) (car x))
+(define (denom x) (cdr x))
+
+;; (define one-half (make-rat 1 2))
+;; (define one-third (make-rat 1 3))
+
+;; (print-rat one-half)
+;; (print-rat (make-rat 1 2))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+;; (print-rat (add-rat one-half one-third))
+;; (print-rat (make-rat 5 6))
+;; (print-rat (mul-rat one-half one-third))
+;; (print-rat (make-rat 1 6))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+
+;; Exercise 2.1. Define a better version of make-rat that handles both positive and negative arguments. Make-rat should normalize the sign so that if the rational number is positive, both the numerator and denominator are positive, and if the rational number is negative, only the numerator is negative.
+
+(define (make-rat n d)
+ (if (= d 0)
+ (error "Division by zero")
+ (let ((g-mag (abs (gcd n d)))
+ (n-mag (abs n))
+ (d-mag (abs d)))
+ (if (< (* n d) 0)
+ (cons (- (/ n-mag g-mag)) (/ d-mag g-mag))
+ (cons (/ n-mag g-mag) (/ d-mag g-mag))))))
+
+;; (define zz-0-0 (make-rat 0 0))
+(define zp-0-3 (make-rat 0 3))
+(define np-1-2 (make-rat -1 2))
+(define np-1-4 (make-rat -1 4))
+(define nn-3-4 (make-rat -3 -4))
+(define pp-4-3 (make-rat 4 3))
+(define pn-5-2 (make-rat 5 -2))
+(define pn-10-2 (make-rat 10 -2))
+(define nn-9-3 (make-rat -9 -3))
+
+;; (print-rat zz-0-0)
+;; (error "Division by zero")
+(print-rat zp-0-3)
+(display "=0/1")
+(print-rat np-1-2)
+(display "=-1/2")
+(print-rat np-1-4)
+(display "=-1/4")
+(print-rat nn-3-4)
+(display "=3/4")
+(print-rat pp-4-3)
+(display "=4/3")
+(print-rat pn-5-2)
+(display "=-5/2")
+(print-rat pn-10-2)
+(display "=-5/1")
+(print-rat nn-9-3)
+(display "=3/1")
+(print-rat (sub-rat nn-9-3 pp-4-3))
+(display "=5/3")
+(print-rat (mul-rat np-1-2 np-1-2))
+(display "=1/4")
+(print-rat (div-rat pn-5-2 pn-10-2))
+(display "=1/2")
+(print-rat (sub-rat np-1-4 zp-0-3))
+(display "=-1/4")
+;; (print-rat (div-rat nn-3-4 zp-0-3))
+;; (error "Division by zero")
+(print-rat (div-rat np-1-4 pn-5-2))
+(display "=1/10")
+
blob - /dev/null
blob + c4ac9e99b701116a764568385c592b4a21c51063 (mode 644)
--- /dev/null
+++ #ex2-14b.scm#
@@ -0,0 +1,23 @@
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval r2)))))
+
+(define a (make-center-percent 100 5))
+(define b (make-center-percent 200 2))
+(define aa (div-interval a a))
+(define ab (div-interval a b))
+(center aa)
+(center ab)
+(percent aa)
+(percent ab)
+(define apb1 (par1 a b))
+(define apb2 (par2 a b))
+apb1
+apb2
+(define apa1 (par1 a a))
+(define apa2 (par2 a a))
blob - /dev/null
blob + 90e418df64de63eb901dfd47d629433344b97410 (mode 644)
--- /dev/null
+++ #ex2-17.sc#
@@ -0,0 +1,3 @@
+(cons 1
+ (cons 2
+ (cons 3
\ No newline at end of file
blob - /dev/null
blob + 2de1ccb6914ef9a38ee91bdd2e89e67c32f2a0f8 (mode 644)
--- /dev/null
+++ #ex2-36.scm#
@@ -0,0 +1,26 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+;; Exercise 2.36. The procedure accumulate-n is similar to accumulate except that it takes as its third argument a sequence of sequences, which are all assumed to have the same number of elements. It applies the designated accumulation procedure to combine all the first elements of the sequences, all the second elements of the sequences, and so on, and returns a sequence of the results. For instance, if s is a sequence containing four sequences, ((1 2 3) (4 5 6) (7 8 9) (10 11 12)), then the value of (accumulate-n + 0 s) should be the sequence (22 26 30). Fill in the missing expressions in the following definition of accumulate-n:
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+(test-case (accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12))) '(22 26 30))
+(test-case (accumulate-n + 0 '(() () ())) '())
+;; (test-case (accumulate-n + 0 '()) (error "Trying to car empty list"))
+
blob - /dev/null
blob + d45237872ca6fbd8a7cf9a56829195933b583f80 (mode 644)
--- /dev/null
+++ #ex2-56-sol.scm#
@@ -0,0 +1,44 @@
+(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))))
+ (else
+ (error "unknown expression type -- DERIV" exp))))
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+(define (exponentiation? x)
+ (and (pair? x) (eq? (car x) '**)))
+(define (base e) (cadr e))
+(define (exponent e) (caddr e))
+(define (make-exponentiation base exponent)
+ (cond ((=number? exponent 0) 1)
+ ((=number? exponent 1) base)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ (else (list '** base exponent))))
+((exponentiation? exp)
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation
+ (base exp)
+ (make-sum (exponent exp) -1)))
+ (deriv (base exp) var)))
blob - /dev/null
blob + 5d5d106b0d0fb8e1e035e024b5a3168b5df0189c (mode 644)
--- /dev/null
+++ #ex2-78-sol.scm#
@@ -0,0 +1,12 @@
+(define (attach-tag type-tag contents)
+ (if (= type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ (else (error "Bad tagged datum -- TYPE-TAG" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ (else (error "Bad tagged datum -- CONTENTS" datum))))
\ No newline at end of file
blob - /dev/null
blob + e6938f0ed468c274c19fd1c6e74733b354edbfdc (mode 644)
--- /dev/null
+++ #ex2-81-sol.scm#
@@ -0,0 +1,37 @@
+(define (attach-tag type-tag contents)
+ (if (number? contents)
+ contents
+ (cons type-tag contents)))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+
blob - /dev/null
blob + 34a9e4e330a44bcefaceab42cae41dc6c8dbcf3c (mode 644)
--- /dev/null
+++ #ex3-25-4.scm#
@@ -0,0 +1,4 @@
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (locate key otherkeys table)
+ (let ((value (assoc key (cdr table))))
\ No newline at end of file
blob - /dev/null
blob + fe6d780fa2491ae56448023a25886dbeb0b4eca7 (mode 644)
--- /dev/null
+++ ex1-1.scm
@@ -0,0 +1,55 @@
+10
+10
+(+ 5 3 4)
+12
+(- 9 1)
+8
+(/ 6 2)
+3
+(+ (* 2 4) (- 4 6))
+(+ 8 -2)
+6
+(define a 3)
+a
+(define b (+ a 1))
+b
+(+ a b (* a b))
+(+ 3 4 (* 3 4))
+(+ 3 4 12)
+19
+(= a b)
+#f
+(if (and (> b a) (< b (* a b)))
+ b
+ a)
+(if (and (> 4 3) (< 4 (* 3 4)))
+ 4
+ 3)
+(if (and #t #t)
+ 4
+ 3)
+4
+
+(cond ((= a 4) 6)
+ ((= b 4) (+ 6 7 a))
+ (else 25))
+(cond (#f 6)
+ (#t (+ 6 7 3))
+ (else 25))
+16
+(+ 2 (if (> b a) b a))
+(+ 2 (if #t 4 3))
+(+ 2 4)
+6
+(* (cond ((> a b) a)
+ ((< a b) b)
+ (else -1))
+ (+ a 1))
+(* (cond (#f 3)
+ (#t 4)
+ (else -1))
+ (+ 3 1))
+(* 4
+ 4)
+16
+
blob - /dev/null
blob + 900a330458f925f33ac886b5d9099de6145acdb6 (mode 644)
--- /dev/null
+++ ex1-1.scm~
@@ -0,0 +1,2 @@
+10
+(+ 5 3 4)
\ No newline at end of file
blob - /dev/null
blob + 0c8ec49ca773a0b7b9b2618b649f266fddeffc3a (mode 644)
--- /dev/null
+++ ex1-10.scm
@@ -0,0 +1,76 @@
+(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)
+(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 4))))))))
+(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
+;; 2^10
+
+(A 2 4)
+(A 1 (A 2 3))
+(A 1 (A 1 (A 2 2)))
+(A 1 (A 1 (A 1 (A 2 1))))
+(A 1 (A 1 (A 1 2)))
+(A 1 (A 1 (A 0 (A 1 1))))
+(A 1 (A 1 (A 0 2)))
+(A 1 (A 1 4))
+(A 1 (A 0 (A 1 3)))
+(A 1 (A 0 (A 0 (A 1 2))))
+...
+(A 1 (A 0 (A 0 (A 0 2))))
+(A 1 (A 0 (A 0 4)))
+(A 1 (A 0 8))
+(A 1 16)
+;; 65536
+;; 2^(2^(2^2)) = 2^16
+
+(A 3 3)
+(A 2 (A 3 2))
+(A 2 (A 2 (A 3 1)))
+(A 2 (A 2 2))
+(A 2 4)
+65536
+;; same as above = 2^16
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define (f n) (A 0 n))
+(define (f n) (* 2 n))
+
+(define (g n) (A 1 n))
+(define (g n)
+ (expt 2 n))
+
+(define (h n) (A 2 n))
+(define (h n)
+ (cond ((= n 0) 0)
+ ((= n 1) 2)
+ (else (expt 2 (h (- n 1))))))
+
+;; 2^(2^(2^(...))) 'n' number of times
+
+
+(define (k n) (* 5 n n))
\ No newline at end of file
blob - /dev/null
blob + 87c2ee8bdda49bed066a47d222423d3084680d3a (mode 644)
--- /dev/null
+++ ex1-10.scm~
@@ -0,0 +1,6 @@
+(define (A x y)
+ (cond ((= y 0) 0)
+ ((= x 0) (* 2 y))
+ ((= y 1) 2)
+ (else (A (- x 1)
+ (A x (- y 1))))))
\ No newline at end of file
blob - /dev/null
blob + ea206cf94126c5c1efacd0d1e682afbce8895540 (mode 644)
--- /dev/null
+++ ex1-10b.scm
@@ -0,0 +1,57 @@
+(define (fib n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (else (+ (fib (- n 1))
+ (fib (- n 2))))))
+
+(define (fib n)
+ (fib-iter 1 0 n))
+(define (fib-iter a b count)
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))
+
+(define (count-change cents coins)
+ (cond ((= coins 0) 0)
+ ((< cents 0) 0)
+ ((= cents 0) 1)
+ (else (+ (count-change cents (- coins 1))
+ (count-change (- cents (largest-coin-value coins)) coins)))))
+
+(define (largest-coin-value coins)
+ (cond ((= coins 5) 50)
+ ((= coins 4) 25)
+ ((= coins 3) 10)
+ ((= coins 2) 5)
+ ((= coins 1) 1)))
+
+(count-change 0 0)
+;; 0
+(count-change 1 0)
+;; 0
+(count-change 0 1)
+;; 1
+(count-change 1 1)
+;; 1
+(count-change 2 1)
+;; 1
+(count-change 2 2)
+;; 1
+(count-change 100 5)
+
+(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)))
blob - /dev/null
blob + 29c7bab778d1b78866735cd005afd2376c6b000b (mode 644)
--- /dev/null
+++ ex1-11.lisp
@@ -0,0 +1,16 @@
+(defun Fr (n)
+ (cond ((< n 3) n)
+ (t (+ Fr (- n 1))
+ (* 2 (Fr (- n 2)))
+ (* 3 (Fr (- n 3))))))
+(defun F-iter (n)
+ (if (< n 3)
+ n
+ (F-iter-aux 2 1 0 n)))
+(defun F-iter-aux (a b c count)
+ (if (= count 2)
+ a
+ (F-iter-aux (+ a (* 2 b) (* 3 c))
+ a
+ b
+ (- count 1))))
\ No newline at end of file
blob - /dev/null
blob + 97a6c6e72253d28ff7aeb47ef0b54cd1e6cc3f5b (mode 644)
--- /dev/null
+++ ex1-11.lisp~
@@ -0,0 +1,5 @@
+(defun Fr (n)
+ (cond ((< n 3) n)
+ (t (+ Fr (- n 1))
+ (* 2 (Fr (- n 2)))
+ (* 3 (Fr (- n 3))))))
\ No newline at end of file
blob - /dev/null
blob + 552c435d8805e6894839f9eaf4f27e1819de228b (mode 644)
--- /dev/null
+++ ex1-11.scm
@@ -0,0 +1,36 @@
+(define (f n)
+ (if (< n 3)
+ n
+ (+ (f (- n 1))
+ (* 2 (f (- n 2)))
+ (* 3 (f (- n 3))))))
+
+(load-option 'format)
+;; (load-option 'unquote)
+;; (define (test-case t1 t2)
+;; (format #t "~A: ~A Expected: ~A" `t1, t1, t2))
+(define (test-case actual expected)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (f 0) 0)
+(test-case (f 1) 1)
+(test-case (f 2) 2)
+(test-case (f 3) 4)
+(test-case (f 4) 11)
+
+(define (f2 n)
+ (f-iter 2 1 0 n))
+
+(define (f-iter n1 n2 n3 i)
+ (if (= i 0)
+ n3
+ (f-iter (+ n1 (* 2 n2) (* 3 n3))
+ n1
+ n2
+ (- i 1))))
+
+
+(test-case (f2 0) 0)
+(test-case (f2 1) 1)
+(test-case (f2 2) 2)
+(test-case (f2 3) 4)
+(test-case (f2 4) 11)
blob - /dev/null
blob + ea206cf94126c5c1efacd0d1e682afbce8895540 (mode 644)
--- /dev/null
+++ ex1-11.scm~
@@ -0,0 +1,57 @@
+(define (fib n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (else (+ (fib (- n 1))
+ (fib (- n 2))))))
+
+(define (fib n)
+ (fib-iter 1 0 n))
+(define (fib-iter a b count)
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))
+
+(define (count-change cents coins)
+ (cond ((= coins 0) 0)
+ ((< cents 0) 0)
+ ((= cents 0) 1)
+ (else (+ (count-change cents (- coins 1))
+ (count-change (- cents (largest-coin-value coins)) coins)))))
+
+(define (largest-coin-value coins)
+ (cond ((= coins 5) 50)
+ ((= coins 4) 25)
+ ((= coins 3) 10)
+ ((= coins 2) 5)
+ ((= coins 1) 1)))
+
+(count-change 0 0)
+;; 0
+(count-change 1 0)
+;; 0
+(count-change 0 1)
+;; 1
+(count-change 1 1)
+;; 1
+(count-change 2 1)
+;; 1
+(count-change 2 2)
+;; 1
+(count-change 100 5)
+
+(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)))
blob - /dev/null
blob + 9746c48fa09164960e80402e0c3d2ec9303e5d5d (mode 644)
--- /dev/null
+++ ex1-12.lisp
@@ -0,0 +1,5 @@
+(defun pascal (row col)
+ (cond ((= col 1) 1)
+ ((= row col) 1)
+ (t (+ (pascal (1- row) col)
+ (pascal (1- row) (1- col))))))
\ No newline at end of file
blob - /dev/null
blob + 2cc1e7171d93964087e6b5e90bdc838804de43e9 (mode 644)
--- /dev/null
+++ ex1-12.scm
@@ -0,0 +1,24 @@
+(define (pascal-rec row col)
+ (cond ((= row col) 1)
+ ((= col 1) 1)
+ (else (+ (pascal-rec (- row 1) (- col 1))
+ (pascal-rec (- row 1) col)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (pascal-rec 1 1) 1)
+(test-case (pascal-rec 2 1) 1)
+(test-case (pascal-rec 2 2) 1)
+(test-case (pascal-rec 3 1) 1)
+(test-case (pascal-rec 3 2) 2)
+(test-case (pascal-rec 3 3) 1)
+(test-case (pascal-rec 4 1) 1)
+(test-case (pascal-rec 4 2) 3)
+(test-case (pascal-rec 4 3) 3)
+(test-case (pascal-rec 4 4) 1)
+(test-case (pascal-rec 5 1) 1)
+(test-case (pascal-rec 5 2) 4)
+(test-case (pascal-rec 5 3) 6)
+(test-case (pascal-rec 5 4) 4)
+(test-case (pascal-rec 5 5) 1)
blob - /dev/null
blob + 2cc1e7171d93964087e6b5e90bdc838804de43e9 (mode 644)
--- /dev/null
+++ ex1-12.scm~
@@ -0,0 +1,24 @@
+(define (pascal-rec row col)
+ (cond ((= row col) 1)
+ ((= col 1) 1)
+ (else (+ (pascal-rec (- row 1) (- col 1))
+ (pascal-rec (- row 1) col)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (pascal-rec 1 1) 1)
+(test-case (pascal-rec 2 1) 1)
+(test-case (pascal-rec 2 2) 1)
+(test-case (pascal-rec 3 1) 1)
+(test-case (pascal-rec 3 2) 2)
+(test-case (pascal-rec 3 3) 1)
+(test-case (pascal-rec 4 1) 1)
+(test-case (pascal-rec 4 2) 3)
+(test-case (pascal-rec 4 3) 3)
+(test-case (pascal-rec 4 4) 1)
+(test-case (pascal-rec 5 1) 1)
+(test-case (pascal-rec 5 2) 4)
+(test-case (pascal-rec 5 3) 6)
+(test-case (pascal-rec 5 4) 4)
+(test-case (pascal-rec 5 5) 1)
blob - /dev/null
blob + a35863a2ff33daf475ad38eea519e93b08592d9f (mode 644)
--- /dev/null
+++ ex1-14.scm
@@ -0,0 +1,2 @@
+order of growth of the space is equal to the depth (roughly proportional to amount)
+order of growth of steps is equal to number of nodes (roughly 2^amount) ;; this is wrong, actually of order amount^kinds-of-coins but proof is ridiculously complicated
\ No newline at end of file
blob - /dev/null
blob + 6e9ebf5b1de9f885977ffcfdcab97cb7ba1ecbfc (mode 644)
--- /dev/null
+++ ex1-15.scm
@@ -0,0 +1,18 @@
+(define (cube x) (* x x x))
+(define (p x) (- (* 3 x) (* 4 (cube x))))
+(define (sine angle)
+ (if (not (> (abs angle) 0.1))
+ angle
+ (p (sine (/ angle 3.0)))))
+
+(sine 12.15)
+(p (sine 4.05))
+(p (p (sine 1.35)))
+(p (p (p (sine 0.45))))
+(p (p (p (p (sine 0.15)))))
+(p (p (p (p (p (sine 0.05))))))
+
+5 times
+
+number of steps is order of log(angle)
+growth of space is order of log(angle) as well
\ No newline at end of file
blob - /dev/null
blob + eabe2016a306941e32762cb0448ce8ff8a7d8630 (mode 644)
--- /dev/null
+++ ex1-15.scm~
@@ -0,0 +1,6 @@
+(define (cube x) (* x x x))
+(define (p x) (- (* 3 x) (* 4 (cube x))))
+(define (sine angle)
+ (if (not (> (abs angle) 0.1))
+ angle
+ (p (sine (/ angle 3.0)))))
\ No newline at end of file
blob - /dev/null
blob + b34aef73bbde6d83c92fd8e03fc83e6a54090e11 (mode 644)
--- /dev/null
+++ ex1-16.lisp
@@ -0,0 +1,4 @@
+(defun fast-expt-iter (b n &optional (a 1))
+ (cond ((= n 0) a)
+ ((evenp n) (fast-expt-iter (square b) (/ n 2) a))
+ (t (fast-expt-iter b (- n 1) (* b a)))))
\ No newline at end of file
blob - /dev/null
blob + 2b563916e7723fe4d55a635d959b69f95d5d437e (mode 644)
--- /dev/null
+++ ex1-16.scm
@@ -0,0 +1,46 @@
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+(define (expt b n)
+ (expt-iter b n 1))
+(define (expt-iter b counter product)
+ (if (= counter 0)
+ product
+ (expt-iter b
+ (- counter 1)
+ (* b product))))
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define (even? n)
+ (= (remainder n 2) 0))
+
+;; Exercise 1.16. Design a procedure that evolves an iterative exponentiation process that uses successive squaring and uses a logarithmic number of steps, as does fast-expt. (Hint: Using the observation that (b^(n/2))^2 = (b^2)^(n/2), keep, along with the exponent n and the base b, an additional state variable a, and define the state transformation in such a way that the product a*b^n is unchanged from state to state. At the beginning of the process a is taken to be 1, and the answer is given by the value of a at the end of the process. In general, the technique of defining an invariant quantity that remains unchanged from state to state is a powerful way to think about the design of iterative algorithms.)
+
+(define (fast-expt-iter a b n)
+ (cond ((= n 0) a)
+ ((odd? n) (fast-expt-iter (* b a) b (- n 1)))
+ ((even? n) (fast-expt-iter a (square b) (/ n 2)))))
+
+(define (square x) (* x x))
+(define (even? x) (= (remainder x 2) 0))
+(define (odd? x) (= (remainder x 2) 1))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-expt-iter 2 1 0) 2)
+(test-case (fast-expt-iter 2 0 5) 0)
+(test-case (fast-expt-iter 0 4 0) 0)
+(test-case (fast-expt-iter 0 0 4) 0)
+(test-case (fast-expt-iter 3 2 0) 3)
+(test-case (fast-expt-iter 5 2 4) 80)
+(test-case (fast-expt-iter 10 3 6) 7290)
+(test-case (fast-expt-iter 8 4 3) 512)
+
+;; these test cases wouldn't work
+;; (fast-expt-iter 2 0 0)
+;; (fast-expt-iter 0 0 0)
blob - /dev/null
blob + 1cf0407df2e42c00c451168554571899bbe9723b (mode 644)
--- /dev/null
+++ ex1-16.scm~
@@ -0,0 +1,45 @@
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+(define (expt b n)
+ (expt-iter b n 1))
+(define (expt-iter b counter product)
+ (if (= counter 0)
+ product
+ (expt-iter b
+ (- counter 1)
+ (* b product))))
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define (even? n)
+ (= (remainder n 2) 0))
+
+;; Exercise 1.16. Design a procedure that evolves an iterative exponentiation process that uses successive squaring and uses a logarithmic number of steps, as does fast-expt. (Hint: Using the observation that (b^(n/2))^2 = (b^2)^(n/2), keep, along with the exponent n and the base b, an additional state variable a, and define the state transformation in such a way that the product a*b^n is unchanged from state to state. At the beginning of the process a is taken to be 1, and the answer is given by the value of a at the end of the process. In general, the technique of defining an invariant quantity that remains unchanged from state to state is a powerful way to think about the design of iterative algorithms.)
+
+(define (fast-expt-iter a b n)
+ (cond ((= n 0) a)
+ ((odd? n) (fast-expt-iter (* b a) b (- n 1)))
+ ((even? n) (fast-expt-iter a (square b) (/ n 2)))))
+
+(define (square x) (* x x))
+(define (even? x) (= (remainder x 2) 0))
+(define (odd? x) (= (remainder x 2) 1))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-expt-iter 2 1 0) 2)
+(test-case (fast-expt-iter 2 0 5) 0)
+(test-case (fast-expt-iter 0 4 0) 0)
+(test-case (fast-expt-iter 0 0 4) 0)
+(test-case (fast-expt-iter 3 2 0) 3)
+(test-case (fast-expt-iter 5 2 4) 80)
+(test-case (fast-expt-iter 10 3 6) 7290)
+(test-case (fast-expt-iter 8 4 3) 512)
+
+;; these test cases wouldn't work
+;; (fast-expt-iter 2 0 0)
+;; (fast-expt-iter 0 0 0)
blob - /dev/null
blob + 0221c8b4fdd419f2da677634cbdc3f76883bfb15 (mode 644)
--- /dev/null
+++ ex1-17.lisp
@@ -0,0 +1,9 @@
+(defun double (x)
+ (* x 2))
+(defun halve (x)
+ (/ x 2))
+(defun fast-mult (a b)
+ (cond ((= b 0) 0)
+ ((= b 1) a)
+ ((evenp b) (double (fast-mult a (halve b))))
+ (t (+ a (fast-mult a (- b 1))))))
\ No newline at end of file
blob - /dev/null
blob + 2af32dda802d2479ab3abfb316bb03eaf3e20bd6 (mode 644)
--- /dev/null
+++ ex1-17.lisp~
@@ -0,0 +1,9 @@
+(defun double (x)
+ (* x 2))
+(defun halve (x)
+ (/ x 2))
+(defun fast-mult (a b)
+ (cond ((= b 0) 0)
+ ((= b 1) a)
+ ((evenp b) (double (fast-mult a (halve b))))
+
\ No newline at end of file
blob - /dev/null
blob + c36ac117f8404a5a2e661117bda79ee3a88dd847 (mode 644)
--- /dev/null
+++ ex1-17.scm
@@ -0,0 +1,34 @@
+(define (* a b)
+ (if (= b 0)
+ 0
+ (+ a (* a (- b 1)))))
+
+;; a * b = {
+;; 0 if b = 0,
+;; 2 * a * (b/2) if b is even,
+;; a + a * (b-1) if b is odd
+;; }
+
+(define (fast-mult a b)
+ (cond ((= b 0) 0)
+ ((even? b) (double (* a (halve b))))
+ (else (+ a (* a (- b 1))))))
+(define (double x)
+ (+ x x))
+(define (halve x)
+ (/ x 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-mult 0 0) 0)
+(test-case (fast-mult 0 1) 0)
+(test-case (fast-mult 0 8) 0)
+(test-case (fast-mult 5 0) 0)
+(test-case (fast-mult 2 1) 2)
+(test-case (fast-mult 3 3) 9)
+(test-case (fast-mult 5 4) 20)
+(test-case (fast-mult 12 13) 156)
+(test-case (fast-mult 12 24) 288)
+
blob - /dev/null
blob + ae05641b0ba60bfedac4805ac94ea027c0333169 (mode 644)
--- /dev/null
+++ ex1-17.scm~
@@ -0,0 +1,21 @@
+(define (* a b)
+ (if (= b 0)
+ 0
+ (+ a (* a (- b 1)))))
+
+;; a * b = {
+;; 0 if b = 0,
+;; 2 * a * (b/2) if b is even,
+;; a + a * (b-1) if b is odd
+;; }
+
+(define (fast-mult a b)
+ (cond ((= b 0) 0)
+ ((even? b) (double (* a (halve b))))
+ (else (+ a (* a (- b 1))))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-expt-iter 2 1 0) 2)
blob - /dev/null
blob + 6d66ff64da8921787acfa97a43995c2addf56ecc (mode 644)
--- /dev/null
+++ ex1-18.lisp
@@ -0,0 +1,4 @@
+(defun fast-mult-iter (a b &optional (acc 0))
+ (cond ((= b 0) acc)
+ ((evenp b) (fast-mult-iter (double a) (halve b) acc))
+ (t (fast-mult-iter a (1- b) (+ a acc)))))
\ No newline at end of file
blob - /dev/null
blob + 09c21c88cf3bbfb1cc4024e2c24fe72572a4c785 (mode 644)
--- /dev/null
+++ ex1-18.scm
@@ -0,0 +1,30 @@
+;; Exercise 1.18. Using the results of exercises 1.16 and 1.17, devise a procedure that generates an iterative process for multiplying two integers in terms of adding, doubling, and halving and uses a logarithmic number of steps.40
+
+;; invariant quantity
+;; t + a * b = {
+;; t if b = 0
+;; t + 2 * a * (b/2) if b even
+;; (t+a) + a * (b-1) if b odd
+;; }
+
+(define (fast-mult-iter a b t)
+ (cond ((= b 0) t)
+ ((even? b) (double fast-mult-iter a (halve b) t))
+ (else (fast-mult-iter a (- b 1) (+ t a)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-mult 0 0) 0)
+(test-case (fast-mult 0 1) 0)
+(test-case (fast-mult 0 8) 0)
+(test-case (fast-mult 5 0) 0)
+(test-case (fast-mult 2 1) 2)
+(test-case (fast-mult 3 3) 9)
+(test-case (fast-mult 5 4) 20)
+(test-case (fast-mult 12 13) 156)
+(test-case (fast-mult 12 24) 288)
+
+
+
blob - /dev/null
blob + 418a8b61185c480e7e3f78d2c0be186c63df6bfe (mode 644)
--- /dev/null
+++ ex1-18.scm~
@@ -0,0 +1 @@
+ Exercise 1.18. Using the results of exercises 1.16 and 1.17, devise a procedure that generates an iterative process for multiplying two integers in terms of adding, doubling, and halving and uses a logarithmic number of steps.40
\ No newline at end of file
blob - /dev/null
blob + dad887572d646910d4c292dda9306d5f412a9052 (mode 644)
--- /dev/null
+++ ex1-19.scm
@@ -0,0 +1,48 @@
+(define (square x)
+ (* x x))
+(define (fib n)
+ (fib-iter 1 0 0 1 n))
+(define (fib-iter a b p q count)
+ (cond ((= count 0) b)
+ ((even? count) (fib-iter a
+ b
+ (+ (square q) (square p))
+ (+ (* 2 q p) (square q))
+ (/ count 2)))
+ (else (fib-iter (+ (* b q) (* a q) (* a p))
+ (+ (* b p) (* a q))
+ p
+ q
+ (- count 1)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (fib 0) 0)
+(test-case (fib 1) 1)
+(test-case (fib 2) 1)
+(test-case (fib 3) 2)
+(test-case (fib 4) 3)
+(test-case (fib 5) 5)
+(test-case (fib 6) 8)
+(test-case (fib 7) 13)
+(test-case (fib 8) 21)
+(test-case (fib 9) 34)
+
+(define (fib n)
+ (fib-iter 1 0 0 1 n)
+
+(define (fib-iter a b p q n)
+ (cond ((= n 0) b)
+ ((even? n) (fib-iter a
+ b
+ (+ (square p) (square q))
+ (+ (* 2 p q) (square q))
+ (/ n 2)))
+ (else (fib-iter (+ (* b q) (* a q) (* a p))
+ (+ (* b p) (* a q))
+ p
+ q
+ (- n 1)))))
\ No newline at end of file
blob - /dev/null
blob + 2f9e5ce1a8a19afa3d8a6a60ef0b3fa8862991d3 (mode 644)
--- /dev/null
+++ ex1-19.scm~
@@ -0,0 +1,10 @@
+(define (fib n)
+ (fib-iter 1 0 0 1 n))
+(define (fib-iter a b p q count)
+ (cond ((= count 0) b)
+ ((even? count) (fib-iter a
+ b
+ (+ (* 2 q p) (square q))
+ (+ (square q) (square p))
+ (/ count 2)))
+ (else (fib-iter (+ (
\ No newline at end of file
blob - /dev/null
blob + 91b598086dfc39895d2d22ff933822f842ea1dfb (mode 644)
--- /dev/null
+++ ex1-2.scm
@@ -0,0 +1,5 @@
+(/ (+ 5 4 (- 2
+ (- 3
+ (+ 6
+ (/ 4 5)))))
+ (* 3 (- 6 2) (- 2 7)))
\ No newline at end of file
blob - /dev/null
blob + da3a38e1f0e0f13ba10083982040344d6fcb8c94 (mode 644)
--- /dev/null
+++ ex1-2.scm~
@@ -0,0 +1,5 @@
+(/ (+ 5 4 (- 2
+ (- 3
+ (+ 6
+ (/ 4 3)))))
+ (* 3 (- 6 2) (- 2 7)))
\ No newline at end of file
blob - /dev/null
blob + 5db7c285c754f1ec524c50aac3f1b9359174cf2a (mode 644)
--- /dev/null
+++ ex1-20.scm
@@ -0,0 +1,22 @@
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+
+(gcd 206 40)
+(gcd 40 (remainder 206 40))
+evaluate remainder once
+(gcd (remainder 206 40) (remainder 40 (remainder 206 40)))
+evaluate remainder three times
+(gcd (remainder 40 (remainder 206 40)) (remainder (remainder 206 40) (remainder 40 (remainder 206 40))))
+evaluate remainder 7 times
+(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)))))
+evaluate remainder 14 times
+(remainder (remainder 206 40) (remainder 40 (remainder 206 40)))
+(remainder 6 (remainder 40 (remainder 206 40)))
+(remainder 6 (remainder 40 (remainder 206 40))) ;; 15 times
+(remainder 6 (remainder 40 6)) ;; 16 times
+(remainder 6 4) ;; 17 times
+2 ;; 18 times
+
+18 remainder operations are performed in normal order, whereas only 4 are performed in normal-order
\ No newline at end of file
blob - /dev/null
blob + b9af13619479b3a56d270bf02b844d67fd47ea7b (mode 644)
--- /dev/null
+++ ex1-20.scm~
@@ -0,0 +1,4 @@
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
\ No newline at end of file
blob - /dev/null
blob + 64b5f92f5683f247d6f703673a467ea24e9057b9 (mode 644)
--- /dev/null
+++ ex1-21.scm
@@ -0,0 +1,36 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(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 (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (smallest-divisor 199) 199)
+(test-case (smallest-divisor 1999) 1999)
+(test-case (smallest-divisor 19999) 7)
+
+
+
blob - /dev/null
blob + a524b98eb61ae95bff8056efbe319546ffbcedf2 (mode 644)
--- /dev/null
+++ ex1-21.scm~
@@ -0,0 +1,29 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ ((> (- (square test-divisor) n)) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+;;(display (smallest-divisor 199))
+;;(display (smallest-divisor 1999))
+;;(display (smallest-divisor 19999))
+;;(smallest-divisor 19999)
\ No newline at end of file
blob - /dev/null
blob + fd243208d841417be40fc87c0e8bb8309fef6f52 (mode 644)
--- /dev/null
+++ ex1-22.lisp
@@ -0,0 +1,8 @@
+(defun search-for-primes (start end)
+ (let ((start (if (evenp start) (1+ start) start)))
+ (do ((i start (+ i 2)))
+ ((> i end))
+ (when (prime? i)
+ (format t "~d is prime~%" i)))))
+
+(time (dotimes (i 1000 t) (search-for-primes 1000 1019)))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 95406b1308abe9cbc0c4751b2c87fc70b6c6377c (mode 644)
Binary files /dev/null and ex1-22.ods differ
blob - /dev/null
blob + 4b3832d5ffc43f111baff4d71e0abe7cee041e19 (mode 644)
--- /dev/null
+++ ex1-22.scm
@@ -0,0 +1,62 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(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 (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000001 100000099)
+(search-for-primes 1000000001 1000000099)
+(search-for-primes 10000000001 10000000099)
+(search-for-primes 100000000001 100000000099)
+(search-for-primes 1000000000001 1000000000099)
+(search-for-primes 10000000000001 10000000000099)
+(search-for-primes 100000000000001 100000000000099)
+
+;; see spreadsheet for results and charts
+
+;; Yes, our timing data perfectly fits the order of growth prediction that R(n) is of the order sqrt(n). So, it seems that our programs do run in time proportional to number of steps required.
+
blob - /dev/null
blob + 64b5f92f5683f247d6f703673a467ea24e9057b9 (mode 644)
--- /dev/null
+++ ex1-22.scm~
@@ -0,0 +1,36 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(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 (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (smallest-divisor 199) 199)
+(test-case (smallest-divisor 1999) 1999)
+(test-case (smallest-divisor 19999) 7)
+
+
+
blob - /dev/null
blob + ea86bb08e494691ff41bdbf7c72db2d8b59ab6fb (mode 644)
Binary files /dev/null and ex1-23.ods differ
blob - /dev/null
blob + 2e2aef81cb909503f4ed9ba2d5a91f2cdce35e14 (mode 644)
--- /dev/null
+++ ex1-23.scm
@@ -0,0 +1,68 @@
+;; (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 ((= times 0) true)
+;; ((fermat-test n) (fast-prime? n (- times 1)))
+;; (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.23. The smallest-divisor procedure shown at the start of this section does lots of needless testing: After it checks to see if the number is divisible by 2 there is no point in checking to see if it is divisible by any larger even numbers. This suggests that the values used for test-divisor should not be 2, 3, 4, 5, 6, ..., but rather 2, 3, 5, 7, 9, .... To implement this change, define a procedure next that returns 3 if its input is equal to 2 and otherwise returns its input plus 2. Modify the smallest-divisor procedure to use (next test-divisor) instead of (+ test-divisor 1). With timed-prime-test incorporating this modified version of smallest-divisor, run the test for each of the 12 primes found in exercise 1.22. Since this modification halves the number of test steps, you should expect it to run about twice as fast. Is this expectation confirmed? If not, what is the observed ratio of the speeds of the two algorithms, and how do you explain the fact that it is different from 2?
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (define (next-divisor n)
+ (if (= n 2)
+ 3
+ (+ n 2)))
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (next-divisor test-divisor)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 100000001 100000099)
+(search-for-primes 1000000001 1000000099)
+(search-for-primes 10000000001 10000000099)
+(search-for-primes 100000000001 100000000099)
+(search-for-primes 1000000000001 1000000000099)
+(search-for-primes 10000000000001 10000000000099)
+(search-for-primes 100000000000001 100000000000099)
+
+;; see spreadsheet ex1-23.ods for results
+;; Not quite half, but close enough. This is due to introducing an extra computation at each step due to having to evaluate one extra (next-divisor test-divisor) with each call on the procedure
blob - /dev/null
blob + fd243208d841417be40fc87c0e8bb8309fef6f52 (mode 644)
--- /dev/null
+++ ex1-23.scm~
@@ -0,0 +1,8 @@
+(defun search-for-primes (start end)
+ (let ((start (if (evenp start) (1+ start) start)))
+ (do ((i start (+ i 2)))
+ ((> i end))
+ (when (prime? i)
+ (format t "~d is prime~%" i)))))
+
+(time (dotimes (i 1000 t) (search-for-primes 1000 1019)))
blob - /dev/null
blob + 626befc242fc0679b51cf6bf87f767cb1e282616 (mode 644)
Binary files /dev/null and ex1-24.ods differ
blob - /dev/null
blob + b7eb24f24d6d743721de3c03a955083c45fd8da8 (mode 644)
--- /dev/null
+++ ex1-24.scm
@@ -0,0 +1,71 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;;can't even test due to small numbers being too fast
+
blob - /dev/null
blob + c6347f520e333ba233b035378dce46a835cc0164 (mode 644)
--- /dev/null
+++ ex1-24.scm~
@@ -0,0 +1,72 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+
+;;can't even test due to small numbers being too fast, large numbers being too large to be represented
+
blob - /dev/null
blob + a560eac21114a4389409303db477c49c6e72260a (mode 644)
--- /dev/null
+++ ex1-25.scm
@@ -0,0 +1,91 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.25. Alyssa P. Hacker complains that we went to a lot of extra work in writing expmod. After all, she says, since we already know how to compute exponentials, we could have simply written
+
+;; (define (expmod base exp m)
+;; (remainder (fast-expt base exp) m))
+
+;; Is she correct? Would this procedure serve as well for our fast prime tester? Explain.
+
+(define (expmod base exp m)
+ (remainder (fast-expt base exp) m))
+
+(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 (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))))
+
+;; Calculating exponentials using (fast-expt ...) gets slower and slower since we are calculating absolutely huge exponents (base^10000000... and higher). Doing multiplication requires more steps as the exponents get bigger, which is why using (expmod) is a huge benefit. The actual multiplications are never bigger than m.
blob - /dev/null
blob + 365e19d77826864cf33b1be160037526152a210f (mode 644)
--- /dev/null
+++ ex1-25.scm~
@@ -0,0 +1,75 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 1000000000001 100000000099)
+(search-for-primes 10000000000001 1000000000099)
+(search-for-primes 100000000000001 10000000000099)
+(search-for-primes 1000000000000001 100000000000099)
+(search-for-primes 10000000000000001 1000000000000099)
+(search-for-primes 100000000000000001 10000000000000099)
+
+;; Exercise 1.25. Alyssa P. Hacker complains that we went to a lot of extra work in writing expmod. After all, she says, since we already know how to compute exponentials, we could have simply written
+
+;; (define (expmod base exp m)
+;; (remainder (fast-expt base exp) m))
+
+;; Is she correct? Would this procedure serve as well for our fast prime tester? Explain.
blob - /dev/null
blob + c5c89fd781a5488a1c93d54d14fa25428cfdc9b1 (mode 644)
--- /dev/null
+++ ex1-26.lisp
@@ -0,0 +1,12 @@
+(setf custom:*trace-indent* 1)
+
+(trace expmod)
+(expmod 15 10 10)
+((defun louid-expmod (base exponent m)
+ (cond ((= exponent 0) 1)
+ ((evenp exponent)
+ (rem (* (louis-expmod base (/ exponent 2) m)
+ (louid-expmod base (/ exponent 2) m))
+ m))
+ (t (rem (* base louid-expmod base (- exponent 1) m))
+ m))))
blob - /dev/null
blob + 3c948a5b60b6ddedddffaa8877852c656c9d65e4 (mode 644)
--- /dev/null
+++ ex1-26.lisp~
@@ -0,0 +1,11 @@
+(setf custom:*trace-indent* 1)
+
+(trace expmod)
+(expmod 15 10 10)
+((defun louid-expmod (base exponent m)
+ (cond ((= exponent 0) 1)
+ ((evenp exponent)
+ (rem (* (louis-expmod base (/ exponent 2) m)
+ (louid-expmod base (/ exponent 2) m))
+ m))
+ (t (rem (* base louid-expmod base (- exponent 1) m)) m))))
blob - /dev/null
blob + c5c5502df313593611f71c9f3f6410b016e0d19a (mode 644)
--- /dev/null
+++ ex1-26.scm
@@ -0,0 +1,67 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.26. Louis Reasoner is having great difficulty doing exercise 1.24. His fast-prime? test seems to run more slowly than his prime? test. Louis calls his friend Eva Lu Ator over to help. When they examine Louis's code, they find that he has rewritten the expmod procedure to use an explicit multiplication, rather than calling square:
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (* (expmod base (/ exp 2) m)
+ (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (- exp 1) m))
+ m))))
+
+;;``I don't see what difference that could make,'' says Louis. ``I do.'' says Eva. ``By writing the procedure like that, you have transformed the (log n) process into a (n) process.'' Explain.
+
+;; Every time exp = 2, we have to calculate (expmod base (/ exp 2) m) twice instead of once. But this ultimately ends up creating lots more calls because this occurs at each procedure call where exp = 2. In total, there will be 'exp' number of alls rather than the original roughly log(exp) number of calls.
+n
+;; We used to have a linear(??) recursion at each step but now have a tree(??) recursion. It used to be O(log) but because it increase exponentially, it is back to the order of exp.
blob - /dev/null
blob + c5c5502df313593611f71c9f3f6410b016e0d19a (mode 644)
--- /dev/null
+++ ex1-26.scm~
@@ -0,0 +1,67 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.26. Louis Reasoner is having great difficulty doing exercise 1.24. His fast-prime? test seems to run more slowly than his prime? test. Louis calls his friend Eva Lu Ator over to help. When they examine Louis's code, they find that he has rewritten the expmod procedure to use an explicit multiplication, rather than calling square:
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (* (expmod base (/ exp 2) m)
+ (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (- exp 1) m))
+ m))))
+
+;;``I don't see what difference that could make,'' says Louis. ``I do.'' says Eva. ``By writing the procedure like that, you have transformed the (log n) process into a (n) process.'' Explain.
+
+;; Every time exp = 2, we have to calculate (expmod base (/ exp 2) m) twice instead of once. But this ultimately ends up creating lots more calls because this occurs at each procedure call where exp = 2. In total, there will be 'exp' number of alls rather than the original roughly log(exp) number of calls.
+n
+;; We used to have a linear(??) recursion at each step but now have a tree(??) recursion. It used to be O(log) but because it increase exponentially, it is back to the order of exp.
blob - /dev/null
blob + 0b4e03b7465c3238069eeec5caf4b270801cb19c (mode 644)
--- /dev/null
+++ ex1-27.lisp
@@ -0,0 +1,8 @@
+(defun full-fermat-test (n)
+ (defun aux-test (a)
+ (cond ((= a 1) t)
+ ((/= (expmod a n n) a) nil)
+ (t (aux-test (1- a)))))
+ (aux-test (1- n)))
+
+(full-fermat-test 6601)
blob - /dev/null
blob + 156b7fd641d126df862e4bb41e7fd2d83c0ee7e0 (mode 644)
--- /dev/null
+++ ex1-27.lisp~
@@ -0,0 +1,6 @@
+(defun full-fermat-test (n)
+ (defun aux-test (a)
+ (cond ((= a 1) t)
+ ((/= (expmod a n n) a) nil)
+ (t (aux-test (1- a)))))
+ (aux-test (1- n)))
blob - /dev/null
blob + fed4b05b62bb7aa0f02cdde694483622241e4def (mode 644)
--- /dev/null
+++ ex1-27.scm
@@ -0,0 +1,143 @@
+;; (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 ((= times 0) true)
+;; ((fermat-test n) (fast-prime? n (- times 1)))
+;; (else false)))
+
+;; ;; (define (test-case actual expected)
+;; ;; (load-option 'format)
+;; ;; (newline)
+;; ;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (define (prime? n)
+;; (let ((times-to-test 10))
+;; (fast-prime? n times-to-test)))
+
+;; (define (timed-prime-test n)
+;; (newline)
+;; (display n)
+;; (start-prime-test n (runtime)))
+;; (define (start-prime-test n start-time)
+;; (if (prime? n)
+;; (report-prime (- (runtime) start-time))))
+;; (define (report-prime elapsed-time)
+;; (display " *** ")
+;; (display elapsed-time))
+
+;; (define (search-for-primes lower upper)
+;; (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+;; ((< lower upper) (begin (timed-prime-test lower)
+;; (search-for-primes (+ lower 2) upper)))
+;; (else (newline)
+;; (display " *** Finished *** "))))
+
+;; (search-for-primes 100000000000001 100000000000099)
+;; (search-for-primes 1000000000000001 1000000000000099)
+;; (search-for-primes 10000000000000001 10000000000000099)
+;; (search-for-primes 100000000000000001 100000000000000099)
+;; (search-for-primes 1000000000000000001 1000000000000000099)
+;; (search-for-primes 10000000000000000001 10000000000000000099)
+
+
+;; (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 ((= times 0) true)
+;; ((fermat-test n) (fast-prime? n (- times 1)))
+;; (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (define (prime? n)
+;; (let ((times-to-test 10))
+;; (fast-prime? n times-to-test)))
+
+;; (define (timed-prime-test n)
+;; (newline)
+;; (display n)
+;; (start-prime-test n (runtime)))
+;; (define (start-prime-test n start-time)
+;; (if (prime? n)
+;; (report-prime (- (runtime) start-time))))
+;; (define (report-prime elapsed-time)
+;; (display " *** ")
+;; (display elapsed-time))
+
+;; (define (search-for-primes lower upper)
+;; (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+;; ((< lower upper) (begin (timed-prime-test lower)
+;; (search-for-primes (+ lower 2) upper)))
+;; (else (newline)
+;; (display " *** Finished *** "))))
+
+
+
+
+
+;; Exercise 1.27. Demonstrate that the Carmichael numbers listed in footnote 47 really do fool the Fermat test. That is, write a procedure that takes an integer n and tests whether an is congruent to a modulo n for every a<n, and try your procedure on the given Carmichael numbers.
+
+;; Numbers that fool the Fermat test are called Carmichael numbers, and little is known about them other than that they are extremely rare. There are 255 Carmichael numbers below 100,000,000. The smallest few are 561, 1105, 1729, 2465, 2821, and 6601. In testing primality of very large numbers chosen at random, the chance of stumbling upon a value that fools the Fermat test is less than the chance that cosmic radiation will cause the computer to make an error in carrying out a ``correct'' algorithm. Considering an algorithm to be inadequate for the first reason but not for the second illustrates the difference between mathematics and engineering.
+
+;; calculate base^exp modulo m
+(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))))
+
+;; tests if integer n passes fermat's little theorem
+(define (fermat-prime? n)
+ (define (fermat-test a)
+ (cond ((= a n) #t)
+ ((not (= (expmod a n n) a)) #f)
+ (else (fermat-test (+ a 1)))))
+ (fermat-test 1))
+
+(define (list-primes upper)
+ (define (test i)
+ (cond ((= i upper) (display "Finished"))
+ ((fermat-prime? i) (begin (display i)
+ (newline))))
+ (test (+ i 1)))
+ (test 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (fermat-prime? 2) #t)
+;; (test-case (fermat-prime? 3) #t)
+;; (test-case (fermat-prime? 4) #f)
+;; (test-case (fermat-prime? 5) #t)
+;; (test-case (fermat-prime? 6) #f)
+;; (test-case (fermat-prime? 7) #t)
+;; (test-case (fermat-prime? 8) #f)
+;; (test-case (fermat-prime? 9) #f)
+
+
+;; (list-primes 10000)
+
+;; Carmichael Numbers
+(test-case (fermat-prime? 561) #f)
+(test-case (fermat-prime? 1105) #f)
+(test-case (fermat-prime? 1729) #f)
+(test-case (fermat-prime? 2465) #f)
+(test-case (fermat-prime? 2821) #f)
+(test-case (fermat-prime? 6601) #f)
blob - /dev/null
blob + c5c5502df313593611f71c9f3f6410b016e0d19a (mode 644)
--- /dev/null
+++ ex1-27.scm~
@@ -0,0 +1,67 @@
+(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 ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.26. Louis Reasoner is having great difficulty doing exercise 1.24. His fast-prime? test seems to run more slowly than his prime? test. Louis calls his friend Eva Lu Ator over to help. When they examine Louis's code, they find that he has rewritten the expmod procedure to use an explicit multiplication, rather than calling square:
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (* (expmod base (/ exp 2) m)
+ (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (- exp 1) m))
+ m))))
+
+;;``I don't see what difference that could make,'' says Louis. ``I do.'' says Eva. ``By writing the procedure like that, you have transformed the (log n) process into a (n) process.'' Explain.
+
+;; Every time exp = 2, we have to calculate (expmod base (/ exp 2) m) twice instead of once. But this ultimately ends up creating lots more calls because this occurs at each procedure call where exp = 2. In total, there will be 'exp' number of alls rather than the original roughly log(exp) number of calls.
+n
+;; We used to have a linear(??) recursion at each step but now have a tree(??) recursion. It used to be O(log) but because it increase exponentially, it is back to the order of exp.
blob - /dev/null
blob + d923538258f52936697b125522f8c350adbb316b (mode 644)
--- /dev/null
+++ ex1-28.scm
@@ -0,0 +1,50 @@
+;; Exercise 1.28. One variant of the Fermat test that cannot be fooled is called the Miller-Rabin test (Miller 1976; Rabin 1980). This starts from an alternate form of Fermat's Little Theorem, which states that if n is a prime number and a is any positive integer less than n, then a raised to the (n - 1)st power is congruent to 1 modulo n. To test the primality of a number n by the Miller-Rabin test, we pick a random number a<n and raise a to the (n - 1)st power modulo n using the expmod procedure. However, whenever we perform the squaring step in expmod, we check to see if we have discovered a ``nontrivial square root of 1 modulo n,'' that is, a number not equal to 1 or n - 1 whose square is equal to 1 modulo n. It is possible to prove that if such a nontrivial square root of 1 exists, then n is not prime. It is also possible to prove that if n is an odd number that is not prime, then, for at least half the numbers a<n, computing a^(n-1) in this way will reveal a nontrivial square root of 1 modulo n. (This is why the Miller-Rabin test cannot be fooled.) Modify the expmod procedure to signal if it discovers a nontrivial square root of 1, and use this to implement the Miller-Rabin test with a procedure analogous to fermat-test. Check your procedure by testing various known primes and non-primes. Hint: One convenient way to make expmod signal is to have it return 0.
+
+;; calculate base^exp modulo m but return 0 if nontrivial square root of 1 modulo n is discovered
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (let ((modulo-sqrt (expmod base (/ exp 2) m)))
+ (let ((modulo-sqr (remainder (square modulo-sqrt) m)))
+ (if (and (not (or (= modulo-sqrt 1) (= modulo-sqrt (- m 1))))
+ (= modulo-sqr 1))
+ 0
+ modulo-sqr))))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (miller-rabin-test n)
+ (define (try-it a)
+ (= (expmod a (- n 1) n) 1))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (miller-rabin-prime? n times)
+ (cond ((= times 0) #t)
+ ((miller-rabin-test n) (miller-rabin-prime? n (- times 1)))
+ (else #f)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (quick-mr-prime? n)
+ (miller-rabin-prime? n 2500))
+
+;;(test-case (quick-mr-prime? 2) #t)
+(test-case (quick-mr-prime? 3) #t)
+(test-case (quick-mr-prime? 4) #f)
+(test-case (quick-mr-prime? 5) #t)
+(test-case (quick-mr-prime? 6) #f)
+(test-case (quick-mr-prime? 7) #t)
+(test-case (quick-mr-prime? 8) #f)
+(test-case (quick-mr-prime? 9) #f)
+
+;; (list-primes 10000)
+
+;; Carmichael Numbers
+(test-case (quick-mr-prime? 561) #f)
+(test-case (quick-mr-prime? 1105) #f)
+(test-case (quick-mr-prime? 1729) #f)
+(test-case (quick-mr-prime? 2465) #f)
+(test-case (quick-mr-prime? 2821) #f)
+(test-case (quick-mr-prime? 6601) #f)
blob - /dev/null
blob + 857dc841bf4e31520ae0b29fdbfc09a364069dcc (mode 644)
--- /dev/null
+++ ex1-28.scm~
@@ -0,0 +1,60 @@
+;; calculate base^exp modulo m
+(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))))
+
+;; tests if integer n passes fermat's little theorem
+(define (fermat-prime? n)
+ (define (fermat-test a)
+ (cond ((= a n) #t)
+ ((not (= (expmod a n n) a)) #f)
+ (else (fermat-test (+ a 1)))))
+ (fermat-test 1))
+
+(define (list-primes upper)
+ (define (test i)
+ (cond ((= i upper) (display "Finished"))
+ ((fermat-prime? i) (begin (display i)
+ (newline))))
+ (test (+ i 1)))
+ (test 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (fermat-prime? 2) #t)
+;; (test-case (fermat-prime? 3) #t)
+;; (test-case (fermat-prime? 4) #f)
+;; (test-case (fermat-prime? 5) #t)
+;; (test-case (fermat-prime? 6) #f)
+;; (test-case (fermat-prime? 7) #t)
+;; (test-case (fermat-prime? 8) #f)
+;; (test-case (fermat-prime? 9) #f)
+
+
+;; (list-primes 10000)
+
+;; Carmichael Numbers
+(test-case (fermat-prime? 561) #f)
+(test-case (fermat-prime? 1105) #f)
+(test-case (fermat-prime? 1729) #f)
+(test-case (fermat-prime? 2465) #f)
+(test-case (fermat-prime? 2821) #f)
+(test-case (fermat-prime? 6601) #f)
+
+
+;; Exercise 1.28. One variant of the Fermat test that cannot be fooled is called the Miller-Rabin test (Miller 1976; Rabin 1980). This starts from an alternate form of Fermat's Little Theorem, which states that if n is a prime number and a is any positive integer less than n, then a raised to the (n - 1)st power is congruent to 1 modulo n. To test the primality of a number n by the Miller-Rabin test, we pick a random number a<n and raise a to the (n - 1)st power modulo n using the expmod procedure. However, whenever we perform the squaring step in expmod, we check to see if we have discovered a ``nontrivial square root of 1 modulo n,'' that is, a number not equal to 1 or n - 1 whose square is equal to 1 modulo n. It is possible to prove that if such a nontrivial square root of 1 exists, then n is not prime. It is also possible to prove that if n is an odd number that is not prime, then, for at least half the numbers a<n, computing a^(n-1) in this way will reveal a nontrivial square root of 1 modulo n. (This is why the Miller-Rabin test cannot be fooled.) Modify the expmod procedure to signal if it discovers a nontrivial square root of 1, and use this to implement the Miller-Rabin test with a procedure analogous to fermat-test. Check your procedure by testing various known primes and non-primes. Hint: One convenient way to make expmod signal is to have it return 0.
+
+(expmod base exp m)
+(= (expmod a (n-1) n) 1)
+
+;; calculate base^exp modulo m but signal if
+(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))))
blob - /dev/null
blob + 8435f22762a4f7417f9d93b58ddd7fda15be8053 (mode 644)
--- /dev/null
+++ ex1-29.lisp
@@ -0,0 +1,29 @@
+(defun cube (x)
+ (* x x x))
+(defun sum (term a next b)
+ (if (> a b)
+ 0
+ (+ (funcall term a)
+ (sum term (funcall next a) next b))))
+(defun sum-integers (a b)
+ (sum #'identity a #'1+ b))
+(defun pi-sum (a b)
+ (defun pi-term (x)
+ (/ 1.0 (* x (+ x 2))))
+ (defun pi-next (x)
+ (+ x 4))
+ (sum #'pi-term a #'pi-next b))
+(defun integral (f a b dx)
+ (defun add-dx (x)
+ (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) #'add-dx b) dx))
+
+(defun simpson-integral (f a b n)
+ (let ((h (float (/ (- b a) n))))
+ (defun simpson-term (k)
+ (* (funcall f (+ a (* k h)))
+ (cond ((or (= k 0) (= k n)) 1)
+ ((oddp k) 4)
+ (t 2))))
+ (* (/ h 3)
+ (sum #'simpson-term 0 #'1+ n))))
blob - /dev/null
blob + fa34e700a5de8617a07743617d92aecb2319bde4 (mode 644)
--- /dev/null
+++ ex1-29.lisp~
@@ -0,0 +1,19 @@
+(defun cube (x)
+ (* x x x))
+(defun sum (term a next b)
+ (if (> a b)
+ 0
+ (+ (funcall term a)
+ (sum term (funcall next a) next b))))
+(defun sum-integers (a b)
+ (sum #'identity a #'1+ b))
+(defun pi-sum (a b)
+ (defun pi-term (x)
+ (/ 1.0 (* x (+ x 2))))
+ (defun pi-next (x)
+ (+ x 4))
+ (sum #'pi-term a #'pi-next b))
+(defun integral (f a b dx)
+ (defun add-dx (x)
+ (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) #'add-dx b) dx))
blob - /dev/null
blob + 35a7f803e0d3197d31240c0d9d881495b450ee2f (mode 644)
--- /dev/null
+++ ex1-29.scm
@@ -0,0 +1,42 @@
+(define (sum term a next b)
+ (if (> a b)
+ 0
+ (+ (term a)
+ (sum term (next a) next b))))
+
+;; (define (simpsons-rule f a b n)
+;; (let ((h (/ (- b a) n)))
+;; (define (running-sum k)
+;; (let ((akh (+ a (* k h))))
+;; (if (= k n)
+;; (f akh)
+;; (+ (cond ((= k 0) (f akh))
+;; ((even? k) (* 2 (f akh)))
+;; ((odd? k) (* 4 (f akh))))
+;; (running-sum (+ k 1))))))
+;; (* (/ h 3)
+;; (running-sum 0))))
+
+(define (simpsons-rule f a b n)
+ (let ((h (/ (- b a) n)))
+ (define (simpsons-term k)
+ (let ((akh (+ a (* k h))))
+ (* (f akh)
+ (cond ((or (= k 0) (= k n)) 1)
+ ((odd? k) 4)
+ ((even? k) 2)))))
+ (* (/ h 3)
+ (sum simpsons-term 0 1+ n))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (cube x) (* x x x))
+
+(test-case (simpsons-rule cube 0.0 1.0 5) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 10) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 100) 0.25)
+
blob - /dev/null
blob + fe38efd0859d86c6cafa7485d05c88f2373ce963 (mode 644)
--- /dev/null
+++ ex1-29.scm~
@@ -0,0 +1,5 @@
+(define (sum term a next b)
+ (if (> a b)
+ 0
+ (+ (term a)
+ (sum term (next a) next b))))
blob - /dev/null
blob + fc585a7f36da66fc925e8b3c5179829615c5c19d (mode 644)
--- /dev/null
+++ ex1-3.scm
@@ -0,0 +1,12 @@
+(define (square x) (* x x))
+(define (sum-of-squares x y) (+ (square x) (square y)))
+(define (sum-sqr-two-larger x y z)
+ (cond ((and (> x z) (> y z)) (sum-of-squares x y))
+ ((and (> x y) (> z y)) (sum-of-squares x z))
+ (else (sum-of-squares y z))))
+(sum-sqr-two-larger 1 2 3)
+13
+(sum-sqr-two-larger 4 3 9)
+97
+(sum-sqr-two-larger 7 3 1)
+58
blob - /dev/null
blob + 01f13f26243dc6df294a378399c118c93cf63b22 (mode 644)
--- /dev/null
+++ ex1-3.scm~
@@ -0,0 +1,3 @@
+(define (square x) (* x x))
+(define (sum-sqr-two-larger x y z)
+ (cond (> x y z) (square x x)
\ No newline at end of file
blob - /dev/null
blob + c58a4d00e1e0894e2496002ffcf79f4d7b7115e4 (mode 644)
--- /dev/null
+++ ex1-30.lisp
@@ -0,0 +1,7 @@
+(defun sum-iter (term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (+ (funcall term a) result))))
+ (iter a 0))
blob - /dev/null
blob + de556bc211441e0e23d23282cd6e913a6544197c (mode 644)
--- /dev/null
+++ ex1-30.scm
@@ -0,0 +1,24 @@
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (sum term a next b)
+ (define (iter a result)
+ (if (> a b)
+ result
+ (iter (next a) (+ (term a) result))))
+ (iter a 0))
+
+(define (integral f a b dx)
+ (define (add-dx x) (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) add-dx b)
+ dx))
+
+(define (cube x) (* x x x))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+
+(test-case (integral cube 0.0 1.0 0.001) 0.25)
blob - /dev/null
blob + 645bbfe947d3acb9e43998af00fd1ac767e1d27f (mode 644)
--- /dev/null
+++ ex1-30.scm~
@@ -0,0 +1,8 @@
+ Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (sum term a next b)
+ (define (iter a result)
+ (if <??>
+ <??>
+ (iter <??> <??>)))
+ (iter <??> <??>))
blob - /dev/null
blob + ea613e474f25da91e89f1710b41ece8f8cd2f323 (mode 644)
--- /dev/null
+++ ex1-31.lisp
@@ -0,0 +1,28 @@
+(defun product (term a next b)
+ (if (> a b)
+ 1
+ (* (funcall term a)
+ (product term (funcall next a) next b))))
+(defun factorial (n)
+ (product #'identity 1 #'1+ n))
+(defun wallis-pi (n)
+ (defun wallis-term (k)
+ (let ((nom
+ (if (evenp k)
+ (+ k 2)
+ (+ k 1)))
+ (denom
+ (if (evenp k)
+ (+ k 1)
+ (+ k 2))))
+ (float (/ nom denom))))
+ (* (product #'wallis-term 1 #'1+ n)))
+
+(defun product-iter (term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (* (funcall term a) result))))
+ (iter a 1))
+
blob - /dev/null
blob + fa7368935691901ae8f4d45d250c1c98402f1a40 (mode 644)
--- /dev/null
+++ ex1-31.lisp~
@@ -0,0 +1,5 @@
+(defun product (term a next b)
+ (if (> a b)
+ 1
+ (* (funcall term a)
+ (product term (funcall next a) next b))))
blob - /dev/null
blob + 1fdf1a4c261602f09a8defdefbfc40bbc2a536f7 (mode 644)
--- /dev/null
+++ ex1-31.scm
@@ -0,0 +1,57 @@
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (product term a next b)
+ (if (> a b)
+ 1
+ (* (term a)
+ (product term (next a) next b))))
+
+(define (product-iter term a next b)
+ (define (iter i result)
+ (if (> i b)
+ result
+ (iter (next i) (* (term i) result))))
+ (iter a 1))
+
+(define (factorial n)
+ (product (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+(define (factorial-iter n)
+ (product-iter (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+(define (pi iterations)
+ (* 4.0
+ (product (lambda (x)
+ (if (odd? x)
+ (/ (+ x 1) (+ x 2))
+ (/ (+ x 2) (+ x 1))))
+ 1
+ (lambda (x) (+ x 1))
+ iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (factorial 0) 1)
+(test-case (factorial 1) 1)
+(test-case (factorial 2) 2)
+(test-case (factorial 3) 6)
+(test-case (factorial 4) 24)
+(test-case (factorial 5) 120)
+(test-case (factorial 6) 720)
+(test-case (factorial 7) 5040)
+(test-case (factorial-iter 7) 5040)
+
+(test-case (pi 10000) 3.1415)
blob - /dev/null
blob + de556bc211441e0e23d23282cd6e913a6544197c (mode 644)
--- /dev/null
+++ ex1-31.scm~
@@ -0,0 +1,24 @@
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (sum term a next b)
+ (define (iter a result)
+ (if (> a b)
+ result
+ (iter (next a) (+ (term a) result))))
+ (iter a 0))
+
+(define (integral f a b dx)
+ (define (add-dx x) (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) add-dx b)
+ dx))
+
+(define (cube x) (* x x x))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+
+(test-case (integral cube 0.0 1.0 0.001) 0.25)
blob - /dev/null
blob + 97ee188536a74e10815f6f1eda102f2f0c3198ea (mode 644)
--- /dev/null
+++ ex1-32.lisp
@@ -0,0 +1,17 @@
+(defun accumulator (combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (funcall combiner
+ (funcall term a)
+ (accumulator combiner null-value term (funcall next a) next b))))
+(defun sum (term a next b)
+ (accumulator #'+ 0 term a next b))
+(defun accumulator-iter (combiner null-value term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (funcall combiner (funcall term a) result))))
+ (iter a null-value))
+(defun product (term a next b)
+ (accumulator-iter #'* 1 term a next b))
blob - /dev/null
blob + 2cd0140136b89f0690ecaa6c80a47f3cfc57910c (mode 644)
--- /dev/null
+++ ex1-32.lisp~
@@ -0,0 +1,14 @@
+(defun accumulator (combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (funcall combiner
+ (funcall term a)
+ (accumulator combiner null-value term (funcall next a) next b))))
+(defun sum (term a next b)
+ (accumulator #'+ 0 term a next b))
+(defun accumulator-iter (combiner null-value term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (funcall combiner (funcall term a) result))))
blob - /dev/null
blob + 6e14060e6a5ec7f0a4615928a938b39bb54db42f (mode 644)
--- /dev/null
+++ ex1-32.scm
@@ -0,0 +1,79 @@
+;; Exercise 1.32. a. Show that sum and product (exercise 1.31) are both special cases of a still more general notion called accumulate that combines a collection of terms, using some general accumulation function:
+
+;; (accumulate combiner null-value term a next b)
+
+;; Accumulate takes as arguments the same term and range specifications as sum and product, together with a combiner procedure (of two arguments) that specifies how the current term is to be combined with the accumulation of the preceding terms and a null-value that specifies what base value to use when the terms run out. Write accumulate and show how sum and product can both be defined as simple calls to accumulate.
+
+(define (accumulate combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (combiner (term a)
+ (accumulate combiner null-value term (next a) next b))))
+
+(define (sum term a next b)
+ (accumulate + 0 term a next b))
+(define (product term a next b)
+ (accumulate * 1 term a next b))
+
+
+(define (accumulate combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (combiner (term a)
+ (accumulate combiner null-value term (next a) next b))))
+
+;; b. If your accumulate procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (accumulate-iter combiner null-value term a next b)
+ (define (iter i result)
+ (if (> a b)
+ result
+ (iter (next i) (combiner (term i) result))))
+ (iter a null-value))
+
+
+(define (factorial n)
+ (product (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+(define (factorial-iter n)
+ (product-iter (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+(define (pi iterations)
+ (* 4.0
+ (product (lambda (x)
+ (if (odd? x)
+ (/ (+ x 1) (+ x 2))
+ (/ (+ x 2) (+ x 1))))
+ 1
+ (lambda (x) (+ x 1))
+ iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (factorial 0) 1)
+(test-case (factorial 1) 1)
+(test-case (factorial 2) 2)
+(test-case (factorial 3) 6)
+(test-case (factorial 4) 24)
+(test-case (factorial 5) 120)
+(test-case (factorial 6) 720)
+(test-case (factorial 7) 5040)
+(test-case (factorial-iter 7) 5040)
+
+(test-case (pi 10000) 3.1415)
+
+
+
blob - /dev/null
blob + 1fdf1a4c261602f09a8defdefbfc40bbc2a536f7 (mode 644)
--- /dev/null
+++ ex1-32.scm~
@@ -0,0 +1,57 @@
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (product term a next b)
+ (if (> a b)
+ 1
+ (* (term a)
+ (product term (next a) next b))))
+
+(define (product-iter term a next b)
+ (define (iter i result)
+ (if (> i b)
+ result
+ (iter (next i) (* (term i) result))))
+ (iter a 1))
+
+(define (factorial n)
+ (product (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+(define (factorial-iter n)
+ (product-iter (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+(define (pi iterations)
+ (* 4.0
+ (product (lambda (x)
+ (if (odd? x)
+ (/ (+ x 1) (+ x 2))
+ (/ (+ x 2) (+ x 1))))
+ 1
+ (lambda (x) (+ x 1))
+ iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (factorial 0) 1)
+(test-case (factorial 1) 1)
+(test-case (factorial 2) 2)
+(test-case (factorial 3) 6)
+(test-case (factorial 4) 24)
+(test-case (factorial 5) 120)
+(test-case (factorial 6) 720)
+(test-case (factorial 7) 5040)
+(test-case (factorial-iter 7) 5040)
+
+(test-case (pi 10000) 3.1415)
blob - /dev/null
blob + 6d6791eccdf8a79f3566435e272d706ae299e1ca (mode 644)
--- /dev/null
+++ ex1-33.lisp
@@ -0,0 +1,13 @@
+(defun filtered-accumulator (combiner null-value term a next b filter)
+ (cond ((> a b) null-value)
+ ((funcall filter a)
+ (funcall combiner
+ (funcall term a)
+ (filtered-accumulator combiner null-value term (funcall next a) next b filter)))
+ (t (filtered-accumulator combiner null-value term (funcall next a) next b filter))))
+(defun sum-squares-of-primes (a b)
+ (filtered-accumulator #'+ 0 #'square a #'1+ b #'prime?))
+(defun product-of-relatively-prime (n)
+ (defun relatively-prime-to-n? (k)
+ (= (gcd k n) 1))
+ (filtered-accumulator #'* 1 #'identity 1 #'1+ (1- n) #'relatively-prime-to-n?))
blob - /dev/null
blob + f4bab0a3b9742d457ad0cfa9c7a28857d5313dd5 (mode 644)
--- /dev/null
+++ ex1-33.scm
@@ -0,0 +1,127 @@
+;; Exercise 1.33. You can obtain an even more general version of accumulate (exercise 1.32) by introducing the notion of a filter on the terms to be combined. That is, combine only those terms derived from values in the range that satisfy a specified condition. The resulting filtered-accumulate abstraction takes the same arguments as accumulate, together with an additional predicate of one argument that specifies the filter. Write filtered-accumulate as a procedure. Show how to express the following using filtered-accumulate:
+
+
+
+(define (filtered-accumulate combiner filter null-value term a next b)
+ (if (> a b)
+ null-value
+ (if (filter a)
+ (combiner (term a)
+ (filtered-accumulate combiner filter null-value term (next a) next b))
+ (filtered-accumulate combiner filter null-value term (next a) next b))))
+
+(define (sum-prime-squares a b)
+ (filtered-accumulate +
+ prime?
+ 0
+ (lambda (x) (* x x))
+ a
+ 1+
+ b))
+
+(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 (+ test-divisor 1)))))
+
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+(define (prime? n)
+ (= n (smallest-divisor n)))
+
+
+;; (define (accumulate combiner null-value term a next b)
+;; (if (> a b)
+;; null-value
+;; (combiner (term a)
+;; (accumulate combiner null-value term (next a) next b))))
+
+;; (define (sum term a next b)
+;; (accumulate + 0 term a next b))
+;; (define (product term a next b)
+;; (accumulate * 1 term a next b))
+
+
+;; (define (accumulate combiner null-value term a next b)
+;; (if (> a b)
+;; null-value
+;; (combiner (term a)
+;; (accumulate combiner null-value term (next a) next b))))
+
+;; (define (accumulate-iter combiner null-value term a next b)
+;; (define (iter i result)
+;; (if (> a b)
+;; result
+;; (iter (next i) (combiner (term i) result))))
+;; (iter a null-value))
+
+
+;; (define (factorial n)
+;; (product (lambda (x) x)
+;; 1
+;; (lambda (x) (+ x 1))
+;; n))
+
+;; (define (factorial-iter n)
+;; (product-iter (lambda (x) x)
+;; 1
+;; (lambda (x) (+ x 1))
+;; n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+;; (define (pi iterations)
+;; (* 4.0
+;; (product (lambda (x)
+;; (if (odd? x)
+;; (/ (+ x 1) (+ x 2))
+;; (/ (+ x 2) (+ x 1))))
+;; 1
+;; (lambda (x) (+ x 1))
+;; iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (factorial 0) 1)
+;; (test-case (factorial 1) 1)
+;; (test-case (factorial 2) 2)
+;; (test-case (factorial 3) 6)
+;; (test-case (factorial 4) 24)
+;; (test-case (factorial 5) 120)
+;; (test-case (factorial 6) 720)
+;; (test-case (factorial 7) 5040)
+;; (test-case (factorial-iter 7) 5040)
+
+;; (test-case (pi 10000) 3.1415)
+
+;; a. the sum of the squares of the prime numbers in the interval a to b (assuming that you have a prime? predicate already written)
+
+;; b. the product of all the positive integers less than n that are relatively prime to n (i.e., all positive integers i < n such that GCD(i,n) = 1).
+
+(test-case (sum-prime-squares 2 17) 666)
+
+(define (relatively-prime-product n)
+ (filtered-accumulate *
+ (lambda (i)
+ (= (gcd i n) 1))
+ 1
+ (lambda (x) x)
+ 1
+ 1+
+ n))
+
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+
+(test-case (relatively-prime-product 20) 8729721)
blob - /dev/null
blob + 97ee188536a74e10815f6f1eda102f2f0c3198ea (mode 644)
--- /dev/null
+++ ex1-33.scm~
@@ -0,0 +1,17 @@
+(defun accumulator (combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (funcall combiner
+ (funcall term a)
+ (accumulator combiner null-value term (funcall next a) next b))))
+(defun sum (term a next b)
+ (accumulator #'+ 0 term a next b))
+(defun accumulator-iter (combiner null-value term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (funcall combiner (funcall term a) result))))
+ (iter a null-value))
+(defun product (term a next b)
+ (accumulator-iter #'* 1 term a next b))
blob - /dev/null
blob + ec35417c12921263d227548fd3ce0b18cb763be6 (mode 644)
--- /dev/null
+++ ex1-34.lisp
@@ -0,0 +1,42 @@
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(fixed-point (lambda (x) (1+ (/1 x))) 1.0)
+
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (format t "Trying ~F~%" guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun xx (x)
+ (/ (log 1000) (log x)))
+(defun dampen-xx (x)
+ (average x (xx x)))
+(print (fixed-point #'xx 2.0))
+(print (fixed-point #'dampen-xx 2.0))
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 66b3fb497a0079f0b8576791296bbe12d261a52d (mode 644)
--- /dev/null
+++ ex1-35.scm
@@ -0,0 +1,52 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(fixed-point (lambda (y) (+ (sin y) (cos y)))
+ 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+ 1.0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
blob - /dev/null
blob + cf922fe928abfc632d3128b02a7cba490778e0ef (mode 644)
--- /dev/null
+++ ex1-35.scm~
@@ -0,0 +1,10 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
blob - /dev/null
blob + 7ebd215ce1359ff0e0cbba33ebb65284cf2cc56b (mode 644)
--- /dev/null
+++ ex1-36.scm
@@ -0,0 +1,76 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (display guess)
+ (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ (begin (display next)
+ next)
+ (try next))))
+ (newline)
+ (try first-guess))
+
+(fixed-point (lambda (y) (+ (sin y) (cos y)))
+ 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+ 1.0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(newline)
+(newline)
+(display "Finding solution to x^x = 1000 without average damping:")
+(fixed-point (lambda (x) (/ (log 1000) (log x)))
+ 2.0)
+;; 35 iterations
+
+(newline)
+(display "Finding solution to x^x = 1000 with average damping:")
+(fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+ 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
blob - /dev/null
blob + 66b3fb497a0079f0b8576791296bbe12d261a52d (mode 644)
--- /dev/null
+++ ex1-36.scm~
@@ -0,0 +1,52 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(fixed-point (lambda (y) (+ (sin y) (cos y)))
+ 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+ 1.0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
blob - /dev/null
blob + 7223eb4a3b54a0fdd2361079edee081f1191bf63 (mode 644)
--- /dev/null
+++ ex1-37.lisp
@@ -0,0 +1,20 @@
+(defun cont-frac (n d k)
+ (labels (
+ (frac (i)
+ (/ (funcall n i)
+ (+ (funcall d i)
+ (if (= i k)
+ 0
+ (frac (1+ i)))))))
+ (frac 1)))
+
+(defun cont-frac-iter (n d k)
+ (labels (
+ (frac-iter (i result)
+ (if (= i 0)
+ result
+ (frac-iter
+ (1- i)
+ (/ (funcall n i)
+ (+ (funcall d i) result))))))
+ (frac-iter k 0)))
blob - /dev/null
blob + ec35417c12921263d227548fd3ce0b18cb763be6 (mode 644)
--- /dev/null
+++ ex1-37.lisp~
@@ -0,0 +1,42 @@
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(fixed-point (lambda (x) (1+ (/1 x))) 1.0)
+
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (format t "Trying ~F~%" guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun xx (x)
+ (/ (log 1000) (log x)))
+(defun dampen-xx (x)
+ (average x (xx x)))
+(print (fixed-point #'xx 2.0))
+(print (fixed-point #'dampen-xx 2.0))
+
blob - /dev/null
blob + e2e8083ca0e163e28d6a53b0119455dffd11fa9c (mode 644)
--- /dev/null
+++ ex1-37.scm
@@ -0,0 +1,129 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+;; (display guess)
+;; (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+;; (begin (display next)
+;; next)
+ next
+ (try next))))
+;; (newline)
+ (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+(define (cont-frac n d k)
+ (define (cont-frac-rec i)
+ (if (> i k)
+ 0
+ (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+ (cont-frac-rec 1))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (/ d i) result)))))
+ (iter k 0))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
blob - /dev/null
blob + 6e8fa11eae398e2d0afd8f9c41cd12037fcd0f91 (mode 644)
--- /dev/null
+++ ex1-37.scm~
@@ -0,0 +1,107 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+;; (display guess)
+;; (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+;; (begin (display next)
+;; next)
+ next
+ (try next))))
+;; (newline)
+ (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+(define (cont-frac n d k)
+ (define (cont-frac-rec i)
+ (if (> i k)
+ 0
+ (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+ (cont-frac-rec 1))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
blob - /dev/null
blob + 7358a18473fba6b72532106b8579dccdc601bbf1 (mode 644)
--- /dev/null
+++ ex1-38.lisp
@@ -0,0 +1,30 @@
+(defun cont-frac (n d k)
+ (labels (
+ (frac (i)
+ (/ (funcall n i)
+ (+ (funcall d i)
+ (if (= i k)
+ 0
+ (frac (1+ i)))))))
+ (frac 1)))
+
+(defun cont-frac-iter (n d k)
+ (labels (
+ (frac-iter (i result)
+ (if (= i 0)
+ result
+ (frac-iter
+ (1- i)
+ (/ (funcall n i)
+ (+ (funcall d i) result))))))
+ (frac-iter k 0)))
+
+(print
+ (cont-frac
+ (lambda (i) 1.0)
+ (lambda (i)
+ (let ((i+1 (1+ i)))
+ (if (= (rem i+1 3) 0)
+ (* 2.0 (/ i+1 3))
+ 1.0)))
+ 10))
blob - /dev/null
blob + 7223eb4a3b54a0fdd2361079edee081f1191bf63 (mode 644)
--- /dev/null
+++ ex1-38.lisp~
@@ -0,0 +1,20 @@
+(defun cont-frac (n d k)
+ (labels (
+ (frac (i)
+ (/ (funcall n i)
+ (+ (funcall d i)
+ (if (= i k)
+ 0
+ (frac (1+ i)))))))
+ (frac 1)))
+
+(defun cont-frac-iter (n d k)
+ (labels (
+ (frac-iter (i result)
+ (if (= i 0)
+ result
+ (frac-iter
+ (1- i)
+ (/ (funcall n i)
+ (+ (funcall d i) result))))))
+ (frac-iter k 0)))
blob - /dev/null
blob + cf404b921f1f631c2e06b66fe45f8e74ed380639 (mode 644)
--- /dev/null
+++ ex1-38.scm
@@ -0,0 +1,125 @@
+;; (define (search f neg-point pos-point)
+;; (let ((midpoint (average neg-point pos-point)))
+;; (if (close-enough? neg-point pos-point)
+;; midpoint
+;; (let ((test-value (f midpoint)))
+;; (cond ((positive? test-value)
+;; (search f neg-point midpoint))
+;; ((negative? test-value)
+;; (search f midpoint pos-point))
+;; (else midpoint))))))
+;; (define (close-enough? x y)
+;; (< (abs (- x y)) 0.001))
+
+;; (define (half-interval-method f a b)
+;; (let ((a-value (f a))
+;; (b-value (f b)))
+;; (cond ((and (negative? a-value) (positive? b-value))
+;; (search f a b))
+;; ((and (negative? b-value) (positive? a-value))
+;; (search f b a))
+;; (else
+;; (error "Values are not of opposite sign" a b)))))
+;; (define tolerance 0.00001)
+
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; ;; (display guess)
+;; ;; (newline)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; ;; (begin (display next)
+;; ;; next)
+;; next
+;; (try next))))
+;; ;; (newline)
+;; (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+;; (define (sqrt x)
+;; (fixed-point (lambda (y) (average y (/ x y)))
+;; 1.0))
+
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+;; (define (cont-frac n d k)
+;; (define (cont-frac-rec i)
+;; (if (> i k)
+;; 0
+;; (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+;; (cont-frac-rec 1))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 10)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 100)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (d i) result)))))
+ (iter k 0.0))
+
+;; (test-case (cont-frac-iter (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (+ 2.0
+ (cont-frac-iter (lambda (i) 1)
+ (lambda (i) (if (= (remainder i 3) 2)
+ (* (/ (+ i 1) 3) 2)
+ 1))
+ 100))
+ 2.7182818284590452353602874)
blob - /dev/null
blob + e2e8083ca0e163e28d6a53b0119455dffd11fa9c (mode 644)
--- /dev/null
+++ ex1-38.scm~
@@ -0,0 +1,129 @@
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+;; (display guess)
+;; (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+;; (begin (display next)
+;; next)
+ next
+ (try next))))
+;; (newline)
+ (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+(define (cont-frac n d k)
+ (define (cont-frac-rec i)
+ (if (> i k)
+ 0
+ (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+ (cont-frac-rec 1))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (/ d i) result)))))
+ (iter k 0))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
blob - /dev/null
blob + 38125855630f30522854beadf0e0aba07bf3ccdf (mode 644)
--- /dev/null
+++ ex1-39.lisp
@@ -0,0 +1,10 @@
+(defun tan-cf (x k)
+ (labels ((tan-step (i)
+ (/ (if (= i 1)
+ x
+ (square x))
+ (- (1- (* i 2))
+ (if (= i k)
+ 0
+ (tan-step (1+ i)))))))
+ (tan-step 1)))
blob - /dev/null
blob + 4b16181231413245c54ee9a225eb004453463aa9 (mode 644)
--- /dev/null
+++ ex1-39.lisp~
@@ -0,0 +1,5 @@
+(defun tan-cf (x k)
+ (labels ((tan-step (i)
+ (/ (if (= i 1)
+ x
+ (s
blob - /dev/null
blob + 5a59e1c70c3246ae75b76af91300d555116831a6 (mode 644)
--- /dev/null
+++ ex1-39.scm
@@ -0,0 +1,144 @@
+;; (define (search f neg-point pos-point)
+;; (let ((midpoint (average neg-point pos-point)))
+;; (if (close-enough? neg-point pos-point)
+;; midpoint
+;; (let ((test-value (f midpoint)))
+;; (cond ((positive? test-value)
+;; (search f neg-point midpoint))
+;; ((negative? test-value)
+;; (search f midpoint pos-point))
+;; (else midpoint))))))
+;; (define (close-enough? x y)
+;; (< (abs (- x y)) 0.001))
+
+;; (define (half-interval-method f a b)
+;; (let ((a-value (f a))
+;; (b-value (f b)))
+;; (cond ((and (negative? a-value) (positive? b-value))
+;; (search f a b))
+;; ((and (negative? b-value) (positive? a-value))
+;; (search f b a))
+;; (else
+;; (error "Values are not of opposite sign" a b)))))
+;; (define tolerance 0.00001)
+
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; ;; (display guess)
+;; ;; (newline)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; ;; (begin (display next)
+;; ;; next)
+;; next
+;; (try next))))
+;; ;; (newline)
+;; (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+;; (define (sqrt x)
+;; (fixed-point (lambda (y) (average y (/ x y)))
+;; 1.0))
+
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+;; (define (cont-frac n d k)
+;; (define (cont-frac-rec i)
+;; (if (> i k)
+;; 0
+;; (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+;; (cont-frac-rec 1))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 10)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 100)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (d i) result)))))
+ (iter k 0.0))
+
+;; (test-case (cont-frac-iter (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (+ 2.0
+ (cont-frac-iter (lambda (i) 1)
+ (lambda (i) (if (= (remainder i 3) 2)
+ (* (/ (+ i 1) 3) 2)
+ 1))
+ 100))
+ 2.7182818284590452353602874)
+
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define (square x) (* x x))
+
+(define (tan-cf x k)
+ (cont-frac-iter (lambda (i)
+ (if (= i 1)
+ x
+ (- (square x))))
+ (lambda (i) (- (* 2 i) 1))
+ k))
+
+(test-case (tan-cf 3.5 1000) 0.37458564015)
+(test-case (tan-cf 1.6 1000) -34.2325327)
+(test-case (tan-cf 2.8 1000) -0.355529832)
+
blob - /dev/null
blob + cf404b921f1f631c2e06b66fe45f8e74ed380639 (mode 644)
--- /dev/null
+++ ex1-39.scm~
@@ -0,0 +1,125 @@
+;; (define (search f neg-point pos-point)
+;; (let ((midpoint (average neg-point pos-point)))
+;; (if (close-enough? neg-point pos-point)
+;; midpoint
+;; (let ((test-value (f midpoint)))
+;; (cond ((positive? test-value)
+;; (search f neg-point midpoint))
+;; ((negative? test-value)
+;; (search f midpoint pos-point))
+;; (else midpoint))))))
+;; (define (close-enough? x y)
+;; (< (abs (- x y)) 0.001))
+
+;; (define (half-interval-method f a b)
+;; (let ((a-value (f a))
+;; (b-value (f b)))
+;; (cond ((and (negative? a-value) (positive? b-value))
+;; (search f a b))
+;; ((and (negative? b-value) (positive? a-value))
+;; (search f b a))
+;; (else
+;; (error "Values are not of opposite sign" a b)))))
+;; (define tolerance 0.00001)
+
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; ;; (display guess)
+;; ;; (newline)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; ;; (begin (display next)
+;; ;; next)
+;; next
+;; (try next))))
+;; ;; (newline)
+;; (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+;; (define (sqrt x)
+;; (fixed-point (lambda (y) (average y (/ x y)))
+;; 1.0))
+
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+;; (define (cont-frac n d k)
+;; (define (cont-frac-rec i)
+;; (if (> i k)
+;; 0
+;; (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+;; (cont-frac-rec 1))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 10)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 100)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (d i) result)))))
+ (iter k 0.0))
+
+;; (test-case (cont-frac-iter (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (+ 2.0
+ (cont-frac-iter (lambda (i) 1)
+ (lambda (i) (if (= (remainder i 3) 2)
+ (* (/ (+ i 1) 3) 2)
+ 1))
+ 100))
+ 2.7182818284590452353602874)
blob - /dev/null
blob + a1f409fc061ad62acdd8587a99f3cc1f4549f662 (mode 644)
--- /dev/null
+++ ex1-4.scm
@@ -0,0 +1,2 @@
+(define (a-plus-abs-b a b)
+ ((if (> b 0) + -) a b))
\ No newline at end of file
blob - /dev/null
blob + ce21fed2cfd23c4802173768d0405c9701405b8d (mode 644)
--- /dev/null
+++ ex1-40.lisp
@@ -0,0 +1,30 @@
+(defvar *tolerance* 0.0001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defvar *dx* 0.00001)
+(defun deriv (g)
+ (lambda (x)
+ (/ (- (funcall g (+ x *dx*))
+ (funcall g x))
+ *dx*)))
+(defun newton-transform (g)
+ (lambda (x)
+ (- x (/ (funcall g x)
+ (funcall (deriv g) x)))))
+(defun newtons-method (g guess)
+ (fixed-point (newton-transform g) guess))
+
+(defun cubic (a b c)
+ (lambda (x)
+ (+ (cube x)
+ (* a (square x))
+ (* b x)
+ c)))
blob - /dev/null
blob + 8850ce7e945d0e7edf6f33966264e8cdafc617a9 (mode 644)
--- /dev/null
+++ ex1-40.lisp~
@@ -0,0 +1,21 @@
+(defvar *tolerance* 0.0001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defvar *dx* 0.00001)
+(defun deriv (g)
+ (lambda (x)
+ (/ (- (funcall g (+ x *dx*))
+ (funcall g x))
+ *dx*)))
+(defun newton-transform (g)
+ (lambda (x)
+ (- x (/ (funcall g x)
+ (funcall (deriv g) x)))))
blob - /dev/null
blob + e58f4a50e59c2d7ae83155648d4382b5d214c5c4 (mode 644)
--- /dev/null
+++ ex1-40.scm
@@ -0,0 +1,53 @@
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (sqrt x)
+ (fixed-point (average-damp (lambda (y) (/ x y)))
+ 1.0))
+(define (cube-root x)
+ (fixed-point (average-damp (lambda (y) (/ x (square y))))
+ 1.0))
+(define (deriv g)
+ (lambda (x)
+ (/ (- (g (+ x dx)) (g x))
+ dx)))
+(define dx 0.00001)
+(define (newton-transform g)
+ (lambda (x)
+ (- x (/ (g x) ((deriv g) x)))))
+(define (newtons-method g guess)
+ (fixed-point (newton-transform g) guess))
+(define (sqrt x)
+ (newtons-method (lambda (y) (- (square y) x))
+ 1.0))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (- (square y) x))
+ newton-transform
+ 1.0))
+(define (cubic a b c)
+ (define (cube x) (* x x x))
+ (define (square x) (* x x))
+ (lambda (x)
+ (+ (cube x)
+ (* a (square x))
+ (* b x)
+ c)))
+
+(test-case (newtons-method (cubic 5 2 3) 1.0) -4.710623963172891)
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 432bde021c6c855155a7953ed02eb5373b38f95a (mode 644)
--- /dev/null
+++ ex1-41.scm
@@ -0,0 +1,62 @@
+(define (double p)
+ (lambda (x)
+ (p (p x))))
+
+;; What value is returned by
+
+;; (((double (double double)) inc) 5)
+nn
+(((double (double double)) inc) 5)
+(((double (lambda (x)
+ (double (double x)))) inc) 5)
+(((lambda (y)
+ ((lambda (x)
+ (double (double x)))
+ ((lambda (x)
+ (double (double x))) y))) inc) 5)
+(((lambda (y)
+ ((lambda (x)
+ (double (double x)))
+ ((lambda (x)
+ (double (double x))) y))) inc) 5)
+(((lambda (x)
+ (double (double x)))
+ ((lambda (x)
+ (double (double x))) inc)) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (double inc)))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (double inc)))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (lambda (x)
+ (inc (inc x)))))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (lambda (x)
+ (inc (inc x)))))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (lambda (x)
+ (inc (inc x)))))) 5)
+
+;; Suppose we defined the procedure below as dd
+;;(lambda (x)
+;; (double (double x)))
+(((lambda (x)
+ (dd (dd x))) inc) 5)
+
+(((dd (dd inc))) 5)
+(((dd (double (double inc)))) 5)
+(((dd (double (lambda (x)
+ (inc (inc x)))))) 5)
+(((dd ((lambda (x)
+ (inc (inc x)))
+ ((lambda (x)
+ (inc (inc x))) x)))) 5)
+((((double (double ((lambda (x)
+ (inc (inc x)))
+ ((lambda (x)
+ (inc (inc x))) x)))))) 5)
blob - /dev/null
blob + f83c55b56c70f92a14b9bd341f441460e22407ae (mode 644)
--- /dev/null
+++ ex1-41.scm~
@@ -0,0 +1,3 @@
+(define (double procedure)
+ (lambda (x)
+ (procedure (procedure (x)))))
blob - /dev/null
blob + c574b975b9b2eecaa8237f762c532bdcb2c00464 (mode 644)
--- /dev/null
+++ ex1-42.lisp
@@ -0,0 +1,3 @@
+(defun compose (f g)
+ (lambda (x)
+ (funcall f (funcall g x))))
blob - /dev/null
blob + eae85f45a07e2b211b43bea30c4714232aa8462b (mode 644)
--- /dev/null
+++ ex1-42.scm
@@ -0,0 +1,12 @@
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+(test-case ((compose square inc) 6) 49)
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 84f64d2a20d961eb2df5845bdbd7fc75648fe724 (mode 644)
--- /dev/null
+++ ex1-43.lisp
@@ -0,0 +1,4 @@
+(defun repeated (f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (1- n)))))
blob - /dev/null
blob + c78b1c3279baf11e473f4fdabba3b226a62ac708 (mode 644)
--- /dev/null
+++ ex1-43.scm
@@ -0,0 +1,60 @@
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+(test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
blob - /dev/null
blob + c78b1c3279baf11e473f4fdabba3b226a62ac708 (mode 644)
--- /dev/null
+++ ex1-43.scm~
@@ -0,0 +1,60 @@
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+(test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
blob - /dev/null
blob + 31f64f7481a7bd09a019fb2af7737f8d22fb43d8 (mode 644)
--- /dev/null
+++ ex1-44.lisp
@@ -0,0 +1,9 @@
+(defvar *dx* 0.00001)
+(defun smooth (f)
+ (lambda (x)
+ (/ (+ (funcall f (- x *db*))
+ (funcall f x)
+ (funcall f (+ x *dx*)))
+ 3)))
+(defun n-fold-smooth (f n)
+ (funcall (repeated #'smooth n) f))
blob - /dev/null
blob + c78b1c3279baf11e473f4fdabba3b226a62ac708 (mode 644)
--- /dev/null
+++ ex1-44.scm
@@ -0,0 +1,60 @@
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+(test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
blob - /dev/null
blob + 62c895539eec4b4526ac88c9a8a0e5293128beb5 (mode 644)
--- /dev/null
+++ ex1-45.lisp
@@ -0,0 +1,31 @@
+(defvar *tolerance* 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(defun dampen-root (x n)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x (expt y (1- n)))))
+ 1.0))
+(defun repeated-dampen-root (x nroot nrepeat)
+ (fixed-point-of-transform
+ (lambda (y) (average y (/ x (expt y (1- nroot)))))
+ (repeated #'average-damp nrepeat)
+ 1.0))
+(print (repeated-dampen-root 2 4 2))
blob - /dev/null
blob + 8cb3ff3f77925e684642410914fea467a9de5ab8 (mode 644)
--- /dev/null
+++ ex1-45.lisp~
@@ -0,0 +1,25 @@
+(defvar *tolerance* 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(defun dampen-root (x n)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x (expt y (1- n)))))
+ 1.0))
blob - /dev/null
blob + 99e0938288f6fbc1965db100378bfc68ae345df7 (mode 644)
--- /dev/null
+++ ex1-45.scm
@@ -0,0 +1,154 @@
+;; (define tolerance 0.0000001)
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; next
+;; (try next))))
+;; (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+;; (define (average-damp f)
+;; (lambda (x) (average x (f x))))
+;; (define (fixed-point-of-transform g transform guess)
+;; (fixed-point (transform g) guess))
+;; (define (sqrt x)
+;; (fixed-point-of-transform (lambda (y) (/ x y))
+;; average-damp
+;; 1.0))
+;; (define (cube-root x)
+;; (fixed-point-of-transform (lambda (y) (/ x (square y)))
+;; average-damp
+;; 1.0))
+
+;; (define (compose f g)
+;; (lambda (x)
+;; (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+;; (define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+;; (define (repeated f n)
+;; (if (= n 0)
+;; (lambda (x) x)
+;; (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+;; (test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+;; (define dx 0.01)
+
+;; (define (smooth f)
+;; (lambda (x)
+;; (/ (+ (f x)
+;; (f (+ x dx))
+;; (f (- x dx)))
+;; 3.0)))
+;; (define (n-fold-smooth f n)
+;; ((repeated smooth n) f))
+
+;; Exercise 1.45. We saw in section 1.3.3 that attempting to compute square roots by naively finding a fixed point of y x/y does not converge, and that this can be fixed by average damping. The same method works for finding cube roots as fixed points of the average-damped y x/y2. Unfortunately, the process does not work for fourth roots -- a single average damp is not enough to make a fixed-point search for y x/y3 converge. On the other hand, if we average damp twice (i.e., use the average damp of the average damp of y x/y3) the fixed-point search does converge. Do some experiments to determine how many average damps are required to compute nth roots as a fixed-point search based upon repeated average damping of y x/yn-1. Use this to implement a simple procedure for computing nth roots using fixed-point, average-damp, and the repeated procedure of exercise 1.43. Assume that any arithmetic operations you need are available as primitives.
+
+;; (define (fast-expt b n)
+;; (cond ((= n 0) 1)
+;; ((even? n) (square (fast-expt b (/ n 2))))
+;; (else (* b (fast-expt b (- n 1))))))
+
+
+;; (define (quartic-root x)
+;; (fixed-point-of-transform (lambda (y) (/ x (cube y)))
+;; (repeated average-damp 2)
+;; 1.0))
+;; (define (nth-root-test x n d)
+;; (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+;; (repeated average-damp d)
+;; 1.0))
+
+;; (test-case (nth-root-test 19 1 0) 19)
+;; (test-case (nth-root-test 19 2 1) 4.35889894)
+;; (test-case (nth-root-test 19 3 1) 2.66840165)
+;; (test-case (nth-root-test 19 4 2) 2.08779763)
+;; (test-case (nth-root-test 19 5 2) 1.80198313)
+;; (test-case (nth-root-test 19 6 2) 1.6335243)
+;; (test-case (nth-root-test 199 7 2) 2.13013723)
+;; (test-case (nth-root-test 199 8 3) 1.93801277)
+;; (test-case (nth-root-test 199 9 3) 1.80064508)
+;; (test-case (nth-root-test 199 10 3) 1.69779522)
+;; (test-case (nth-root-test 19999 11 3) 2.46037187)
+;; (test-case (nth-root-test 19999 12 3) 2.28253453)
+;; (test-case (nth-root-test 19999 13 3) 2.14213477)
+;; (test-case (nth-root-test 19999 14 3) 2.02868621)
+;; (test-case (nth-root-test 19999 15 3) 1.93523578)
+;; (test-case (nth-root-test 1999999 16 4) 2.47636331)
+;; (test-case (nth-root-test 1999999 17 4) 2.34773357)
+
+
+;; At first, my conclusion: average damp = sqrt(n), rounded down -- EXCEPT for 8...why is that?
+;; Maybe: 2^average damp = n
+
+;; (define (nth-root x n)
+;; (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+;; (repeated average-damp (truncate (/ (log n) (log 2))))
+;; 1.0))
+
+;; (test-case (nth-root 19 1) 19)
+;; (test-case (nth-root 19 2) 4.35889894)
+;; (test-case (nth-root 19 3) 2.66840165)
+;; (test-case (nth-root 19 4) 2.08779763)
+;; (test-case (nth-root 19 5) 1.80198313)
+;; (test-case (nth-root 19 6) 1.6335243)
+;; (test-case (nth-root 199 7) 2.13013723)
+;; (test-case (nth-root 199 8) 1.93801277)
+;; (test-case (nth-root 199 9) 1.80064508)
+;; (test-case (nth-root 199 10) 1.69779522)
+;; (test-case (nth-root 19999 11) 2.46037187)
+;; (test-case (nth-root 19999 12) 2.28253453)
+;; (test-case (nth-root 19999 13) 2.14213477)
+;; (test-case (nth-root 19999 14) 2.02868621)
+;; (test-case (nth-root 19999 15) 1.93523578)
+;; (test-case (nth-root 1999999 16) 2.47636331)
+;; (test-case (nth-root 1999999 17) 2.34773357)
+
+;; Exercise 1.46. Several of the numerical methods described in this chapter are instances of an extremely general computational strategy known as iterative improvement. Iterative improvement says that, to compute something, we start with an initial guess for the answer, test if the guess is good enough, and otherwise improve the guess and continue the process using the improved guess as the new guess. Write a procedure iterative-improve that takes two procedures as arguments: a method for telling whether a guess is good enough and a method for improving a guess. Iterative-improve should return as its value a procedure that takes a guess as argument and keeps improving the guess until it is good enough. Rewrite the sqrt procedure of section 1.1.7 and the fixed-point procedure of section 1.3.3 in terms of iterative-improve.
+
+(define (iterative-improve good-enough? improve)
+ (define (iter guess)
+ (if (good-enough? guess)
+ guess
+ (iter (improve guess))))
+ iter)
+
+(define (sqrt guess x)
+ ((iterative-improve (lambda (guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (lambda (guess)
+ (average guess (/ x guess)))) guess))
+
+
+(test-case (sqrt 2.2 5) 2.23606798)
+
+(define (fixed-point f guess)
+ (let ((tolerance 0.0000001))
+ ((iterative-improve (lambda (guess)
+ (< (abs (- guess (f guess))) tolerance))
+ (lambda (guess)
+ (f guess))) guess)))
+
+(test-case (fixed-point (lambda (x)
+ (cos x))
+ 1)
+ 0.73956720221)
+
+
blob - /dev/null
blob + 967fe8e0ab02e44187d9ad1d041398d2ee353cad (mode 644)
--- /dev/null
+++ ex1-45.scm~
@@ -0,0 +1,122 @@
+(define tolerance 0.0000001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+;; (test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
+
+;; Exercise 1.45. We saw in section 1.3.3 that attempting to compute square roots by naively finding a fixed point of y x/y does not converge, and that this can be fixed by average damping. The same method works for finding cube roots as fixed points of the average-damped y x/y2. Unfortunately, the process does not work for fourth roots -- a single average damp is not enough to make a fixed-point search for y x/y3 converge. On the other hand, if we average damp twice (i.e., use the average damp of the average damp of y x/y3) the fixed-point search does converge. Do some experiments to determine how many average damps are required to compute nth roots as a fixed-point search based upon repeated average damping of y x/yn-1. Use this to implement a simple procedure for computing nth roots using fixed-point, average-damp, and the repeated procedure of exercise 1.43. Assume that any arithmetic operations you need are available as primitives.
+
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+
+
+(define (quartic-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (cube y)))
+ (repeated average-damp 2)
+ 1.0))
+(define (nth-root-test x n d)
+ (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+ (repeated average-damp d)
+ 1.0))
+
+;; (test-case (nth-root-test 19 1 0) 19)
+;; (test-case (nth-root-test 19 2 1) 4.35889894)
+;; (test-case (nth-root-test 19 3 1) 2.66840165)
+;; (test-case (nth-root-test 19 4 2) 2.08779763)
+;; (test-case (nth-root-test 19 5 2) 1.80198313)
+;; (test-case (nth-root-test 19 6 2) 1.6335243)
+;; (test-case (nth-root-test 199 7 2) 2.13013723)
+;; (test-case (nth-root-test 199 8 3) 1.93801277)
+;; (test-case (nth-root-test 199 9 3) 1.80064508)
+;; (test-case (nth-root-test 199 10 3) 1.69779522)
+;; (test-case (nth-root-test 19999 11 3) 2.46037187)
+;; (test-case (nth-root-test 19999 12 3) 2.28253453)
+;; (test-case (nth-root-test 19999 13 3) 2.14213477)
+;; (test-case (nth-root-test 19999 14 3) 2.02868621)
+;; (test-case (nth-root-test 19999 15 3) 1.93523578)
+;; (test-case (nth-root-test 1999999 16 4) 2.47636331)
+;; (test-case (nth-root-test 1999999 17 4) 2.34773357)
+
+
+;; At first, my conclusion: average damp = sqrt(n), rounded down -- EXCEPT for 8...why is that?
+;; Maybe: 2^average damp = n
+
+(define (nth-root x n)
+ (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+ (repeated average-damp (truncate (/ (log n) (log 2))))
+ 1.0))
+
+(test-case (nth-root 19 1) 19)
+(test-case (nth-root 19 2) 4.35889894)
+(test-case (nth-root 19 3) 2.66840165)
+(test-case (nth-root 19 4) 2.08779763)
+(test-case (nth-root 19 5) 1.80198313)
+(test-case (nth-root 19 6) 1.6335243)
+(test-case (nth-root 199 7) 2.13013723)
+(test-case (nth-root 199 8) 1.93801277)
+(test-case (nth-root 199 9) 1.80064508)
+(test-case (nth-root 199 10) 1.69779522)
+(test-case (nth-root 19999 11) 2.46037187)
+(test-case (nth-root 19999 12) 2.28253453)
+(test-case (nth-root 19999 13) 2.14213477)
+(test-case (nth-root 19999 14) 2.02868621)
+(test-case (nth-root 19999 15) 1.93523578)
+(test-case (nth-root 1999999 16) 2.47636331)
+(test-case (nth-root 1999999 17) 2.34773357)
blob - /dev/null
blob + 47ef38cd6553257f2844d7a532fbbd0595e1653c (mode 644)
--- /dev/null
+++ ex1-46.lisp
@@ -0,0 +1,6 @@
+(defun iterative-improve (good-enough? improve)
+ (lambda (first-guess)
+ (labels (
+ (improve-iter (guess)
+ (let ((improved-guess (funcall improve guess)))
+ (if
blob - /dev/null
blob + f161311325a090286a57f052c1cc482fd9390258 (mode 644)
--- /dev/null
+++ ex1-46.lisp~
@@ -0,0 +1,5 @@
+(defun iterative-improve (good-enough? improve)
+ (lambda (first-guess)
+ (labels (
+ (improve-iter (guess)
+
blob - /dev/null
blob + e10c468f38b75cbeecff2c4c454ca55fe56276c1 (mode 644)
--- /dev/null
+++ ex1-5.scm
@@ -0,0 +1,14 @@
+(define (p) (p))
+(define (text x y)
+ (if (= x 0)
+ 0
+ y))
+(test 0 (p))
+
+Applicative order will go into an infinite loop when trying to evaluate the operand (p)
+Normal-order will evaluate it as:
+
+(if (= 0 0)
+ 0
+ (p))
+0
\ No newline at end of file
blob - /dev/null
blob + 1c19ac8553bb86c329e227990e6188ab229c690b (mode 644)
--- /dev/null
+++ ex1-6.scm
@@ -0,0 +1,9 @@
+(define (new-if predicate then-clause else-clause)
+ (cond (predicate then-clause)
+ (else else-clause)))
+(define (sqrt-iter guess x)
+ (new-if (good-enough? guess x)
+ guess
+ (sqrt-iter (improve guess x)
+ x)))
+According to the general evaluation rule, all sub-expressions must be evaluated (the scheme interpreter follow applicative-order evaluation). The problem is that for sqrt-iter is that the 3rd expression that it passes to new-if is recursive. So, the interpreter will attempt to evaluate the 3rd sub-expression an never terminate. It ends up getting stuck in an infinite recursion. The reason the if-special form must be provided is so that the else-clause is never evaluated if the predicate evaluates to true. The "short-circuit"-ing behavior is necessary to avoid infinite recursion.
\ No newline at end of file
blob - /dev/null
blob + a70fb695277315e866b25ed390871b9aea935e73 (mode 644)
--- /dev/null
+++ ex1-6.scm~
@@ -0,0 +1,3 @@
+(define (new-if predicate then-clause else-clause)
+ (cond (predicate then-clause)
+ (else else-clause)))
blob - /dev/null
blob + 83852b93b98b3a6d16d642eb5b77a84e13c70082 (mode 644)
--- /dev/null
+++ ex1-7.scm
@@ -0,0 +1,41 @@
+;; (define (sqrt x)
+;; (sqrt-iter 1.0 x))
+;; (define (sqrt-iter guess x)
+;; (if (good-enough? guess x)
+;; guess
+;; (sqrt-iter (improve guess x) x)))
+;; (define (good-enough? guess x)
+;; (< (abs (- (square guess) x)) 0.001))
+;; (define (square x) (* x x))
+;; (define (improve guess x)
+;; (average guess (/ x guess)))
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+;; (sqrt 0.001)
+;; 0.0316227766
+;; error is quite large
+;; for small numbers, the reason is simply because the sqrt is too close to the tolerance of 0.001
+
+;; (sqrt 1234567890123456789012345678901234567890)
+
+;; for large numbers, a number must be expressed as a float. A float is made up of a mantissa and exponent. As the exponent gets larger, the difference between each quantum of allowed floating point gets bigger and bigger. Unfortunately, this means that (improve guess x) might give the same result each time, even though (good-enough? guess x) keeps returning #f. So, with each iteration, the guess does not get any more accurate and hence the recursive process is never able to terminate. We end up with infinite recursion.
+
+(define (sqrt x)
+ (sqrt-iter 1.0 0.0 x))
+(define (sqrt-iter guess prev-guess x)
+ (if (good-enough? guess prev-guess)
+ guess
+ (sqrt-iter (improve guess x) guess x)))
+(define (good-enough? guess prev-guess)
+ (< (/ (abs (- guess prev-guess)) guess) 0.001))
+(define (square x) (* x x))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+
+(sqrt 0.001)
+;; 0.0316227766
+
+;; Much better for small numbers
blob - /dev/null
blob + fabb2c628e6c7719bf8fcfd04938939f76983aee (mode 644)
--- /dev/null
+++ ex1-7.scm~
@@ -0,0 +1,6 @@
+(define (sqrt x)
+ (sqrt-iter 1.0 x))
+(define (sqrt-iter guess x)
+ (if (good-enough? guess x)
+ guess
+ (sqrt-iter (improve guess x) x)))
\ No newline at end of file
blob - /dev/null
blob + dafa353696d0bbcbdca1edc6dc11581f9341304d (mode 644)
--- /dev/null
+++ ex1-7b.scm
@@ -0,0 +1,12 @@
+(define sqrt-iter (guess x)
+ (let ((improved-guess (improve guess x)))
+ (if (close-enough? guess improved-guess)
+ improved-guess
+ (sqrt-iter improved-guess x))))
+(define (close-enough? guess x)
+ (let ((ratio (/ a b)))
+ (and (< ratio 1.001) (> ratio 0.0999))))
+
+
+
+
\ No newline at end of file
blob - /dev/null
blob + 377f5190e36687a3f89ca1b6ebb87cfdb041e376 (mode 644)
--- /dev/null
+++ ex1-8.scm
@@ -0,0 +1,22 @@
+(define (cbrt x)
+ (cbrt-iter 1.0 x))
+
+(define (cbrt-iter guess x)
+ (if (good-enough? guess x)
+ guess
+ (cbrt-iter (improve guess x) x)))
+
+(define (good-enough? guess x)
+ (< (abs (- (cube guess) x)) 0.001))
+
+(define (improve guess x)
+ (/ (+ (/ x (square guess)) (* 2 guess)) 3))
+(define (square x) (* x x))
+(define (cube x) (* x x x))
+
+(cbrt 15)
+;; 2.46621207
+(cbrt 8)
+;; 2
+(cbrt 64)
+;; 4
\ No newline at end of file
blob - /dev/null
blob + 96ca7a654c450356ecd0ff440dd701e07efd627c (mode 644)
--- /dev/null
+++ ex1-8.scm~
@@ -0,0 +1,4 @@
+(define (cube guess x)
+ (if (good-enough? ...)
+ guess
+ (improve guess x)))
blob - /dev/null
blob + 49b46e1feddc8acd63413091068a81cbd4b3e8fe (mode 644)
--- /dev/null
+++ ex1-9.scm
@@ -0,0 +1,38 @@
+(define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+
+(define (factorial n)
+ (fact-iter 1 1 n))
+(define (fact-iter product counter max-count)
+ (if (> counter max-count)
+ product
+ (fact-iter (* product counter) (+ counter 1) max-count)))
+
+
+(define (+ a b)
+ (if ( = a 0)
+ b
+ (inc (+ (dec a) b))))
+
+;; This is a recursive process
+(+ 4 5)
+(inc (+ 3 5))
+(inc (inc (+ 2 5)))
+(inc (inc (inc (+ 1 5))))
+(inc (inc (inc (inc (+ 0 5)))))
+(inc (inc (inc (inc 5))))
+;; ...
+
+(define (+ a b)
+ (if (= a 0)
+ b
+ (+ (dec a) (inc b))))
+
+;; This is an iterative process
+(+ 4 5)
+(+ 3 6)
+(+ 2 7)
+(+ 1 8)
+(+ 0 9)
\ No newline at end of file
blob - /dev/null
blob + 16ea0d3c665879e2aae15b39444a446f4cf85c86 (mode 644)
--- /dev/null
+++ ex1-9.scm~
@@ -0,0 +1,11 @@
+(define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+
+(define (factorial n)
+ (fact-iter 1 1 n))
+(define (fact-iter product counter max-count)
+ (if (> counter max-count)
+ product
+ (fact-iter (* product counter) (+ counter 1) max-count)))
blob - /dev/null
blob + f699b6849a920fa8595566302a2745c59b73f198 (mode 644)
--- /dev/null
+++ ex2-1.lisp
@@ -0,0 +1,14 @@
+(defun make-rat (n d)
+ (labels ((make-rat-reduce (n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (cond ((and (< n 0) (< d 0))
+ (make-rat-reduce (- n) (- d)))
+ ((and (< d 0) (> n 0))
+ (make-rat-reduce (- n) (- d)))
+ (t (make-rat-reduce n d)))))
+(defun numer (x)
+ (car x))
+(defun denom (x)
+ (cdr x))
+
blob - /dev/null
blob + 502e2391c7380ce9e44e7cca4ffcddefc1aa06e1 (mode 644)
--- /dev/null
+++ ex2-1.scm
@@ -0,0 +1,102 @@
+(define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+(define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+(define (equal-rat? x y)
+ (= (* (numer x) (denom y))
+ (* (numer y) (denom x))))
+
+(define (print-rat x)
+ (newline)
+ (display (numer x))
+ (display "/")
+ (display (denom x)))
+
+
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+;; (define (make-rat n d)
+;; (let ((g (gcd n d)))
+;; (cons (/ n g) (/ d g))))
+(define (numer x) (car x))
+(define (denom x) (cdr x))
+
+;; (define one-half (make-rat 1 2))
+;; (define one-third (make-rat 1 3))
+
+;; (print-rat one-half)
+;; (print-rat (make-rat 1 2))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+;; (print-rat (add-rat one-half one-third))
+;; (print-rat (make-rat 5 6))
+;; (print-rat (mul-rat one-half one-third))
+;; (print-rat (make-rat 1 6))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+
+;; Exercise 2.1. Define a better version of make-rat that handles both positive and negative arguments. Make-rat should normalize the sign so that if the rational number is positive, both the numerator and denominator are positive, and if the rational number is negative, only the numerator is negative.
+
+(define (make-rat n d)
+ (if (= d 0)
+ (error "Division by zero")
+ (let ((g-mag (abs (gcd n d)))
+ (n-mag (abs n))
+ (d-mag (abs d)))
+ (if (< (* n d) 0)
+ (cons (- (/ n-mag g-mag)) (/ d-mag g-mag))
+ (cons (/ n-mag g-mag) (/ d-mag g-mag))))))
+
+;; (define zz-0-0 (make-rat 0 0))
+(define zp-0-3 (make-rat 0 3))
+(define np-1-2 (make-rat -1 2))
+(define np-1-4 (make-rat -1 4))
+(define nn-3-4 (make-rat -3 -4))
+(define pp-4-3 (make-rat 4 3))
+(define pn-5-2 (make-rat 5 -2))
+(define pn-10-2 (make-rat 10 -2))
+(define nn-9-3 (make-rat -9 -3))
+
+;; (print-rat zz-0-0)
+;; (error "Division by zero")
+(print-rat zp-0-3)
+(display "=0/1")
+(print-rat np-1-2)
+(display "=-1/2")
+(print-rat np-1-4)
+(display "=-1/4")
+(print-rat nn-3-4)
+(display "=3/4")
+(print-rat pp-4-3)
+(display "=4/3")
+(print-rat pn-5-2)
+(display "=-5/2")
+(print-rat pn-10-2)
+(display "=-5/1")
+(print-rat nn-9-3)
+(display "=3/1")
+(print-rat (sub-rat nn-9-3 pp-4-3))
+(display "=5/3")
+(print-rat (mul-rat np-1-2 np-1-2))
+(display "=1/4")
+(print-rat (div-rat pn-5-2 pn-10-2))
+(display "=1/2")
+(print-rat (sub-rat np-1-4 zp-0-3))
+(display "=-1/4")
+;; (print-rat (div-rat nn-3-4 zp-0-3))
+;; (error "Division by zero")
+(print-rat (div-rat np-1-4 pn-5-2))
+(display "=1/10")
+
blob - /dev/null
blob + b138a9332e70faf79a8140b63b041a80059dfef8 (mode 644)
--- /dev/null
+++ ex2-1.scm~
@@ -0,0 +1,5 @@
+(define (linear-combination a b x y)
+ (+ (* a x) (* b y)))
+
+(define (linear-combination a b x y)
+ (add (mul a x) (mul b y)))
blob - /dev/null
blob + 10c2c8c5dfa23b89338dfc64d4017e07438f6d48 (mode 644)
--- /dev/null
+++ ex2-10.lisp
@@ -0,0 +1,9 @@
+(defun div-interval (x y)
+ (if (and
+ (>= (upper-bound y) 0)
+ (<= (lower-bound y) 0))
+ (error "Denominator spans zero")
+ (mul-interval
+ x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
blob - /dev/null
blob + c780e8f425fc2fe8225592c055ed0489e162bd25 (mode 644)
--- /dev/null
+++ ex2-10.lisp~
@@ -0,0 +1,9 @@
+(defun div-interval (x y)
+ (if (and
+ (>= (upper-bound y) 0)
+ (<= (lower-bound y) 0)
+ (error "Denominator spans zero")
+ (mul-interval
+ x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))))
blob - /dev/null
blob + 96060a461a48985df77282d2e728f2a4cab65247 (mode 644)
--- /dev/null
+++ ex2-10.scm
@@ -0,0 +1,39 @@
+(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 ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+
+;; Exercise 2.10. Ben Bitdiddle, an expert systems programmer, looks over Alyssa's shoulder and comments that it is not clear what it means to divide by an interval that spans zero. Modify Alyssa's code to check for this condition and to signal an error if it occurs.
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
blob - /dev/null
blob + d582b9d7cc181826cc14f2d73dad9501f8d2761f (mode 644)
--- /dev/null
+++ ex2-10.scm~
@@ -0,0 +1,29 @@
+(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 ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+
+;; Exercise 2.10. Ben Bitdiddle, an expert systems programmer, looks over Alyssa's shoulder and comments that it is not clear what it means to divide by an interval that spans zero. Modify Alyssa's code to check for this condition and to signal an error if it occurs.
blob - /dev/null
blob + 4d99ac8d461b3a995749d3774bcf80c433456ec1 (mode 644)
--- /dev/null
+++ ex2-11.scm
@@ -0,0 +1,80 @@
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+;; (define (div-interval x y)
+;; (mul-interval x
+;; (make-interval (/ 1.0 (upper-bound y))
+;; (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+;; Exercise 2.11. In passing, Ben also cryptically comments: ``By testing the signs of the endpoints of the intervals, it is possible to break mul-interval into nine cases, only one of which requires more than two multiplications.'' Rewrite this procedure using Ben's suggestion.
+
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
blob - /dev/null
blob + 96060a461a48985df77282d2e728f2a4cab65247 (mode 644)
--- /dev/null
+++ ex2-11.scm~
@@ -0,0 +1,39 @@
+(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 ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+
+;; Exercise 2.10. Ben Bitdiddle, an expert systems programmer, looks over Alyssa's shoulder and comments that it is not clear what it means to divide by an interval that spans zero. Modify Alyssa's code to check for this condition and to signal an error if it occurs.
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
blob - /dev/null
blob + e18c634c97605fb42c2a63bc72c7c8833526f55f (mode 644)
--- /dev/null
+++ ex2-12.lisp
@@ -0,0 +1,5 @@
+(defun make-center-percent (c p)
+ (let ((w (abs (* p (/ c 100)))))
+ (make-center-width c w)))
+(defun percent (i)
+ (* 100 (/ (width i) (abs (center i)))))
blob - /dev/null
blob + 483aa800871df2305017801f7bfa9d61c3681da8 (mode 644)
--- /dev/null
+++ ex2-12.scm
@@ -0,0 +1,120 @@
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; Exercise 2.12. Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (* percent center 0.01)))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (center interval)))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
blob - /dev/null
blob + 26b0ce20e698e102fc931ceaf996a49607872303 (mode 644)
--- /dev/null
+++ ex2-12.scm~
@@ -0,0 +1,6 @@
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
blob - /dev/null
blob + d90414a70ecc05f10e0c903a312f36671028965d (mode 644)
--- /dev/null
+++ ex2-13.scm
@@ -0,0 +1,120 @@
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; Exercise 2.12. Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (abs (* percent center 0.01))))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (abs (center interval))))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
blob - /dev/null
blob + 483aa800871df2305017801f7bfa9d61c3681da8 (mode 644)
--- /dev/null
+++ ex2-13.scm~
@@ -0,0 +1,120 @@
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; Exercise 2.12. Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (* percent center 0.01)))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (center interval)))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
blob - /dev/null
blob + ccde8b6f7c9a26d13c24c983d3343970e426a1d0 (mode 644)
--- /dev/null
+++ ex2-14.lisp
@@ -0,0 +1,15 @@
+(defun par1 (r1 r2)
+ (div-interval
+ (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(defun par2 (r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval
+ one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
+
+(defvar aa (make-center-width 5 0.1))
+(defvar bb (make-center-width 10 0.1))
+(print (par1 aa bb))
+(print (par2 aa bb))
blob - /dev/null
blob + 23335b796198966837adce56fd25e5c39a11e4ff (mode 644)
--- /dev/null
+++ ex2-14.lisp~
@@ -0,0 +1,10 @@
+(defun par1 (r1 r2)
+ (div-interval
+ (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(defun par2 (r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval
+ one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
blob - /dev/null
blob + 705eac1e11ce76ac97bf113094cb455e6a7cb451 (mode 644)
--- /dev/null
+++ ex2-14.scm
@@ -0,0 +1,137 @@
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (abs (* percent center 0.01))))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (abs (center interval))))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
+
+(newline)
+(print-interval (par1 (make-center-percent 25 5) (make-center-percent 20 3)))
+(print-interval (par2 (make-center-percent 25 5) (make-center-percent 20 3)))
+;; both should be equal and centered around 11.11, but this is not so
+
+(print-interval (div-interval (make-center-percent 25 1)
+ (make-center-percent 25 1)))
+
+;; we'd expect this to give exactly 1?
+
blob - /dev/null
blob + 02d531b90d4cf19e069322f3f19835f291af7645 (mode 644)
--- /dev/null
+++ ex2-14.scm~
@@ -0,0 +1,137 @@
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (abs (* percent center 0.01))))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (abs (center interval))))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
+
+(newline)
+(print-interval (par1 (make-center-percent 25 5) (make-center-percent 20 3)))
+(print-interval (par2 (make-center-percent 25 5) (make-center-percent 20 3)))
+;; both should be equal and centered around 11.11, but this is not so
+
+(print-interval (div-interval (make-center-percent 25 1n)
+ (make-center-percent 25 1)))
+
+;; we'd expect this to give exactly 1?
+
blob - /dev/null
blob + a04d4d1ab137708374750dd1c8edcb0eb28d7729 (mode 644)
--- /dev/null
+++ ex2-14b.scm
@@ -0,0 +1,8 @@
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval r2)))))
blob - /dev/null
blob + e5398d99e9112df56d7322d0452fea8d7a167c14 (mode 644)
--- /dev/null
+++ ex2-17.lisp
@@ -0,0 +1,4 @@
+(defun last-pair (items)
+ (if (null (cdr items))
+ items
+ (last-pair (cdr items))))
blob - /dev/null
blob + 7a256898f2d60e1ccb14deb454ea1474de7b3715 (mode 644)
--- /dev/null
+++ ex2-17.lisp~
@@ -0,0 +1,2 @@
+(defun last-pair (items)
+ (if (null (cdr items))
blob - /dev/null
blob + 9041673d15286cfebda77b1aff70e6f58cbe4022 (mode 644)
--- /dev/null
+++ ex2-17.scm
@@ -0,0 +1,42 @@
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (car l))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + 7d6072b30102939d8494c0ecd49d9d79fa12fa69 (mode 644)
--- /dev/null
+++ ex2-17.scm~
@@ -0,0 +1,2 @@
+(define one-through-four (list 1 2 3 4))
+one-through-four
blob - /dev/null
blob + 6b0a2b37c5201aefbe46f38cb282b747a33f005a (mode 644)
--- /dev/null
+++ ex2-18.lisp
@@ -0,0 +1,8 @@
+(defun my-reverse (items)
+ (if (null items)
+ nil
+ (append
+ (my-reverse (cdr items))
+ (list (car items)))))
+
+
blob - /dev/null
blob + c6fa8da372810f8bb0c042b32e832629f3101ce6 (mode 644)
--- /dev/null
+++ ex2-18.lisp~
@@ -0,0 +1,6 @@
+(defun my-reverse (items)
+ (if (null items)
+ nil
+ (append
+ (my-reverse (cdr items)
+ (list (car items))))))
blob - /dev/null
blob + ab1e1fc6103ac7689cc6084d61e6e900cbae0c79 (mode 644)
--- /dev/null
+++ ex2-18.scm
@@ -0,0 +1,42 @@
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (list (car l)))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + 9041673d15286cfebda77b1aff70e6f58cbe4022 (mode 644)
--- /dev/null
+++ ex2-18.scm~
@@ -0,0 +1,42 @@
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (car l))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + aa0b7519188a9176c40e36b0747fbfd87e600ecb (mode 644)
--- /dev/null
+++ ex2-19.lisp
@@ -0,0 +1,15 @@
+(defun no-more? (coins)
+ (null coins))
+(defun except-first-denomination (coins)
+ (cdr coins))
+(defun first-denomination (oins)
+ (car coins))
+(defun cc (amount coin-values)
+ (cond ((= amount 0) 1)
+ ((or (< amount 0) (no-more? coin-values)) 0)
+ (t
+ (+ (cc amount
+ (except-first-denomination coin-values))
+ (cc (- amount
+ (first-denomination coin-values))
+ coin-values)))))
blob - /dev/null
blob + 6b0a2b37c5201aefbe46f38cb282b747a33f005a (mode 644)
--- /dev/null
+++ ex2-19.lisp~
@@ -0,0 +1,8 @@
+(defun my-reverse (items)
+ (if (null items)
+ nil
+ (append
+ (my-reverse (cdr items))
+ (list (car items)))))
+
+
blob - /dev/null
blob + 8efa82e7078d09516d795203da315223129cc911 (mode 644)
--- /dev/null
+++ ex2-19.scm
@@ -0,0 +1,57 @@
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (list (car l)))))
+
+(define us-coins (list 50 25 10 5 1))
+(define uk-coins (list 100 50 20 10 5 2 1 0.5))
+
+(define (cc amount coin-values)
+ (cond ((= amount 0) 1)
+ ((or (< amount 0) (no-more? coin-values)) 0)
+ (else
+ (+ (cc amount
+ (except-first-denomination coin-values))
+ (cc (- amount
+ (first-denomination coin-values))
+ coin-values)))))
+
+;; Define the procedures first-denomination, except-first-denomination, and no-more? in terms of primitive operations on list structures. Does the order of the list coin-values affect the answer produced by cc? Why or why not?
+
+(define first-denomination car)
+(define except-first-denomination cdr)
+(define no-more? null?)
+
+;; no, order of coin-values shouldn't matter because it doesn't matter in reali life
+
+(test-case (cc 100 us-coins) 292)
blob - /dev/null
blob + ab1e1fc6103ac7689cc6084d61e6e900cbae0c79 (mode 644)
--- /dev/null
+++ ex2-19.scm~
@@ -0,0 +1,42 @@
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (list (car l)))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + 59da5eaacbe69d770adfa118c9dea5307a256b0f (mode 644)
--- /dev/null
+++ ex2-2.lisp
@@ -0,0 +1,26 @@
+(defun make-segment (start end)
+ (cons start end))
+(defun start-segment (segment)
+ (car segment))
+(defun end-segment (segment)
+ (cdr segment))
+(defun make-point (x y)
+ (cons x y))
+(defun x-point (point)
+ (car point))
+(defun y-point (point)
+ (cdr point))
+(defun print-point (point)
+ (format t "(~F,~F)~%" (x-point point) (y-point point)))
+(defun midpoint-segment (segment)
+ (let ((segstart (start-segment segment))
+ (segend (end-segment segment)))
+ (make-point (average (x-point segstart)
+ (x-point segend))
+ (average (y-point segstart)
+ (y-point segend)))))
+(defvar aa (make-point 4 6))
+(defvar bb (make-point 9 15))
+(print-point
+ (midpoint-segment (make-segment aa bb)))
+
blob - /dev/null
blob + 21f611c03dc9ffde375c305fc7729681cb62e91e (mode 644)
--- /dev/null
+++ ex2-2.lisp~
@@ -0,0 +1,2 @@
+(defun make-segment (start end)
+ (cons start end))
blob - /dev/null
blob + 9c4f17a102178e64c30b374fa056442df93373e5 (mode 644)
--- /dev/null
+++ ex2-2.scm
@@ -0,0 +1,38 @@
+;; Exercise 2.2. Consider the problem of representing line segments in a plane. Each segment is represented as a pair of points: a starting point and an ending point. Define a constructor make-segment and selectors start-segment and end-segment that define the representation of segments in terms of points. Furthermore, a point can be represented as a pair of numbers: the x coordinate and the y coordinate. Accordingly, specify a constructor make-point and selectors x-point and y-point that define this representation. Finally, using your selectors and constructors, define a procedure midpoint-segment that takes a line segment as argument and returns its midpoint (the point whose coordinates are the average of the coordinates of the endpoints). To try your procedures, you'll need a way to print points:
+
+(define (make-point x y)
+ (cons x y))
+(define (x-point p)
+ (car p))
+(define (y-point p)
+ (cdr p))
+
+(define (make-segment start end)
+ (cons start end))
+(define (start-segment seg)
+ (car seg))
+(define (end-segment seg)
+ (cdr seg))
+(define (midpoint-segment seg)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (let ((x1 (x-point (start-segment seg)))
+ (x2 (x-point (end-segment seg)))
+ (y1 (y-point (start-segment seg)))
+ (y2 (y-point (end-segment seg))))
+ (make-point (average x1 x2)
+ (average y1 y2))))
+
+(define (print-point p)
+ (newline)
+ (display "(")
+ (display (x-point p))
+ (display ",")
+ (display (y-point p))
+ (display ")"))
+
+(define x1y2 (make-point 1 2))
+(define x-4y-3 (make-point -4 -3))
+(define x1y2tox-4y-3 (make-segment x1y2 x-4y-3))
+(print-point (midpoint-segment x1y2tox-4y-3))
+(display "=(-3/2,-1/2)")
blob - /dev/null
blob + 31a3df3302f2f5d624e49dc95efcd395df9a71fb (mode 644)
--- /dev/null
+++ ex2-2.scm~
@@ -0,0 +1,9 @@
+(define (make-rat n d)
+ (cons n d))
+(define (numer x)
+ (let ((g (gcd (car x) (cdr x))))
+ (/ (car x) g)))
+(define (denom x)
+ (let ((g (gcd (car x) (cdr x))))
+ (/ (cdr x) g)))
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 7684e7f06971d8860461eb6ef2b108a3e1c5ad9e (mode 644)
--- /dev/null
+++ ex2-20.scm
@@ -0,0 +1,35 @@
+;; Use this notation to write a procedure same-parity that takes one or more integers and returns a list of all the arguments that have the same even-odd parity as the first argument. For example,
+
+;; (define (same-parity parity . integers)
+;; (let ((rem (remainder parity 2)))
+;; (define (par ints)
+;; (cond ((null? ints) '())
+;; ((= (remainder (car ints) 2) rem)
+;; (cons (car ints)
+;; (par (cdr ints))))
+;; (else (par (cdr ints))))))
+;; (cons parity (par integers)))
+
+;; par seems not to be in scope in the call at the end
+
+
+(define (same-parity parity . integers)
+ (let ((rem (remainder parity 2)))
+ (define (par ints)
+ (cond ((null? ints) '())
+ ((= (remainder (car ints) 2) rem)
+ (cons (car ints)
+ (par (cdr ints))))
+ (else (par (cdr ints)))))
+ (cons parity (par integers))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (same-parity 1 2 3 4 5 6 7) '(1 3 5 7))
+(test-case (same-parity 2 3 4 5 6 7) '(2 4 6))
+(test-case (same-parity 5) '(5))
+;;(test-case (same-parity) (error "Expected argument"))
blob - /dev/null
blob + 555bac319e12d29de9b2f007cc6291478b945c52 (mode 644)
--- /dev/null
+++ ex2-20.scm~
@@ -0,0 +1,33 @@
+;; Use this notation to write a procedure same-parity that takes one or more integers and returns a list of all the arguments that have the same even-odd parity as the first argument. For example,
+
+;; (define (same-parity parity . integers)
+;; (let ((rem (remainder parity 2)))
+;; (define (par ints)
+;; (cond ((null? ints) '())
+;; ((= (remainder (car ints) 2) rem)
+;; (cons (car ints)
+;; (par (cdr ints))))
+;; (else (par (cdr ints))))))
+;; (cons parity (par integers)))
+
+;; par seems not to be in scope in the call at the end
+
+
+(define (same-parity parity . integers)
+ (let ((rem (remainder parity 2)))
+ (define (par ints)
+ (cond ((null? ints) '())
+ ((= (remainder (car ints) 2) rem)
+ (cons (car ints)
+ (par (cdr ints))))
+ (else (par (cdr ints)))))
+ (cons parity (par integers))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (same-parity 1 2 3 4 5 6 7) '(1 3 5 7))
+(test-case (same-parity 2 3 4 5 6 7) '(2 4 6))
blob - /dev/null
blob + fa86a7231a3d9fa3188d74cd60b3b5fc8b36982a (mode 644)
--- /dev/null
+++ ex2-20b.scm
@@ -0,0 +1,10 @@
+(define (same-parity a . z)
+ (define (iter items answer)
+ (if (null? items)
+ answer
+ (iter (cdr items)
+ (if (= (remainder (car items) 2)
+ (remainder a 2))
+ (append answer (list (car items)))
+ answer))))
+ (iter z (list a)))
blob - /dev/null
blob + 060e7a9cdf67dab7dd294a3d7fc0c116338fde96 (mode 644)
--- /dev/null
+++ ex2-21.lisp
@@ -0,0 +1,7 @@
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
blob - /dev/null
blob + f6e3a3426f5e06d21555df5cb7b6811b5401a2d6 (mode 644)
--- /dev/null
+++ ex2-21.scm
@@ -0,0 +1,29 @@
+(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items)))))
+
+(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+
+;; Exercise 2.21. The procedure square-list takes a list of numbers as argument and returns a list of the squares of those numbers.
+
+(define (square-list-map nums)
+ (map (lambda (x) (* x x)) nums))
+
+(define (square-list-recurse nums)
+ (if (null? nums)
+ '()
+ (cons (* (car nums) (car nums))
+ (square-list-recurse (cdr nums)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (square-list-recurse (list 1 2 3 4)) '(1 4 9 16))
+(test-case (square-list-map (list 1 2 3 4)) '(1 4 9 16))
+
blob - /dev/null
blob + 317aa9e8bbadc63e7c2a837f087306cd6afa6dbd (mode 644)
--- /dev/null
+++ ex2-21.scm~
@@ -0,0 +1,6 @@
+(define (scale-list items factor)
+ (if (null? items)
+ nil
+ (cons (* (car items) factor)
+ (scale-list (cdr items) factor))))
+(scale-list (list 1 2 3 4 5) 10)
blob - /dev/null
blob + 568eb49849f867bea5c092aa20695146c978f6dd (mode 644)
--- /dev/null
+++ ex2-22.lisp
@@ -0,0 +1,19 @@
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
+
+(defun square-list-iter (items)
+ (labels (
+ (iter (things answer)
+ (format t "~A - ~A~%" things answer)
+ (if (null things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer)))))
+ (iter items nil)))
+(print (square-list-iter '(1 2 3 4)))
blob - /dev/null
blob + 060e7a9cdf67dab7dd294a3d7fc0c116338fde96 (mode 644)
--- /dev/null
+++ ex2-22.lisp~
@@ -0,0 +1,7 @@
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
blob - /dev/null
blob + a817b13042b32f737b5303c1029fc5193fc5a95d (mode 644)
--- /dev/null
+++ ex2-22.scm
@@ -0,0 +1,59 @@
+(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items)))))
+
+(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+
+(define (square-list-map nums)
+ (map (lambda (x) (* x x)) nums))
+
+(define (square-list-recurse nums)
+ (if (null? nums)
+ '()
+ (cons (* (car nums) (car nums))
+ (square-list-recurse (cdr nums)))))
+
+;; Exercise 2.22. Louis Reasoner tries to rewrite the first square-list procedure of exercise 2.21 so that it evolves an iterative process:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer))))
+ (iter items nil))
+
+;; (cons (square (car things))
+;; answer)
+;; puts the next number in front of its previous number, but we should be
+;; putting the next number behind the previous number
+;; that's why the numbers appear reversed in the resulting list
+
+;; Louis then tries to fix his bug by interchanging the arguments to cons:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons answer
+ (square (car things))))))
+ (iter items nil))
+
+;; This doesn't work either. Explain.
+
+;; answer is a list whereas (square (car things)) is a number. So although
+;; the order is right, you end up with nested lists. We should instead be
+;; using (append answer (list (square (car things))))
+;; to append two lists
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
blob - /dev/null
blob + 517db1decd35dc81fd403875038302c8d01fef2b (mode 644)
--- /dev/null
+++ ex2-22.scm~
@@ -0,0 +1,54 @@
+(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items)))))
+
+(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+
+;; Exercise 2.21. The procedure square-list takes a list of numbers as argument and returns a list of the squares of those numbers.
+
+(define (square-list-map nums)
+ (map (lambda (x) (* x x)) nums))
+
+(define (square-list-recurse nums)
+ (if (null? nums)
+ '()
+ (cons (* (car nums) (car nums))
+ (square-list-recurse (cdr nums)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (square-list-recurse (list 1 2 3 4)) '(1 4 9 16))
+(test-case (square-list-map (list 1 2 3 4)) '(1 4 9 16))
+
+ Exercise 2.22. Louis Reasoner tries to rewrite the first square-list procedure of exercise 2.21 so that it evolves an iterative process:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer))))
+ (iter items nil))
+
+Unfortunately, defining square-list this way produces the answer list in the reverse order of the one desired. Why?
+
+Louis then tries to fix his bug by interchanging the arguments to cons:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons answer
+ (square (car things))))))
+ (iter items nil))
+
+This doesn't work either. Explain.
blob - /dev/null
blob + 201bbd5d5864e8c06c14a11a799abb4b932b1f9d (mode 644)
--- /dev/null
+++ ex2-23.scm
@@ -0,0 +1,23 @@
+;; Exercise 2.23. The procedure for-each is similar to map. It takes as arguments a procedure and a list of elements. However, rather than forming a list of the results, for-each just applies the procedure to each of the elements in turn, from left to right. The values returned by applying the procedure to the elements are not used at all -- for-each is used with procedures that perform an action, such as printing. For example,
+
+(define (for-each proc items)
+ (if (null? items)
+ #t
+ (and (proc (car items))
+ (for-each proc (cdr items)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(for-each (lambda (x) (newline) (display x))
+ (list 57 321 88))
+(newline)
+(display 57)
+(newline)
+(display 321)
+(newline)
+(display 88)
+
+
blob - /dev/null
blob + 568eb49849f867bea5c092aa20695146c978f6dd (mode 644)
--- /dev/null
+++ ex2-23.scm~
@@ -0,0 +1,19 @@
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
+
+(defun square-list-iter (items)
+ (labels (
+ (iter (things answer)
+ (format t "~A - ~A~%" things answer)
+ (if (null things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer)))))
+ (iter items nil)))
+(print (square-list-iter '(1 2 3 4)))
blob - /dev/null
blob + edaa4aa1f68dc3754190657801e20d3aaae1f9bb (mode 644)
--- /dev/null
+++ ex2-24.scm
@@ -0,0 +1,8 @@
+(define (count-leaves x)
+ (cond ((null? x) 0)
+ ((not (pair? x)) 1)
+ (else (+ (count-leaves (car x))
+ (count-leaves (cdr x))))))
+
+(list 1 (list 2 (list 3 4)))
+'(1 (2 (3 4)))
blob - /dev/null
blob + 201bbd5d5864e8c06c14a11a799abb4b932b1f9d (mode 644)
--- /dev/null
+++ ex2-24.scm~
@@ -0,0 +1,23 @@
+;; Exercise 2.23. The procedure for-each is similar to map. It takes as arguments a procedure and a list of elements. However, rather than forming a list of the results, for-each just applies the procedure to each of the elements in turn, from left to right. The values returned by applying the procedure to the elements are not used at all -- for-each is used with procedures that perform an action, such as printing. For example,
+
+(define (for-each proc items)
+ (if (null? items)
+ #t
+ (and (proc (car items))
+ (for-each proc (cdr items)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(for-each (lambda (x) (newline) (display x))
+ (list 57 321 88))
+(newline)
+(display 57)
+(newline)
+(display 321)
+(newline)
+(display 88)
+
+
blob - /dev/null
blob + 7ccd2c4b515e06df44e4dc93ca4c47ece540ad59 (mode 644)
--- /dev/null
+++ ex2-25.lisp
@@ -0,0 +1,5 @@
+(cadaddr '(1 3 (5 7) 9)))
+
+(caar '((7)))
+
+(cadadadadadadr (1 (2 (3 (4 (5 (6 7)))))))
blob - /dev/null
blob + bfc90827888613b4d9016b4b23d18b0693e21bf2 (mode 644)
--- /dev/null
+++ ex2-25.scm
@@ -0,0 +1,32 @@
+(define (count-leaves x)
+ (cond ((null? x) 0)
+ ((not (pair? x)) 1)
+ (else (+ (count-leaves (car x))
+ (count-leaves (cdr x))))))
+
+;;(list 1 (list 2 (list 3 4)))
+;;'(1 (2 (3 4)))
+
+;; Exercise 2.26. Suppose we define x and y to be two lists:
+
+(define x (list 1 2 3))
+(define y (list 4 5 6))
+
+;; What result is printed by the interpreter in response to evaluating each of the following expressions:
+
+(display (append x y))
+(newline)
+(display '(1 2 3 4 5 6))
+(newline)
+(newline)
+
+(display (cons x y))
+(newline)
+(display '((1 2 3) 4 5 6))
+(newline)
+(newline)
+
+(display (list x y))
+(newline)
+(display '((1 2 3) (4 5 6)))
+(newline)
blob - /dev/null
blob + 2b25c4b9e68529b537ad05ba267fb802b7070866 (mode 644)
--- /dev/null
+++ ex2-25.scm~
@@ -0,0 +1,32 @@
+(define (count-leaves x)
+ (cond ((null? x) 0)
+ ((not (pair? x)) 1)
+ (else (+ (count-leaves (car x))
+ (count-leaves (cdr x))))))
+
+;;(list 1 (list 2 (list 3 4)))
+;;'(1 (2 (3 4)))
+
+;; Exercise 2.26. Suppose we define x and y to be two lists:
+
+(define x (list 1 2 3))
+(define y (list 4 5 6))
+
+;; What result is printed by the interpreter in response to evaluating each of the following expressions:
+
+(display (append x y))
+(newline)
+(display '(1 2 3 4 5 6))
+(newline)
+(newline)
+
+(display (cons x y))
+(newline)
+(display '((1 2 3) 4 5 6))
+(newline)
+(newline)
+
+(display (list x y))
+(newline)
+(display '((1 2 3) (4 5 6))
+(newline)
blob - /dev/null
blob + 2530e791e49be2f79417dcd587432e909effb6b1 (mode 644)
--- /dev/null
+++ ex2-27.lisp
@@ -0,0 +1,10 @@
+(defun deep-reverse (lst)
+ (cond ((null lst) nil)
+ ((consp (car lst))
+ (append
+ (deep-reverse (cdr lst))
+ (list (deep-reverse (car lst)))))
+ (t
+ (append
+ (deep-reverse (cdr lst))
+ (list (car lst))))))
blob - /dev/null
blob + 770d199fbd9028d8cdf421b8fd776ac5b9aaae4d (mode 644)
--- /dev/null
+++ ex2-27.scm
@@ -0,0 +1,23 @@
+;; Exercise 2.27. Modify your reverse procedure of exercise 2.18 to produce a deep-reverse procedure that takes a list as argument and returns as its value the list with its elements reversed and with all sublists deep-reversed as well. For example,
+
+(define (deep-reverse tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) tree)
+ (else (append
+ (deep-reverse (cdr tree))
+ (list (deep-reverse (car tree)))))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define x (list (list 1 2) (list 3 4)))
+
+(test-case (reverse x) '((3 4) (1 2)))
+
+(test-case (deep-reverse x) '((4 3) (2 1)))
blob - /dev/null
blob + bf58fc259980b97e6f378c80960e08c1a04360a6 (mode 644)
--- /dev/null
+++ ex2-27.scm~
@@ -0,0 +1,17 @@
+;; Exercise 2.27. Modify your reverse procedure of exercise 2.18 to produce a deep-reverse procedure that takes a list as argument and returns as its value the list with its elements reversed and with all sublists deep-reversed as well. For example,
+
+(define (deep-reverse tree)
+ (cond ((null? tree) ...)
+ ((not (pair? tree)) ...)
+ (else ...)))
+
+(define x (list (list 1 2) (list 3 4)))
+
+x
+((1 2) (3 4))
+
+(reverse x)
+((3 4) (1 2))
+
+(deep-reverse x)
+((4 3) (2 1))
blob - /dev/null
blob + 16dfc58e2160eb0e4059d130a0bafa8255c51c76 (mode 644)
--- /dev/null
+++ ex2-28.lisp
@@ -0,0 +1,5 @@
+(defun fringe (lst)
+ (cond ((null lst) nil)
+ ((not (consp lst)) (list lst))
+ (t (append (fringe (car lst))
+ (fringe cdr lst)))))
blob - /dev/null
blob + f2ca7a0679ea92bc35d1f0145fae9e3a4c35c2c4 (mode 644)
--- /dev/null
+++ ex2-28.scm
@@ -0,0 +1,33 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (deep-reverse tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) tree)
+ (else (append
+ (deep-reverse (cdr tree))
+ (list (deep-reverse (car tree)))))))
+
+;; (define x (list (list 1 2) (list 3 4)))
+;; (test-case (reverse x) '((3 4) (1 2)))
+;; (test-case (deep-reverse x) '((4 3) (2 1)))
+
+
+;;Exercise 2.28. Write a procedure fringe that takes as argument a tree (represented as a list) and returns a list whose elements are all the leaves of the tree arranged in left-to-right order. For example,
+
+(define (fringe tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (list tree))
+ (else (append (fringe (car tree))
+ (fringe (cdr tree))))))
+
+
+(define x (list (list 1 2) (list 3 4)))
+(test-case (fringe x) '(1 2 3 4))
+(test-case (fringe (list x x)) '(1 2 3 4 1 2 3 4))
blob - /dev/null
blob + 770d199fbd9028d8cdf421b8fd776ac5b9aaae4d (mode 644)
--- /dev/null
+++ ex2-28.scm~
@@ -0,0 +1,23 @@
+;; Exercise 2.27. Modify your reverse procedure of exercise 2.18 to produce a deep-reverse procedure that takes a list as argument and returns as its value the list with its elements reversed and with all sublists deep-reversed as well. For example,
+
+(define (deep-reverse tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) tree)
+ (else (append
+ (deep-reverse (cdr tree))
+ (list (deep-reverse (car tree)))))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define x (list (list 1 2) (list 3 4)))
+
+(test-case (reverse x) '((3 4) (1 2)))
+
+(test-case (deep-reverse x) '((4 3) (2 1)))
blob - /dev/null
blob + e7be1fc8d156a4fb44e0f30c46d67669fc109fc5 (mode 644)
--- /dev/null
+++ ex2-29.lisp
@@ -0,0 +1,43 @@
+(defun make-mobile (left right)
+ (list left right))
+(defun left-branch (mobile)
+ (first mobile))
+(defun right-branch (mobile)
+ (second mobile))
+(defun make-branch (len structure)
+ (list len structure))
+(defun branch-len (branch)
+ (first branch))
+(defun branch-structure (branch)
+ (second branch))
+
+(defun structure-is-weight? (structure)
+ (atom structure))
+(defun weight-of-branch (branch)
+ (let ((struct (branch-structure branch)))
+ (if (structure-is-weight? struct)
+ struct
+ (weight-of-mobile struct))))
+(defun weight-of-mobile (mobile)
+ (+ (weight-of-branch (left-branch mobile))
+ (weight-of-branch (right-branch mobile))))
+(defun torque-of-branch (branch)
+ (* (branch-len branch)
+ (weight-of-branch branch)))
+(defun branch-balanced? (branch)
+ "A branch is balanced either when it has a structure
+ that's a simple weight, or when the structure is
+ a balanced mobile"
+ (let ((struct (branch-structure branch)))
+ (or
+ (structure-is-weight? struct)
+ (mobile-balanced? struct))))
+(defun mobile-balanced? (mobile)
+ (let ((lb (left-branch mobile))
+ (rb (right-branch mobile)))
+ (and
+ (= (torque-of-branch lb)
+ (torque-of-branch rb))
+ (branch-balanced? lb)
+ (branch-balanced? rb))))
+
blob - /dev/null
blob + dc22ddd0091432ea7ca37b0232bff2364fec1d12 (mode 644)
--- /dev/null
+++ ex2-29.lisp~
@@ -0,0 +1,17 @@
+(defun make-mobile (left right)
+ (list left right))
+(defun left-branch (mobile)
+ (first mobile))
+(defun right-branch (mobile)
+ (second mobile))
+(defun make-branch (len structure)
+ (list len structure))
+(defun branch-len (branch)
+ (first branch))
+(defun branch-structure (branch)
+ (second branch))
+
+(defun structure-is-weight? (structure)
+ (atom structure))
+(defun weight-of-branch 9branch)
+(let
blob - /dev/null
blob + a7a71ba3cdc7e88d69ab36242b8bca1f6c480564 (mode 644)
--- /dev/null
+++ ex2-29.scm
@@ -0,0 +1,103 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.29. A binary mobile consists of two branches, a left branch and a right branch. Each branch is a rod of a certain length, from which hangs either a weight or another binary mobile. We can represent a binary mobile using compound data by constructing it from two branches (for example, using list):
+
+;; A branch is constructed from a length (which must be a number) together with a structure, which may be either a number (representing a simple weight) or another mobile:
+
+;; a. Write the corresponding selectors left-branch and right-branch, which return the branches of a mobile, and branch-length and branch-structure, which return the components of a branch.
+
+;; b. Using your selectors, define a procedure total-weight that returns the total weight of a mobile.
+
+;; c. A mobile is said to be balanced if the torque applied by its top-left branch is equal to that applied by its top-right branch (that is, if the length of the left rod multiplied by the weight hanging from that rod is equal to the corresponding product for the right side) and if each of the submobiles hanging off its branches is balanced. Design a predicate that tests whether a binary mobile is balanced.
+
+(define (make-mobile left right)
+ (list left right))
+(define (make-branch length structure)
+ (list length structure))
+(define (left-branch mobile)
+ (car mobile))
+(define (right-branch mobile)
+ (cadr mobile))
+(define (branch-length branch)
+ (car branch))
+(define (branch-structure branch)
+ (cadr branch))
+(define (weight? mobile)
+ (not (pair? mobile)))
+(define (total-weight mobile)
+ (if (weight? mobile)
+ mobile
+ (+ (total-weight (branch-structure (left-branch mobile)))
+ (total-weight (branch-structure (right-branch mobile))))))
+
+(define m1 (make-mobile (make-branch 4 5) (make-branch 10 3)))
+(define m2 (make-mobile (make-branch 2 3) (make-branch 3 4)))
+(define m3 (make-mobile (make-branch 4 m1) (make-branch 5 m1)))
+(define m4 (make-mobile (make-branch 7 m3) (make-branch 15 m2)))
+(define m5 (make-mobile (make-branch 1 m4) (make-branch 3 m3)))
+
+;; (test-case (total-weight 4) 4)
+;; (test-case (total-weight m1) 8)
+;; (test-case (total-weight m2) 7)
+;; (test-case (total-weight m3) 16)
+;; (test-case (total-weight m4) 23)
+;; (test-case (total-weight m5) 39)
+
+(define (balanced? mobile)
+ (if (weight? mobile)
+ #t
+ (let* ((lb (left-branch mobile))
+ (rb (right-branch mobile))
+ (ls (branch-structure lb))
+ (rs (branch-structure rb)))
+ (and
+ (balanced? ls)
+ (balanced? rs)
+ (= (* (branch-length lb)
+ (total-weight ls))
+ (* (branch-length rb)
+ (total-weight rs)))))))
+
+(define m6 (make-mobile (make-branch 6 6) (make-branch 9 4))) ;; weight 10
+(define m7 (make-mobile (make-branch 4 5) (make-branch 10 2))) ;; weight 7
+(define m8 (make-mobile (make-branch 5 m6) (make-branch 2 25))) ;; wgt 35
+(define m9 (make-mobile (make-branch 2 m8) (make-branch 10 m7))) ;; wgt 42
+(define m10 (make-mobile (make-branch 1 m9) (make-branch 6 m7))) ;; wgt 49
+
+(test-case (balanced? m1) #f)
+(test-case (balanced? m2) #f)
+(test-case (balanced? m3) #f)
+(test-case (balanced? m4) #f)
+(test-case (balanced? m5) #f)
+(test-case (balanced? m6) #t)
+(test-case (balanced? m7) #t)
+(test-case (balanced? m8) #t)
+(test-case (balanced? m9) #t)
+(test-case (balanced? m10) #t)
+
+;; d. Suppose we change the representation of mobiles so that the constructors are
+
+(define (make-mobile left right)
+ (cons left right))
+(define (make-branch length structure)
+ (cons length structure))
+
+;; How much do you need to change your programs to convert to the new representation?
+
+;; Just need to change these 4:
+
+(define (left-branch mobile)
+ (car mobile))
+(define (right-branch mobile)
+ (cdr mobile))
+(define (branch-length branch)
+ (car branch))
+(define (branch-structure branch)
+ (cdr branch))
blob - /dev/null
blob + bb10063bd811d7ba7ccf9091aff685ace38d80a1 (mode 644)
--- /dev/null
+++ ex2-29.scm~
@@ -0,0 +1,24 @@
+;; Exercise 2.29. A binary mobile consists of two branches, a left branch and a right branch. Each branch is a rod of a certain length, from which hangs either a weight or another binary mobile. We can represent a binary mobile using compound data by constructing it from two branches (for example, using list):
+
+(define (make-mobile left right)
+ (list left right))
+
+;; A branch is constructed from a length (which must be a number) together with a structure, which may be either a number (representing a simple weight) or another mobile:
+
+(define (make-branch length structure)
+ (list length structure))
+
+;; a. Write the corresponding selectors left-branch and right-branch, which return the branches of a mobile, and branch-length and branch-structure, which return the components of a branch.
+
+;; b. Using your selectors, define a procedure total-weight that returns the total weight of a mobile.
+
+;; c. A mobile is said to be balanced if the torque applied by its top-left branch is equal to that applied by its top-right branch (that is, if the length of the left rod multiplied by the weight hanging from that rod is equal to the corresponding product for the right side) and if each of the submobiles hanging off its branches is balanced. Design a predicate that tests whether a binary mobile is balanced.
+
+;; d. Suppose we change the representation of mobiles so that the constructors are
+
+(define (make-mobile left right)
+ (cons left right))
+(define (make-branch length structure)
+ (cons length structure))
+
+;; How much do you need to change your programs to convert to the new representation?
blob - /dev/null
blob + 234f27f1cae0af810aea60e51d2f89561fd64845 (mode 644)
--- /dev/null
+++ ex2-3.lisp
@@ -0,0 +1,24 @@
+(defun rect-perimeter (rect)
+ (+ (* 2 (rect-width rect))
+ (* 2 (rect-height rect))))
+(defun rect-area (rect)
+ (* (rect-width rect)
+ (rect-height rect)))
+
+
+(defun make-rect (p1 p2)
+ (cons p1 p2))
+(defun rect-width (rect)
+ (abs (- (x-point (car rect))
+ (x-point (cdr rect)))))
+(defun rect-height (rect)
+ (abs (- (y-point (car rect))
+ (y-point (cdr rect)))))
+(defun make-rect (p1 p2)
+ (make-segment p1 p2))
+(defun rect-width (rect)
+ (abs (- (x-point (start-segment rect))
+ (x-point (end-segment rect)))))
+(defun rect-height (rect)
+ (abs (- (y-point (start-segment rect))
+ (y-point (end-segment rect)))))
blob - /dev/null
blob + 7825e09cb680c620c5193d9dfbfa4735649a011a (mode 644)
--- /dev/null
+++ ex2-3.lisp~
@@ -0,0 +1,7 @@
+(defun rect-perimeter (rect)
+ (+ (* 2 (rect-width rect))
+ (* 2 (rect-height rect))))
+(defun rect-area (rect)
+ (* (rect-width rect)
+ (rect-height rect)))
+
blob - /dev/null
blob + f37f238c408a44aa666aad0a1c45fcbd322cfc33 (mode 644)
--- /dev/null
+++ ex2-3.scm
@@ -0,0 +1,103 @@
+(define (make-point x y)
+ (cons x y))
+(define (x-point p)
+ (car p))
+(define (y-point p)
+ (cdr p))
+
+(define (make-segment start end)
+ (cons start end))
+(define (start-segment seg)
+ (car seg))
+(define (end-segment seg)
+ (cdr seg))
+(define (midpoint-segment seg)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (let ((x1 (x-point (start-segment seg)))
+ (x2 (x-point (end-segment seg)))
+ (y1 (y-point (start-segment seg)))
+ (y2 (y-point (end-segment seg))))
+ (make-point (average x1 x2)
+ (average y1 y2))))
+
+(define (print-point p)
+ (newline)
+ (display "(")
+ (display (x-point p))
+ (display ",")
+ (display (y-point p))
+ (display ")"))
+
+(define x1y2 (make-point 1 2))
+(define x-4y-3 (make-point -4 -3))
+(define x1y2tox-4y-3 (make-segment x1y2 x-4y-3))
+(print-point (midpoint-segment x1y2tox-4y-3))
+(display "=(-3/2,-1/2)")
+
+;; Exercise 2.3. Implement a representation for rectangles in a plane. (Hint: You may want to make use of exercise 2.2.) In terms of your constructors and selectors, create procedures that compute the perimeter and the area of a given rectangle. Now implement a different representation for rectangles. Can you design your system with suitable abstraction barriers, so that the same perimeter and area procedures will work using either representation?
+
+;; makes rectangle given 2 points: top-left and bottom-right
+(define (make-rect tl br)
+ (let ((tr (make-point (x-point br) (y-point tl)))
+ (bl (make-point (x-point tl) (y-point br))))
+ (cons (cons tl tr)
+ (cons bl br))))
+(define (top-left rect)
+ (caar rect))
+(define (bot-right rect)
+ (cddr rect))
+(define (top-right rect)
+ (cdar rect))
+(define (bot-left rect)
+ (cadr rect))
+
+(define (width rect)
+ (- (x-point (top-right rect)) (x-point (top-left rect))))
+(define (height rect)
+ (- (y-point (top-left rect)) (y-point (bot-left rect))))
+
+(define (perimeter rect)
+ (+ (* 2 (width rect))
+ (* 2 (height rect))))
+(define (area rect)
+ (* (width rect) (height rect)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define tl (make-point 1 6))
+(define br (make-point 10 3))
+(define rect (make-rect tl br))
+(test-case (perimeter rect) 24)
+(test-case (area rect) 27)
+
+;; makes rectangle given top-left corner, width, and height
+(define (make-rect top-left width height)
+ (cons top-left (cons width height)))
+(define (top-left rect)
+ (car rect))
+(define (bot-right rect)
+ (make-rect (+ (x-point (top-left rect))
+ (width rect))
+ (- (y-point (top-left rect))
+ (height rect))))
+(define (top-right rect)
+ (make-rect (+ (x-point (top-left rect))
+ (width rect))
+ (y-point (top-left rect))))
+(define (bot-left rect)
+ (make-rect (x-point (top-left rect))
+ (- (y-point (top-left rect))
+ (height rect))))
+
+(define (width rect)
+ (cadr rect))
+(define (height rect)
+ (cddr rect))
+
+(define rect (make-rect tl 9 3))
+(test-case (perimeter rect) 24)
+(test-case (area rect) 27)
blob - /dev/null
blob + 77fd0e99bceb2dd4de3b3486482fe3406e5cf2bd (mode 644)
--- /dev/null
+++ ex2-3.scm~
@@ -0,0 +1,73 @@
+;; Exercise 2.2. Consider the problem of representing line segments in a plane. Each segment is represented as a pair of points: a starting point and an ending point. Define a constructor make-segment and selectors start-segment and end-segment that define the representation of segments in terms of points. Furthermore, a point can be represented as a pair of numbers: the x coordinate and the y coordinate. Accordingly, specify a constructor make-point and selectors x-point and y-point that define this representation. Finally, using your selectors and constructors, define a procedure midpoint-segment that takes a line segment as argument and returns its midpoint (the point whose coordinates are the average of the coordinates of the endpoints). To try your procedures, you'll need a way to print points:
+
+(define (make-point x y)
+ (cons x y))
+(define (x-point p)
+ (car p))
+(define (y-point p)
+ (cdr p))
+
+(define (make-segment start end)
+ (cons start end))
+(define (start-segment seg)
+ (car seg))
+(define (end-segment seg)
+ (cdr seg))
+(define (midpoint-segment seg)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (let ((x1 (x-point (start-segment seg)))
+ (x2 (x-point (end-segment seg)))
+ (y1 (y-point (start-segment seg)))
+ (y2 (y-point (end-segment seg))))
+ (make-point (average x1 x2)
+ (average y1 y2))))
+
+(define (print-point p)
+ (newline)
+ (display "(")
+ (display (x-point p))
+ (display ",")
+ (display (y-point p))
+ (display ")"))
+
+(define x1y2 (make-point 1 2))
+(define x-4y-3 (make-point -4 -3))
+(define x1y2tox-4y-3 (make-segment x1y2 x-4y-3))
+(print-point (midpoint-segment x1y2tox-4y-3))
+(display "=(-3/2,-1/2)")
+
+;; Exercise 2.3. Implement a representation for rectangles in a plane. (Hint: You may want to make use of exercise 2.2.) In terms of your constructors and selectors, create procedures that compute the perimeter and the area of a given rectangle. Now implement a different representation for rectangles. Can you design your system with suitable abstraction barriers, so that the same perimeter and area procedures will work using either representation?
+
+;; makes rectangle given 4 points: top-left, top-right, bottom-left, bottom-right
+;; (define (make-rect tl tr bl br)
+;; (cons (cons tl tr)
+;; (cons bl br)))
+;; (define (top-left rect)
+;; (caar rect))
+;; (define (top-right rect)
+;; (cdar rect))
+;; (define (bot-left rect)
+;; (cadr rect))
+;; (define (bot-right rect)
+;; (cddr rect))
+
+;; makes rectangle given 2 points: top-left and bottom-right
+(define (make-rect tl br)
+ (let ((tr (make-point (x-point br) (y-point tl)))
+ (bl (make-point (x-point tl) (y-point br))))
+ (cons (cons tl tr)
+ (cons bl br))))
+(define (top-left rect)
+ (caar rect))
+(define (bot-right rect)
+ (cddr rect))
+(define (top-right rect)
+ (cdar rect))
+(define (bot-left rect)
+ (cadr rect))
+
+
+
+(define (perimeter rect)
+
blob - /dev/null
blob + f14b7e46f1d8c296e0ff1c88cb4a89e032d1deba (mode 644)
--- /dev/null
+++ ex2-30.lisp
@@ -0,0 +1,21 @@
+(defun square-tree-direct (tree)
+ (cond ((null tree) nil)
+ ((not (consp tree)) (square tree))
+ (t (cons (square-tree-direct (car tree))
+ (square-tree-direct (cdr tree))))))
+
+(defun square-tree-map (tree)
+ (mapcar
+ (lambda (subtree)
+ (if (consp subtree)
+ (square-tre-map subtree)
+ (square subtree)))
+ tree))
+
+(defun tree-map (func tree)
+ (mapcar
+ (lambda (subtree)
+ (if (consp subtree)
+ (tree-map func subtree)
+ (funcall func subtree)))
+ tree))
blob - /dev/null
blob + 93373f06135a4218d90c174edd7c98bb449a090f (mode 644)
--- /dev/null
+++ ex2-30.lisp~
@@ -0,0 +1,3 @@
+(defun square-tree-direct (tree)
+ (cond ((null tree) nil)
+ ((not (consp tree))
blob - /dev/null
blob + 259310f1b679d6b8e29c696a2af58db170848ec3 (mode 644)
--- /dev/null
+++ ex2-30.scm
@@ -0,0 +1,50 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+;; Exercise 2.30. Define a procedure square-tree analogous to the square-list procedure of exercise 2.21. That is, square-list should behave as follows:
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+(test-case (square-tree
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+;; Define square-tree both directly (i.e., without using any higher-order procedures) and also by using map and recursion.
+
+(define (square-tree-map tree)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (square-tree-map sub-tree)
+ (* sub-tree sub-tree)))
+ tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
blob - /dev/null
blob + a3782ca66e74392fdae6f46fe59a15d2207cecd9 (mode 644)
--- /dev/null
+++ ex2-30.scm~
@@ -0,0 +1,5 @@
+(define (scale-tree tree factor)
+ (cond ((null? tree) nil)
+ ((not (pair? tree)) (* tree factor))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor))
blob - /dev/null
blob + f27ee80831261b973a70e7a29d6f1ea5f0326ec8 (mode 644)
--- /dev/null
+++ ex2-31.scm
@@ -0,0 +1,71 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+;; (test-case (square-tree
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; (define (square-tree-map tree)
+;; (map (lambda (sub-tree)
+;; (if (pair? sub-tree)
+;; (square-tree-map sub-tree)
+;; (* sub-tree sub-tree)))
+;; tree))
+
+;; (test-case (square-tree-map
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; Exercise 2.31. Abstract your answer to exercise 2.30 to produce a procedure tree-map with the property that square-tree could be defined as
+
+(define (tree-map proc tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (proc tree))
+ (else (cons (tree-map proc (car tree))
+ (tree-map proc (cdr tree))))))
+
+(define (square-tree-map tree) (tree-map square tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+
+;; Exercise 2.32. We can represent a set as a list of distinct elements, and we can represent the set of all subsets of the set as a list of lists. For example, if the set is (1 2 3), then the set of all subsets is (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)). Complete the following definition of a procedure that generates the set of subsets of a set and give a clear explanation of why it works:
+
+(define (subsets s)
+ (if (null? s)
+ (list nil)
+ (let ((rest (subsets (cdr s))))
+ (append rest (map <??> rest)))))
blob - /dev/null
blob + 259310f1b679d6b8e29c696a2af58db170848ec3 (mode 644)
--- /dev/null
+++ ex2-31.scm~
@@ -0,0 +1,50 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+;; Exercise 2.30. Define a procedure square-tree analogous to the square-list procedure of exercise 2.21. That is, square-list should behave as follows:
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+(test-case (square-tree
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+;; Define square-tree both directly (i.e., without using any higher-order procedures) and also by using map and recursion.
+
+(define (square-tree-map tree)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (square-tree-map sub-tree)
+ (* sub-tree sub-tree)))
+ tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
blob - /dev/null
blob + 163245e47bf967fc14ee3108d627f444d4f2784f (mode 644)
--- /dev/null
+++ ex2-32.lisp
@@ -0,0 +1,9 @@
+(defun powerset (s)
+ (if (null s)
+ (list nil)
+ (let ((rest (powerset (cdr s))))
+ (append
+ rest
+ (mapcar (lambda (r)
+ (cons (car s) r))
+ rest)))))
blob - /dev/null
blob + c826619bb044ff9d6bc740200c684d7cf1ecb6e5 (mode 644)
--- /dev/null
+++ ex2-32.lisp~
@@ -0,0 +1,4 @@
+(defun powerset (s)
+ (if (null s)
+ (list nil)
+ (let ((rest (powerset (cdr s))))
blob - /dev/null
blob + 51111e76430cdf8d1e8899259f08f89767817885 (mode 644)
--- /dev/null
+++ ex2-32.scm
@@ -0,0 +1,28 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.32. We can represent a set as a list of distinct elements, and we can represent the set of all subsets of the set as a list of lists. For example, if the set is (1 2 3), then the set of all subsets is (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)). Complete the following definition of a procedure that generates the set of subsets of a set and give a clear explanation of why it works:
+
+(define (subsets s)
+ (if (null? s)
+ '(())
+ (let ((rest (subsets (cdr s))))
+ (append rest
+ (map (lambda (subset)
+ (cons (car s) subset))
+ rest)))))
+
+(test-case (subsets '(1 2 3)) '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)))
+
+;; what we're doing here is breaking down the problem from originally trying
+;; to find all the subsets of S to instead finding the subsets
+;; of all but the first number
+;; we then take this and add it to all the subsets without the first number
+;; but now with the first number put in the front
+
blob - /dev/null
blob + f27ee80831261b973a70e7a29d6f1ea5f0326ec8 (mode 644)
--- /dev/null
+++ ex2-32.scm~
@@ -0,0 +1,71 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+;; (test-case (square-tree
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; (define (square-tree-map tree)
+;; (map (lambda (sub-tree)
+;; (if (pair? sub-tree)
+;; (square-tree-map sub-tree)
+;; (* sub-tree sub-tree)))
+;; tree))
+
+;; (test-case (square-tree-map
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; Exercise 2.31. Abstract your answer to exercise 2.30 to produce a procedure tree-map with the property that square-tree could be defined as
+
+(define (tree-map proc tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (proc tree))
+ (else (cons (tree-map proc (car tree))
+ (tree-map proc (cdr tree))))))
+
+(define (square-tree-map tree) (tree-map square tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+
+;; Exercise 2.32. We can represent a set as a list of distinct elements, and we can represent the set of all subsets of the set as a list of lists. For example, if the set is (1 2 3), then the set of all subsets is (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)). Complete the following definition of a procedure that generates the set of subsets of a set and give a clear explanation of why it works:
+
+(define (subsets s)
+ (if (null? s)
+ (list nil)
+ (let ((rest (subsets (cdr s))))
+ (append rest (map <??> rest)))))
blob - /dev/null
blob + 9bfa1e6fdb3756a6df24e2319e2953cf07e046b3 (mode 644)
--- /dev/null
+++ ex2-33.lisp
@@ -0,0 +1,6 @@
+(defun my-map (p sequence)
+ (accumulate
+ (lambda (x y)
+ (cons (funcall p x) y))
+ nil
+ sequence))
blob - /dev/null
blob + f5990955e9a1f42e6b01f62d26203ef71fe31df8 (mode 644)
--- /dev/null
+++ ex2-33.scm
@@ -0,0 +1,62 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (filter predicate sequence)
+ (cond ((null? sequence) '())
+ ((predicate (car sequence))
+ (cons (car sequence)
+ (filter predicate (cdr sequence))))
+ (else (filter predicate (cdr sequence)))))
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+(define (enumerate-interval low high)
+ (if (low > high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (enumerate-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (list tree))
+ (else (append (enumerate-tree (car tree))
+ (enumerate-tree (cdr tree))))))
+
+;; Exercise 2.33. Fill in the missing expressions to complete the following definitions of some basic list-manipulation operations as accumulations:
+
+(define (map p sequence)
+ (accumulate (lambda (x y)
+ (cons (p x) y))
+ '()
+ sequence))
+
+(test-case (map square '()) '())
+(test-case (map square '(1)) '(1))
+(test-case (map square '(1 2 3 4 5)) '(1 4 9 16 25))
+
+(define (append seq1 seq2)
+ (accumulate cons
+ seq2
+ seq1))
+
+(test-case (append '() '()) '())
+(test-case (append '(1 2 3) '()) '(1 2 3))
+(test-case (append '() '(4 5 6)) '(4 5 6))
+(test-case (append '(1 2 3) '(4 5 6)) '(1 2 3 4 5 6))
+(test-case (append '((1 (2)) 3) '((4 ((5)) 6))) '((1 (2)) 3 (4 ((5)) 6)))
+
+(define (length sequence)
+ (accumulate (lambda (first accum)
+ (1+ accum))
+ 0
+ sequence))
+
+(test-case (length '()) 0)
+(test-case (length '(1 2 3)) 3)
+(test-case (length '((1 (2)) 3 (4 ((5)) 6))) 3)
blob - /dev/null
blob + b39155e64261bdca59cbd2f977b3505baaa6f171 (mode 644)
--- /dev/null
+++ ex2-33.scm~
@@ -0,0 +1,59 @@
+(define (sum-odd-squares tree)
+ (cond ((null? tree) 0)
+ ((not (pair? tree))
+ (if (odd? tree) (square tree) 0))
+ (else (+ (sum-odd-squares (car tree))
+ (sum-odd-squares (cdr tree))))))
+
+(define (even-fibs n)
+ (define (next k)
+ (if (> k n)
+ '()
+ (let ((f (fib k)))
+ (if (even? f)
+ (cons f (next (1+ k)))
+ (next (1+ k))))))
+ (next 0))
+
+(map square (list 1 2 3 4 5))
+
+(define (filter predicate sequence)
+ (cond ((null? sequence) '())
+ ((predicate (car sequence))
+ (cons (car sequence)
+ (filter predicate (cdr sequence))))
+ (else (filter predicate (cdr sequence)))))
+
+(filter odd? (list 1 2 3 4 5))
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+(accumulate + 0 (list 1 2 3 4 5))
+(accumulate * 1 (list 1 2 3 4 5))
+(accumulate cons nil (list 1 2 3 4 5))
+
+(define (enumerate-interval low high)
+ (if (low > high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (enumerate-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (list tree))
+ (else (append (enumerate-tree (car tree))
+ (enumerate-tree (cdr tree))))))
+(enumerate-tree (list 1 (list 2 (list 3 4)) 5))
+
+(define (sum-odd-squares tree)
+ (accumulate +
+ 0
+ (map square
+ (filter odd?
+ (enumerate-tree tree)))))
+(define (even-fibs n)
+ (accumulate cons
+ nil
+ (filter even?
+ (map fib
+ (enumerate-interval 0 n)))))
blob - /dev/null
blob + 7d4c0140643c714cf9c2018428019fbd419e1c1d (mode 644)
--- /dev/null
+++ ex2-34.lisp
@@ -0,0 +1,6 @@
+(defun horner-eval (x coeffs)
+ (accumulate
+ (lambda (this-coeff higher-terms)
+ (+ (* x higher-terms) this-coeff))
+ 0
+ coeffs))
blob - /dev/null
blob + 434e0f2323dead698f5db4fea97c302d990c539d (mode 644)
--- /dev/null
+++ ex2-34.scm
@@ -0,0 +1,54 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; (+ (* 2 1)
+;; 0)
+;; (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5)
+;; (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3))
+;; 1)
+
+;; the pattern sort of looks like this in pseudo-code
+;; (+ (* 2 (horner-eval 2 (cdr coefficient-sequence)))
+;; (car coefficient-sequence))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (lambda (coefficient remaining-horner)
+ (+ coefficient
+ (* x remaining-horner)))
+ 0
+ coefficient-sequence))
+
+(test-case (horner-eval 0 '()) 0)
+(test-case (horner-eval 10 '()) 0)
+(test-case (horner-eval 0 '(1)) 1)
+(test-case (horner-eval 2 '(1 3 0 5 0 1)) 79)
+(test-case (horner-eval -1 '(2 4 1 1 8 3)) 3)
+(test-case (horner-eval 1.23 '(3 5 2 9 4)) 38.079068639999996)
+
blob - /dev/null
blob + a825b510010bbbe14243492e7b7993373599cadd (mode 644)
--- /dev/null
+++ ex2-34.scm~
@@ -0,0 +1 @@
+(define (horner-eval x coefficient-sequence)
blob - /dev/null
blob + d6dbae243ab808c1e9317ada91efc5d4d860984b (mode 644)
--- /dev/null
+++ ex2-35.lisp
@@ -0,0 +1,9 @@
+(defun count-leaves (tree)
+ (accumulate
+ (lambda (x y)
+ (+ y
+ (if (consp x)
+ (count-leaves x)
+ 1)))
+ 0
+ tree))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 9639ea0c3f7933d11c3e5511bca3f6f858f6134e (mode 644)
--- /dev/null
+++ ex2-35.scm
@@ -0,0 +1,42 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (lambda (coefficient remaining-horner)
+ (+ coefficient
+ (* x remaining-horner)))
+ 0
+ coefficient-sequence))
+
+;; (test-case (horner-eval 0 '()) 0)
+;; (test-case (horner-eval 10 '()) 0)
+;; (test-case (horner-eval 0 '(1)) 1)
+;; (test-case (horner-eval 2 '(1 3 0 5 0 1)) 79)
+;; (test-case (horner-eval -1 '(2 4 1 1 8 3)) 3)
+;; (test-case (horner-eval 1.23 '(3 5 2 9 4)) 38.079068639999996)
+
+;; Exercise 2.35. Redefine count-leaves from section 2.2.2 as an accumulation:
+
+(define (count-leaves t)
+ (accumulate + 0 (map (lambda (subtree)
+ (cond ((null? subtree) 0)
+ ((not (pair? subtree)) 1)
+ (else (count-leaves subtree))))
+ t)))
+
+(test-case (count-leaves '()) 0)
+(test-case (count-leaves '(((())) () (() (())))) 0)
+(test-case (count-leaves '(2 3 0 9 8)) 5)
+(test-case (count-leaves '((2) (1 (2 5 (8 (9) 3) 2)) 4)) 9)
blob - /dev/null
blob + 434e0f2323dead698f5db4fea97c302d990c539d (mode 644)
--- /dev/null
+++ ex2-35.scm~
@@ -0,0 +1,54 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; (+ (* 2 1)
+;; 0)
+;; (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5)
+;; (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3))
+;; 1)
+
+;; the pattern sort of looks like this in pseudo-code
+;; (+ (* 2 (horner-eval 2 (cdr coefficient-sequence)))
+;; (car coefficient-sequence))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (lambda (coefficient remaining-horner)
+ (+ coefficient
+ (* x remaining-horner)))
+ 0
+ coefficient-sequence))
+
+(test-case (horner-eval 0 '()) 0)
+(test-case (horner-eval 10 '()) 0)
+(test-case (horner-eval 0 '(1)) 1)
+(test-case (horner-eval 2 '(1 3 0 5 0 1)) 79)
+(test-case (horner-eval -1 '(2 4 1 1 8 3)) 3)
+(test-case (horner-eval 1.23 '(3 5 2 9 4)) 38.079068639999996)
+
blob - /dev/null
blob + cbf87a2f2259d646d5f72cb57b4d1530276bc7b1 (mode 644)
--- /dev/null
+++ ex2-35b.scm
@@ -0,0 +1,3 @@
+(define (count-leaves t)
+ (accumulate + 0 (map (lambda (x) 1)
+ (enumerate-tree t))))
blob - /dev/null
blob + eb52c35a60e7188f3859806d6f912212dccd8045 (mode 644)
--- /dev/null
+++ ex2-36.lisp
@@ -0,0 +1,5 @@
+(defun accumulate-n (op init seqs)
+ (if (null (car seqs))
+ nil
+ (cons (accumulate op init (mapcar #'car seqs))
+ (accumulate-n op init (mapcar #'cdr seqs)))))
blob - /dev/null
blob + 62a3b2721e6826c826c61b409cbc8b358238c365 (mode 644)
--- /dev/null
+++ ex2-36.lisp~
@@ -0,0 +1,4 @@
+(defun accumulate-n (op init seqs)
+ (if (null (car seqs))
+ nil
+ (cons (accumulate op init (mapcar #'car seqs
blob - /dev/null
blob + 2de1ccb6914ef9a38ee91bdd2e89e67c32f2a0f8 (mode 644)
--- /dev/null
+++ ex2-36.scm
@@ -0,0 +1,26 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+;; Exercise 2.36. The procedure accumulate-n is similar to accumulate except that it takes as its third argument a sequence of sequences, which are all assumed to have the same number of elements. It applies the designated accumulation procedure to combine all the first elements of the sequences, all the second elements of the sequences, and so on, and returns a sequence of the results. For instance, if s is a sequence containing four sequences, ((1 2 3) (4 5 6) (7 8 9) (10 11 12)), then the value of (accumulate-n + 0 s) should be the sequence (22 26 30). Fill in the missing expressions in the following definition of accumulate-n:
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+(test-case (accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12))) '(22 26 30))
+(test-case (accumulate-n + 0 '(() () ())) '())
+;; (test-case (accumulate-n + 0 '()) (error "Trying to car empty list"))
+
blob - /dev/null
blob + a9f52ba493339e32fe08b64cd1c9980e2df91648 (mode 644)
--- /dev/null
+++ ex2-36.scm~
@@ -0,0 +1,7 @@
+;; Exercise 2.36. The procedure accumulate-n is similar to accumulate except that it takes as its third argument a sequence of sequences, which are all assumed to have the same number of elements. It applies the designated accumulation procedure to combine all the first elements of the sequences, all the second elements of the sequences, and so on, and returns a sequence of the results. For instance, if s is a sequence containing four sequences, ((1 2 3) (4 5 6) (7 8 9) (10 11 12)), then the value of (accumulate-n + 0 s) should be the sequence (22 26 30). Fill in the missing expressions in the following definition of accumulate-n:
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ nil
+ (cons (accumulate op init <??>)
+ (accumulate-n op init <??>))))
blob - /dev/null
blob + 4558d901835276a9f9390ef9e18a480b3d522006 (mode 644)
--- /dev/null
+++ ex2-37.lisp
@@ -0,0 +1,14 @@
+(defun dot-product (v w)
+ (accumulate #'+ 0 (mapcar #'* v w)))
+(defun matrix-*-vector (m v)
+ (mapcar
+ (lambda (row)
+ (dot-product row v))
+ m))
+(defun transpose (m)
+ (accumulate-n #'cons nil m))
+(defun matrix-*-matrix (m n)
+ (let ((n-t (transpose n)))
+ (mapcar (lambda (row)
+ (matrix-*-vector n-t row))
+ m)))
blob - /dev/null
blob + 8ba702d4e18e92ec06c4e97c5e1b7608ad5ab1a6 (mode 644)
--- /dev/null
+++ ex2-37.lisp~
@@ -0,0 +1,7 @@
+(defun dot-product (v w)
+ (accumulate #'+ 0 (mapcar #'* v w)))
+(defun matrix-*-vector (m v)
+ (mapcar
+ (lambda (row)
+ (dot-product row v))
+ m))
blob - /dev/null
blob + 8e4e1b3c24beee2ac46f403bfe1572b158df1b87 (mode 644)
--- /dev/null
+++ ex2-37.scm
@@ -0,0 +1,76 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+(define (dot-product v w)
+ (accumulate + 0 (map * v w)))
+
+(define (matrix-*-vector m v)
+ (map (lambda (row)
+ (dot-product row v))
+ m))
+
+(define (transpose mat)
+ (accumulate-n cons '() mat))
+
+(define (matrix-*-matrix m n)
+ (let ((cols (transpose n)))
+ (map (lambda (m-row)
+ (matrix-*-vector cols m-row))
+ m)))
+
+(define m1 '((1 2 3) (4 5 6) (7 8 9)))
+(define m2 '((3 1 9) (3 -2 -4) (7 0 5)))
+(define m3 '((30 36 42) (66 81 96) (102 126 150)))
+(define m4 '((3 1 9 -5 -2 1)
+ (3 -2 -4 0 4 8)
+ (7 0 5 2 3 6)))
+(define m5 '((1 5 4)
+ (2 -1 -3)
+ (0 5 0)
+ (-4 0 8)
+ (5 -1 -2)
+ (-3 -2 6)))
+(define m6 '((12 59 -21)
+ (-5 -23 58)
+ (-4 45 74)))
+(define m7 '((1 2 0 -4 5 -3)
+ (5 -1 5 0 -1 -2)
+ (4 -3 0 8 -2 6)))
+(define m8 '((3 3 7)
+ (1 -2 0)
+ (9 -4 5)
+ (-5 0 2)
+ (-2 4 3)
+ (1 8 6)))
+(define v1 '(1 2 3))
+(define v2 '(14 32 50))
+(define v3 '(2 -1 4))
+(define v4 '(41 -8 34))
+
+(test-case (matrix-*-vector m1 v1) v2)
+(test-case (matrix-*-vector m2 v3) v4)
+
+
+(test-case (transpose m5) m7)
+(test-case (transpose m4) m8)
+
+(test-case (matrix-*-matrix m1 m1) m3)
+(test-case (matrix-*-matrix m4 m5) m6)
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + fe8be662ea502dac45ca46ffb5b78989043a96c9 (mode 644)
--- /dev/null
+++ ex2-38.lisp
@@ -0,0 +1,16 @@
+(defun fold-right (op init seq)
+ (if (null seq)
+ init
+ (funcall op
+ (car seq)
+ (fold-right op init (cdr seq)))))
+(defun fold-left (op init seq)
+ (labels (
+ (iter (result rest)
+ (if (null rest)
+ result
+ (iter (funcall op result (car rest))
+ (cdr rest)))))
+ (iter init seq)))
+(fold-right #'* 1 '(1 2 3 4 5))
+(fold-left #'* 1 '(1 2 3 4 5))
blob - /dev/null
blob + 8cc7264175d8cac0041ca018845dc44931eceb49 (mode 644)
--- /dev/null
+++ ex2-38.lisp~
@@ -0,0 +1,14 @@
+(defun fold-right (op init seq)
+ (if (null seq)
+ init
+ (funcall op
+ (car seq)
+ (fold-right op init (cdr seq)))))
+(defun fold-left (op init seq)
+ (labels (
+ (iter (result rest)
+ (if (null rest)
+ result
+ (iter (funcall op result (car rest))
+ (cdr rest)))))
+ (iter init seq)))
blob - /dev/null
blob + a3451b45155a343ae430a42e41e4135477b0575c (mode 644)
--- /dev/null
+++ ex2-38.scm
@@ -0,0 +1,69 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+;; Exercise 2.38. The accumulate procedure is also known as fold-right, because it combines the first element of the sequence with the result of combining all the elements to the right. There is also a fold-left, which is similar to fold-right, except that it combines elements working in the opposite direction:
+
+(define (fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (car rest))
+ (cdr rest))))
+ (iter initial sequence))
+
+;; What are the values of
+;;(/ 1 (/ 2 (/ 3 1)))
+(test-case (fold-right / 1 (list 1 2 3)) 3/2)
+;;(/ (/ (/ 1 1) 2) 3)
+(test-case (fold-left / 1 (list 1 2 3)) 1/6)
+;;(list 1 (list 2 (list 3 '())))
+(test-case (fold-right list '() (list 1 2 3)) '(1 (2 (3 ()))))
+;;(list (list (list nil 1) 2) 3)
+(test-case (fold-left list '() (list 1 2 3)) '(((() 1) 2) 3))
+
+;; Give a property that op should satisfy to guarantee that fold-right and fold-left will produce the same values for any sequence.
+
+;; we need both associativity and commutativity
+;; associativity
+;; (op a (op b c)) = (op (op a b) c)
+;; commutativity
+;; (op a b) = (op b a)
+
+;; '(a b c)
+;; fold-right
+;; (op a (op b (op c initial)))
+;; fold-left
+;; (op (op (op initial a) b) c)
+;; associativity
+;; (op (op initial (op a b)) c)
+;; commutativity
+;; (op (op (op a b) initial) c)
+;; associativity
+;; (op (op a (op b initial)) c)
+;; associativity
+;; (op a (op (op b initial) c))
+;; associativity
+;; (op a (op b (op initial c)))
+;; commutativity
+;; (op a (op b (op c initial)))
+
+
+
blob - /dev/null
blob + 8e4e1b3c24beee2ac46f403bfe1572b158df1b87 (mode 644)
--- /dev/null
+++ ex2-38.scm~
@@ -0,0 +1,76 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+(define (dot-product v w)
+ (accumulate + 0 (map * v w)))
+
+(define (matrix-*-vector m v)
+ (map (lambda (row)
+ (dot-product row v))
+ m))
+
+(define (transpose mat)
+ (accumulate-n cons '() mat))
+
+(define (matrix-*-matrix m n)
+ (let ((cols (transpose n)))
+ (map (lambda (m-row)
+ (matrix-*-vector cols m-row))
+ m)))
+
+(define m1 '((1 2 3) (4 5 6) (7 8 9)))
+(define m2 '((3 1 9) (3 -2 -4) (7 0 5)))
+(define m3 '((30 36 42) (66 81 96) (102 126 150)))
+(define m4 '((3 1 9 -5 -2 1)
+ (3 -2 -4 0 4 8)
+ (7 0 5 2 3 6)))
+(define m5 '((1 5 4)
+ (2 -1 -3)
+ (0 5 0)
+ (-4 0 8)
+ (5 -1 -2)
+ (-3 -2 6)))
+(define m6 '((12 59 -21)
+ (-5 -23 58)
+ (-4 45 74)))
+(define m7 '((1 2 0 -4 5 -3)
+ (5 -1 5 0 -1 -2)
+ (4 -3 0 8 -2 6)))
+(define m8 '((3 3 7)
+ (1 -2 0)
+ (9 -4 5)
+ (-5 0 2)
+ (-2 4 3)
+ (1 8 6)))
+(define v1 '(1 2 3))
+(define v2 '(14 32 50))
+(define v3 '(2 -1 4))
+(define v4 '(41 -8 34))
+
+(test-case (matrix-*-vector m1 v1) v2)
+(test-case (matrix-*-vector m2 v3) v4)
+
+
+(test-case (transpose m5) m7)
+(test-case (transpose m4) m8)
+
+(test-case (matrix-*-matrix m1 m1) m3)
+(test-case (matrix-*-matrix m4 m5) m6)
blob - /dev/null
blob + 0593d5bce8106107840a8155791b080d4b4c010e (mode 644)
--- /dev/null
+++ ex2-39.lisp
@@ -0,0 +1,11 @@
+(defun reverse-r (seq)
+ (fold-right (lambda (x y)
+ (append y (list x)))
+ nil
+ seq))
+
+(defun reverse-l (seq)
+ (fold-left (lambda (x y)
+ (cons y x))
+ nil
+ seq))
blob - /dev/null
blob + 578c54ae03ffbdf77b82a27b5435d003d0031de1 (mode 644)
--- /dev/null
+++ ex2-39.lisp~
@@ -0,0 +1,5 @@
+(defun reverse-r (seq)
+ (fold-right (lambda (x y)
+ (append y (list x)))
+ nil
+ seq))
blob - /dev/null
blob + e5527b13b7e813435e95bac7269fc5a7aa1c18da (mode 644)
--- /dev/null
+++ ex2-39.scm
@@ -0,0 +1,29 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.39. Complete the following definitions of reverse (exercise 2.18) in terms of fold-right and fold-left from exercise 2.38:
+
+(define (reverse-right sequence)
+ (fold-right (lambda (x y)
+ (append y
+ (list x)))
+ '()
+ sequence))
+(define (reverse-left sequence)
+ (fold-left (lambda (x y)
+ (cons y x))
+ '()
+ sequence))
+
+;; '(1 2 3 4 5 6)
+;; (iter (op result (car items)) (cdr items))
+(test-case (reverse-right '(1 2 3 4 5 6)) '(6 5 4 3 2 1))
+(test-case (reverse-right '((1 2) (3) (4 (5 6)))) '((4 (5 6)) (3) (1 2)))
+(test-case (reverse-left '(1 2 3 4 5 6)) '(6 5 4 3 2 1))
+(test-case (reverse-left '((1 2) (3) (4 (5 6)))) '((4 (5 6)) (3) (1 2)))
blob - /dev/null
blob + a3451b45155a343ae430a42e41e4135477b0575c (mode 644)
--- /dev/null
+++ ex2-39.scm~
@@ -0,0 +1,69 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+;; Exercise 2.38. The accumulate procedure is also known as fold-right, because it combines the first element of the sequence with the result of combining all the elements to the right. There is also a fold-left, which is similar to fold-right, except that it combines elements working in the opposite direction:
+
+(define (fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (car rest))
+ (cdr rest))))
+ (iter initial sequence))
+
+;; What are the values of
+;;(/ 1 (/ 2 (/ 3 1)))
+(test-case (fold-right / 1 (list 1 2 3)) 3/2)
+;;(/ (/ (/ 1 1) 2) 3)
+(test-case (fold-left / 1 (list 1 2 3)) 1/6)
+;;(list 1 (list 2 (list 3 '())))
+(test-case (fold-right list '() (list 1 2 3)) '(1 (2 (3 ()))))
+;;(list (list (list nil 1) 2) 3)
+(test-case (fold-left list '() (list 1 2 3)) '(((() 1) 2) 3))
+
+;; Give a property that op should satisfy to guarantee that fold-right and fold-left will produce the same values for any sequence.
+
+;; we need both associativity and commutativity
+;; associativity
+;; (op a (op b c)) = (op (op a b) c)
+;; commutativity
+;; (op a b) = (op b a)
+
+;; '(a b c)
+;; fold-right
+;; (op a (op b (op c initial)))
+;; fold-left
+;; (op (op (op initial a) b) c)
+;; associativity
+;; (op (op initial (op a b)) c)
+;; commutativity
+;; (op (op (op a b) initial) c)
+;; associativity
+;; (op (op a (op b initial)) c)
+;; associativity
+;; (op a (op (op b initial) c))
+;; associativity
+;; (op a (op b (op initial c)))
+;; commutativity
+;; (op a (op b (op c initial)))
+
+
+
blob - /dev/null
blob + 516f6e606368fccef350effacd6d887361602737 (mode 644)
--- /dev/null
+++ ex2-4.lisp
@@ -0,0 +1,16 @@
+(defun my-cons (x y)
+ (lambda (m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (t (error "Argument not 0 or 1 -- CONS ~S~%" m)))))
+(defun my-car (z)
+ (funcall z 0))
+(defun my-cdr (z)
+ (funcall z 1))
+
+(defun my-cons (x y)
+ (lambda (m) (funcall m x y)))
+(defun my-car (z)
+ (funcall z (lambda (p q) p)))
+(defun my-cdr (z)
+ (funcall z (lambda (p q) q)))
blob - /dev/null
blob + dc855047f37e8aab86837aa40d33a184e283a296 (mode 644)
--- /dev/null
+++ ex2-4.lisp~
@@ -0,0 +1,11 @@
+(defun my-cons (x y)
+ (lambda (m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (t (error "Argument not 0 or 1 -- CONS ~S~%" m)))))
+(defun my-car (z)
+ (funcall z 0))
+(defun my-cdr (z)
+ (funcall z 1))
+
+(defun
blob - /dev/null
blob + 207934fd7e7ee8a421e49bdf6e15e618a88ae1f1 (mode 644)
--- /dev/null
+++ ex2-4.scm
@@ -0,0 +1,17 @@
+(define (cons x y)
+ (lambda (m) (m x y)))
+(define (car z)
+ (z (lambda (p q) p)))
+
+(car (cons x y))
+((lambda (m) (m x y)) (lambda (p q) p))
+((lambda (p q) p) x y)
+x
+;; Check to see that (car (cons x y)) = x
+
+(define (cdr z)
+ (z (lambda (p q) q)))
+(cdr (cons x y))
+((lambda (m) (m x y)) (lambda (p q) q))
+((lambda (p q) q) x y)
+
blob - /dev/null
blob + 8da7a6a19bf7ec648f9ea5c03bb0b04eca7e67b7 (mode 644)
--- /dev/null
+++ ex2-4.scm~
@@ -0,0 +1,7 @@
+(make-rat n d)
+
+(define (cons x y)
+ (define (dispatch m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (else (error "Argument not 0 or 1 -- CONS" m)))))
blob - /dev/null
blob + d64c33db3841b87062780b704e949109fbe4825b (mode 644)
--- /dev/null
+++ ex2-40.lisp
@@ -0,0 +1,22 @@
+(defun enumerate-interval (low high)
+ (if (> low high)
+ nil
+ (cons low (enumerate-interval (1+ low) high))))
+(defun flatpmap (proc seq)
+ (accumulate #'append nil (mapcar proc seq)))
+(defun sum (lst)
+ (accumulate #'+ 0 lst))
+(defun prime-sum? (pair)
+ (prime? (sum pair)))
+(defun make-pair-sum (pair)
+ (list (car pair) (cadr pair) (sum pair)))
+(defun unique-pairs (n)
+ (flatmap
+ (lambda (i)
+ (mapcar (lambda (j) (list i j))
+ (enumerate-interval 1 (1- i))))
+ (enumerate-interval 1 n)))
+(defun prime-sum-pairs (n)
+ (mapcar
+ #'make-pair-sum
+ (filter #'prime-sum? (unique-pairs n))))
blob - /dev/null
blob + 3d34d67abe34e9dfb77533a4d1ffe7ae0731d509 (mode 644)
--- /dev/null
+++ ex2-40.lisp~
@@ -0,0 +1,12 @@
+(defun enumerate-interval (low high)
+ (if (> low high)
+ nil
+ (cons low (enumerate-interval (1+ low) high))))
+(defun flatpmap (proc seq)
+ (accumulate #'append nil (mapcar proc seq)))
+(defun sum (lst)
+ (accumulate #'+ 0 lst))
+(defun prime-sum? (pair)
+ (prime? (sum pair)))
+(defun make-pair-sum (pair)
+ (list (car pair) (cadr pair) (sum pair)))
blob - /dev/null
blob + 65ef1f095f9d4e5a1852f6e1630fa098a166aabf (mode 644)
--- /dev/null
+++ ex2-40.scm
@@ -0,0 +1,59 @@
+(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 (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+(define (accumulate op initial seq)
+ (if (null? seq)
+ initial
+ (op (car seq)
+ (accumulate op initial (cdr seq)))))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(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 (permutations s)
+ (if (null? s)
+ '(())
+ (flatmap (lambda (x)
+ (map (lambda (p) (cons x p))
+ (permutations (remove x s))))
+ s)))
+(define (remove item sequence)
+ (filter (lambda (x) (not (= x item)))
+ sequence))
+(define (unique-pairs n)
+ (flatmap
+ (lambda (i)
+ (map (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter
+ prime-sum?
+ (unique-pairs n))))
+
+(prime-sum-pairs 10)
blob - /dev/null
blob + f51f776543141bf365b81af53d8e9510ec9acaf8 (mode 644)
--- /dev/null
+++ ex2-40.scm~
@@ -0,0 +1,6 @@
+(accumulate append
+ nil
+ (map (lambda (i)
+ (map (lambda (j) (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
blob - /dev/null
blob + d163a5f5c5b699695e91aa1e942d78f0f9f82e16 (mode 644)
--- /dev/null
+++ ex2-41.lisp
@@ -0,0 +1,18 @@
+(defun unique-triples (n)
+ "Unique triples of numbers <= n"
+ (flatmap
+ (lambda (i)
+ (flatmap
+ (lambda (j)
+ (mapcar
+ (lambda (k) (list i j k))
+ (enumerate-interval 1 (1- j))))
+ (enumerate-interval 1 (1- i))))
+ (enumerate-interval 1 n)))
+
+(defune triples-sum-s (s n)
+ "Triples of numbers <= n summing to s"
+ (filter
+ (lambda (triple)
+ (= (sum triple) s))
+ (unique-triples n)))
blob - /dev/null
blob + 718ac39ca226da40f171afe0b4a57509c599c66f (mode 644)
--- /dev/null
+++ ex2-41.lisp~
@@ -0,0 +1,14 @@
+(defun unique-triples (n)
+ "Unique triples of numbers <= n"
+ (flatmap
+ (lambda (i)
+ (flatmap
+ (lambda (j)
+ (mapcar
+ (lambda (k) (list i j k))
+ (enumerate-interval 1 (1- j))))
+ (enumerate-interval 1 (1- i))))
+ (enumerate-interval 1 n)))
+
+(defune triples-sum-s (s n)
+ "Triples
blob - /dev/null
blob + fc17504ae13dfb9f6867a460225752446132bbdf (mode 644)
--- /dev/null
+++ ex2-41.scm
@@ -0,0 +1,79 @@
+(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 (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+(define (accumulate op initial seq)
+ (if (null? seq)
+ initial
+ (op (car seq)
+ (accumulate op initial (cdr seq)))))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(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 (permutations s)
+ (if (null? s)
+ '(())
+ (flatmap (lambda (x)
+ (map (lambda (p) (cons x p))
+ (permutations (remove x s))))
+ s)))
+(define (remove item sequence)
+ (filter (lambda (x) (not (= x item)))
+ sequence))
+(define (unique-pairs n)
+ (flatmap
+ (lambda (i)
+ (map (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter
+ prime-sum?
+ (unique-pairs n))))
+
+;; (prime-sum-pairs 10)
+
+;; Exercise 2.41. Write a procedure to find all ordered triples of distinct positive integers i, j, and k less than or equal to a given integer n that sum to a given integer s.
+
+;; 1 <= k < j < i <= n
+(define (triples n sum)
+ (define (triple-sum? lst)
+ (= (+ (car lst)
+ (cadr lst)
+ (caddr lst)) sum))
+ (filter triple-sum?
+ (flatmap (lambda (i)
+ (flatmap (lambda (j)
+ (map (lambda (k)
+ (list i j k))
+ (enumerate-interval 1 (- j 1))))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n))))
+
+(triples 10 12)
+
blob - /dev/null
blob + 65ef1f095f9d4e5a1852f6e1630fa098a166aabf (mode 644)
--- /dev/null
+++ ex2-41.scm~
@@ -0,0 +1,59 @@
+(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 (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+(define (accumulate op initial seq)
+ (if (null? seq)
+ initial
+ (op (car seq)
+ (accumulate op initial (cdr seq)))))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(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 (permutations s)
+ (if (null? s)
+ '(())
+ (flatmap (lambda (x)
+ (map (lambda (p) (cons x p))
+ (permutations (remove x s))))
+ s)))
+(define (remove item sequence)
+ (filter (lambda (x) (not (= x item)))
+ sequence))
+(define (unique-pairs n)
+ (flatmap
+ (lambda (i)
+ (map (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter
+ prime-sum?
+ (unique-pairs n))))
+
+(prime-sum-pairs 10)
blob - /dev/null
blob + ebe074a283f14ce70f094d0fd856569161955669 (mode 644)
--- /dev/null
+++ ex2-42.lisp
@@ -0,0 +1,31 @@
+(defun make-position (row col)
+ (cons row col))
+(defun position-row (pos)
+ (car pos))
+(defun position-col (pos)
+ (cdr pos))
+(defun positions-equal (a b)
+ (equal a b))
+(defvar empty-board '())
+(defun adjoin-position (row col positions)
+ (append positions (list (make-position row col))))
+(defun attacks? (a b)
+ (let ((a-row (position-row a))
+ (a-col (position-col a))
+ (b-row (position-row b))
+ (b-col (position-col b)))
+ (cond
+ ((= a-row b-row) t)
+ ((= a-col b-col) t)
+ ((= (abs (- a-col b-col))
+ (abs (- a-row b-row))) t)
+ (t nil))))
+(defun safe? (k positions)
+ (let ((kth-pos (nth (1- k) positions)))
+ (if (null (find-if
+ (lambda (pos)
+ (and (not (positions-equal kth-pos pos))
+ (attacks? kth-pos pos)))
+ positions))
+ t
+ nil)))
blob - /dev/null
blob + 8ac27d310e198ef36f7fdbfc9315c837893f324b (mode 644)
--- /dev/null
+++ ex2-42.lisp~
@@ -0,0 +1,21 @@
+(defun make-position (row col)
+ (cons row col))
+(defun position-row (pos)
+ (car pos))
+(defun position-col (pos)
+ (cdr pos))
+(defun positions-equal (a b)
+ (equal a b))
+(defvar empty-board '())
+(defun adjoin-position (row col positions)
+ (append positions (list (make-position row col))))
+(defun attacks? (a b)
+ (let ((a-row (position-row a))
+ (a-col (position-col a))
+ (b-row (position-row b))
+ (b-col (position-col b)))
+ (cond
+ ((= a-row b-row) t)
+ ((= a-col b-col) t)
+ ((= (abs (- a-col b-col))
+ (abs (- a-row b-row)))
blob - /dev/null
blob + 3ed90f100e832506831ae6bbb495d8e73713d411 (mode 644)
--- /dev/null
+++ ex2-42.scm
@@ -0,0 +1,160 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(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))
+
+;; For example, '((2 4 1 3)) might represent a solution to the 4-queens problem. This represents having queens in col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+
+(define (same-row? row other-positions)
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ other-positions))
+
+
+(define (same-positive-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + other-positions (enumerate-interval 1 (- col 1)))))
+(define (same-negative-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - other-positions (enumerate-interval 1 (- col 1)))))
+
+(define (safe? col positions)
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (not (or (same-row? row all-but-last)
+ (same-positive-diagonal? row col all-but-last)
+ (same-negative-diagonal? row col all-but-last)))))
+
+(define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+;; ;;(test-case (exclude-last '()) "error: empty list")
+;; (test-case (exclude-last '(1)) '())
+;; (test-case (exclude-last '(1 2 3 4)) '(1 2 3))
+
+;; (test-case (adjoin-position 1 1 '()) '(1))
+;; (test-case (adjoin-position 2 1 '()) '(2))
+;; (test-case (adjoin-position 3 1 '()) '(3))
+;; (test-case (adjoin-position 4 1 '()) '(4))
+;; (test-case (adjoin-position 1 4 '(2 4 1)) '(2 4 1 1))
+;; (test-case (adjoin-position 2 4 '(2 4 1)) '(2 4 1 2))
+;; (test-case (adjoin-position 3 4 '(2 4 1)) '(2 4 1 3))
+;; (test-case (adjoin-position 4 4 '(2 4 1)) '(2 4 1 4))
+
+;; (test-case (same-row? 1 '()) #f)
+;; (test-case (same-row? 1 '(2 4 1)) #t)
+;; (test-case (same-row? 2 '(2 4 1)) #t)
+;; (test-case (same-row? 3 '(2 4 1)) #f)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 1 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 2 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 3 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 4 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 5 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 6 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 8 '(2 4 6 8 3 1)) #t)
+
+
+;; '((2 4 1))
+;; '((1 2 3 4))
+;; '(((2 4 1 1) (2 4 1 2) (2 4 1 3) (2 4 1 4)))
+;; take '(2 4 1) and append new-queen-row in the (new-queen-col - 1)st position in the list
+;; (define (adjoin-position new-queen-row new-queen-col positions)
+
+;; '(2 4 1)
+;;+ '(1 2 3)
+;;==========
+;; '(3 6 4)
+;; (test-case (same-positive-diagonal? 1 1 '()) #f)
+;; (test-case (same-positive-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-positive-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 1 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 8 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 1 1 '()) #f)
+;; (test-case (same-negative-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-negative-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 1 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 8 7 '(2 4 6 8 3 1)) #t)
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+;; The ``eight-queens puzzle'' asks how to place eight queens on a chessboard so that no queen is in check from any other (i.e., no two queens are in the same row, column, or diagonal). One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placing a queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This produces the sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.
+
+;; We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedure queen-cols that returns the sequence of all ways to place queens in the first k columns of the board.
+
+
+;; In this procedure rest-of-queens is a way to place k - 1 queens in the first k - 1 columns, and new-row is a proposed row in which to place the queen for the kth column. Complete the program by implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoins a new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You must also write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.)
+
+(queens 8)
blob - /dev/null
blob + 563dc6ff55dfc45b929e641011a0f22bac1fc79a (mode 644)
--- /dev/null
+++ ex2-42.scm~
@@ -0,0 +1,159 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+
+(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))
+
+;; For example, '((2 4 1 3)) might represent a solution to the 4-queens problem. This represents having queens in col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+
+(define (same-row? row other-positions)
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ other-positions))
+
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+(define (same-positive-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + other-positions (enumerate-interval 1 (- col 1)))))
+(define (same-negative-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - other-positions (enumerate-interval 1 (- col 1)))))
+
+(define (safe? col positions)
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (not (or (same-row? row all-but-last)
+ (same-positive-diagonal? row col all-but-last)
+ (same-negative-diagonal? row col all-but-last)))))
+
+(define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+;; ;;(test-case (exclude-last '()) "error: empty list")
+;; (test-case (exclude-last '(1)) '())
+;; (test-case (exclude-last '(1 2 3 4)) '(1 2 3))
+
+;; (test-case (adjoin-position 1 1 '()) '(1))
+;; (test-case (adjoin-position 2 1 '()) '(2))
+;; (test-case (adjoin-position 3 1 '()) '(3))
+;; (test-case (adjoin-position 4 1 '()) '(4))
+;; (test-case (adjoin-position 1 4 '(2 4 1)) '(2 4 1 1))
+;; (test-case (adjoin-position 2 4 '(2 4 1)) '(2 4 1 2))
+;; (test-case (adjoin-position 3 4 '(2 4 1)) '(2 4 1 3))
+;; (test-case (adjoin-position 4 4 '(2 4 1)) '(2 4 1 4))
+
+;; (test-case (same-row? 1 '()) #f)
+;; (test-case (same-row? 1 '(2 4 1)) #t)
+;; (test-case (same-row? 2 '(2 4 1)) #t)
+;; (test-case (same-row? 3 '(2 4 1)) #f)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 1 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 2 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 3 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 4 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 5 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 6 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 8 '(2 4 6 8 3 1)) #t)
+
+
+;; '((2 4 1))
+;; '((1 2 3 4))
+;; '(((2 4 1 1) (2 4 1 2) (2 4 1 3) (2 4 1 4)))
+;; take '(2 4 1) and append new-queen-row in the (new-queen-col - 1)st position in the list
+;; (define (adjoin-position new-queen-row new-queen-col positions)
+
+;; '(2 4 1)
+;;+ '(1 2 3)
+;;==========
+;; '(3 6 4)
+;; (test-case (same-positive-diagonal? 1 1 '()) #f)
+;; (test-case (same-positive-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-positive-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 1 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 8 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 1 1 '()) #f)
+;; (test-case (same-negative-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-negative-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 1 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 8 7 '(2 4 6 8 3 1)) #t)
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+;; The ``eight-queens puzzle'' asks how to place eight queens on a chessboard so that no queen is in check from any other (i.e., no two queens are in the same row, column, or diagonal). One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placing a queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This produces the sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.
+
+;; We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedure queen-cols that returns the sequence of all ways to place queens in the first k columns of the board.
+
+
+;; In this procedure rest-of-queens is a way to place k - 1 queens in the first k - 1 columns, and new-row is a proposed row in which to place the queen for the kth column. Complete the program by implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoins a new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You must also write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.)
+
+(queens 8)
blob - /dev/null
blob + 23d0ad751b68477d09dbe9132bf59564e77a6f99 (mode 644)
--- /dev/null
+++ ex2-42b.scm
@@ -0,0 +1,82 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(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))
+
+;; For example, '((2 4 1 3)) might represent a solution to the 4-queens problem. This represents having queens in col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
+
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(queens 8)
blob - /dev/null
blob + 3ed90f100e832506831ae6bbb495d8e73713d411 (mode 644)
--- /dev/null
+++ ex2-42b.scm~
@@ -0,0 +1,160 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(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))
+
+;; For example, '((2 4 1 3)) might represent a solution to the 4-queens problem. This represents having queens in col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+
+(define (same-row? row other-positions)
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ other-positions))
+
+
+(define (same-positive-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + other-positions (enumerate-interval 1 (- col 1)))))
+(define (same-negative-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - other-positions (enumerate-interval 1 (- col 1)))))
+
+(define (safe? col positions)
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (not (or (same-row? row all-but-last)
+ (same-positive-diagonal? row col all-but-last)
+ (same-negative-diagonal? row col all-but-last)))))
+
+(define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+;; ;;(test-case (exclude-last '()) "error: empty list")
+;; (test-case (exclude-last '(1)) '())
+;; (test-case (exclude-last '(1 2 3 4)) '(1 2 3))
+
+;; (test-case (adjoin-position 1 1 '()) '(1))
+;; (test-case (adjoin-position 2 1 '()) '(2))
+;; (test-case (adjoin-position 3 1 '()) '(3))
+;; (test-case (adjoin-position 4 1 '()) '(4))
+;; (test-case (adjoin-position 1 4 '(2 4 1)) '(2 4 1 1))
+;; (test-case (adjoin-position 2 4 '(2 4 1)) '(2 4 1 2))
+;; (test-case (adjoin-position 3 4 '(2 4 1)) '(2 4 1 3))
+;; (test-case (adjoin-position 4 4 '(2 4 1)) '(2 4 1 4))
+
+;; (test-case (same-row? 1 '()) #f)
+;; (test-case (same-row? 1 '(2 4 1)) #t)
+;; (test-case (same-row? 2 '(2 4 1)) #t)
+;; (test-case (same-row? 3 '(2 4 1)) #f)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 1 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 2 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 3 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 4 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 5 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 6 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 8 '(2 4 6 8 3 1)) #t)
+
+
+;; '((2 4 1))
+;; '((1 2 3 4))
+;; '(((2 4 1 1) (2 4 1 2) (2 4 1 3) (2 4 1 4)))
+;; take '(2 4 1) and append new-queen-row in the (new-queen-col - 1)st position in the list
+;; (define (adjoin-position new-queen-row new-queen-col positions)
+
+;; '(2 4 1)
+;;+ '(1 2 3)
+;;==========
+;; '(3 6 4)
+;; (test-case (same-positive-diagonal? 1 1 '()) #f)
+;; (test-case (same-positive-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-positive-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 1 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 8 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 1 1 '()) #f)
+;; (test-case (same-negative-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-negative-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 1 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 8 7 '(2 4 6 8 3 1)) #t)
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+;; The ``eight-queens puzzle'' asks how to place eight queens on a chessboard so that no queen is in check from any other (i.e., no two queens are in the same row, column, or diagonal). One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placing a queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This produces the sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.
+
+;; We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedure queen-cols that returns the sequence of all ways to place queens in the first k columns of the board.
+
+
+;; In this procedure rest-of-queens is a way to place k - 1 queens in the first k - 1 columns, and new-row is a proposed row in which to place the queen for the kth column. Complete the program by implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoins a new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You must also write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.)
+
+(queens 8)
blob - /dev/null
blob + ed842a7f272f8e2e30880e913e662188fca5b481 (mode 644)
--- /dev/null
+++ ex2-42c.scm
@@ -0,0 +1,83 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+(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))
+
+;; For example, '(((2 1) (4 2) (1 3) (3 4))) represents col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; (adjoin-position 1 3 '((2 1) (4 2))) = '((2 1) (4 2) (1 3))
+(define (adjoin-position row col positions)
+ (append positions (list (list row col))))
+
+
+;; not finished
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
+
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(queens 8)
blob - /dev/null
blob + 23d0ad751b68477d09dbe9132bf59564e77a6f99 (mode 644)
--- /dev/null
+++ ex2-42c.scm~
@@ -0,0 +1,82 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(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))
+
+;; For example, '((2 4 1 3)) might represent a solution to the 4-queens problem. This represents having queens in col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
+
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(queens 8)
blob - /dev/null
blob + 5794f879333a7ddbeebe241a0d495917c1c978ca (mode 644)
--- /dev/null
+++ ex2-43.lisp
@@ -0,0 +1,14 @@
+(defun louis-queens (board-size)
+ (louis-queen-cols board-size board-size))
+
+(defun louis-queen-cols (k board-size)
+ (if (= k 0)
+ (list empty-board)
+ (filter (lambda (positions) (safe k positions))
+ (flatmap
+ (lambda (new-row)
+ (mapcar
+ (lambda (rest-of-queens)
+ (adjoin-position new-row k rest-of-queens))
+ (louis-queen-cols (1- k) board-size)))
+ (enumerate-interval 1 board-size)))))
blob - /dev/null
blob + b66f5aaff72ceac9d5a2024adbbd30a9115137a6 (mode 644)
--- /dev/null
+++ ex2-43.scm
@@ -0,0 +1,17 @@
+;; (flatmap
+;; (lambda (new-row)
+;; (map (lambda (rest-of-queens)
+;; (adjoin-position new-row k rest-of-queens))
+;; (queen-cols (- k 1))))
+;; (enumerate-interval 1 board-size))
+
+;; This new mapping calls (queen-cols (- k 1)) board-size times upon each call to (queen-cols k).
+
+;; k calls to queen-cols
+;; 1 board-size
+;; 2 bs^2
+;; 3 bs^3
+;; ...
+;; bs bs^bs
+
+;; So, overall, it seems like ultimately, queen-cols is called board-size^board-size times. In the original version, queen-cols is only called board-size times. So, if it originally takes time T, the new version will take time T^T
blob - /dev/null
blob + 7a9e7474fa9cf998d91a5fc098bcba3c76f745a5 (mode 644)
--- /dev/null
+++ ex2-43.scm~
@@ -0,0 +1,6 @@
+(flatmap
+ (lambda (new-row)
+ (map (lambda (rest-of-queens)
+ (adjoin-position new-row k rest-of-queens))
+ (queen-cols (- k 1))))
+ (enumerate-interval 1 board-size))
blob - /dev/null
blob + d9aa5a327b3d20b11552fbaba4f0b126bcc31c94 (mode 644)
--- /dev/null
+++ ex2-44-sol.scm
@@ -0,0 +1,5 @@
+(define (up-split painter n)
+ (if (zero? n)
+ painter
+ (let ((smaller (up-split painter (- n 1))))
+ (below painter (beside smaller smaller)))))
blob - /dev/null
blob + 45b9cc91f79f84ede2426e2686be62e5f1fd88df (mode 644)
--- /dev/null
+++ ex2-44.scm
@@ -0,0 +1,32 @@
+(define wave2 (besides wave (flip-vert wave)))
+(define wave4 (below wave2 wave2))
+(define (flipped-pairs painter)
+ (let ((painter2 (besides painter (flip-vert painter))))
+ (below painter2 painter2)))
+(define wave4 (flipped-pairs wave))
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
blob - /dev/null
blob + 7a4a4519f088faf48fff7bfa82f1ca8f1fb6d813 (mode 644)
--- /dev/null
+++ ex2-44.scm~
@@ -0,0 +1,11 @@
+(define wave2 (besides wave (flip-vert wave)))
+(define wave4 (below wave2 wave2))
+(define (flipped-pairs painter)
+ (let ((painter2 (besides painter (flip-vert painter))))
+ (below painter2 painter2)))
+(define wave4 (flipped-pairs wave))
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
blob - /dev/null
blob + 31d4e53988825bec61dc4282913e1b904ecb8f68 (mode 644)
--- /dev/null
+++ ex2-45-sol.scm
@@ -0,0 +1,6 @@
+(define (split combine-main combine-smaller)
+ (lambda (painter n)
+ (if (zero? n)
+ painter
+ (let ((smaller ((split combine-main combine-smaller) painter (- n 1))))
+ (combine-main painter (combine-smaller smaller smaller))))))
blob - /dev/null
blob + a7307f291cb8cf2477db9ca674689202823ea506 (mode 644)
--- /dev/null
+++ ex2-45.scm
@@ -0,0 +1,49 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
blob - /dev/null
blob + 2a6706f40e3eeb09966dbf3fedb41b7b3a5b27e6 (mode 644)
--- /dev/null
+++ ex2-45.scm~
@@ -0,0 +1,5 @@
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
blob - /dev/null
blob + 2eac32acd2d3541182e02916f953743f349f1ab9 (mode 644)
--- /dev/null
+++ ex2-46.scm
@@ -0,0 +1,74 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
blob - /dev/null
blob + a7307f291cb8cf2477db9ca674689202823ea506 (mode 644)
--- /dev/null
+++ ex2-46.scm~
@@ -0,0 +1,49 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
blob - /dev/null
blob + 1933a287c2e7427f0176b5d136f629d14940e4cf (mode 644)
--- /dev/null
+++ ex2-47-sol.scm
@@ -0,0 +1,13 @@
+(define (add-vect u v)
+ (make-vect
+ (+ (xcor-vect u) (xcor-vect v))
+ (+ (ycor-vect u) (ycor-vect v))))
+(define (sub-vect u v)
+ (make-vect
+ (- (xcor-vect u) (xcor-vect v))
+ (- (ycor-vect u) (ycor-vect v))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* s (ycor-vect v))))
+
+
blob - /dev/null
blob + ee4519baaddd0d9f9c83d2f8bfcf3d84874ab49e (mode 644)
--- /dev/null
+++ ex2-47-sol.scm~
@@ -0,0 +1,10 @@
+(define (make-frame dc origin edge1 edge2)
+ (list dc origin edge1 edge2))
+(define (dc-frame f)
+ (car f))
+(define (origin-frame f)
+ (cadr f))
+(define (edge1-frame f)
+ (caddr f))
+(define (edge2-frame f)
+ (cadddr f))
blob - /dev/null
blob + f02d7084f2b99dff052ce18541dff219df227b7c (mode 644)
--- /dev/null
+++ ex2-47.scm
@@ -0,0 +1,95 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (make-frame origin edge1 edge2)
+ (cons origin (cons edge1 edge2)))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (cddr frame))
+
blob - /dev/null
blob + 2eac32acd2d3541182e02916f953743f349f1ab9 (mode 644)
--- /dev/null
+++ ex2-47.scm~
@@ -0,0 +1,74 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
blob - /dev/null
blob + 09523fc4ef39347c9828a079d0752893cd0b0a07 (mode 644)
--- /dev/null
+++ ex2-48.scm
@@ -0,0 +1,109 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
blob - /dev/null
blob + f02d7084f2b99dff052ce18541dff219df227b7c (mode 644)
--- /dev/null
+++ ex2-48.scm~
@@ -0,0 +1,95 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (make-frame origin edge1 edge2)
+ (cons origin (cons edge1 edge2)))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (cddr frame))
+
blob - /dev/null
blob + 3cdfa4181430c88c36b89e27d74f4eb3f854ad42 (mode 644)
--- /dev/null
+++ ex2-49.scm
@@ -0,0 +1,130 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
blob - /dev/null
blob + 09523fc4ef39347c9828a079d0752893cd0b0a07 (mode 644)
--- /dev/null
+++ ex2-49.scm~
@@ -0,0 +1,109 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
blob - /dev/null
blob + e4bb84abebbfeb3a0095bbcc90d8a1cc732015ae (mode 644)
--- /dev/null
+++ ex2-5.lisp
@@ -0,0 +1,12 @@
+(defun divides? (a b)
+ (= (rem b a) 0))
+(defun my-cons (a b)
+ (* (expt 2 a) (expt 3 b)))
+(defun my-car (z)
+ (do ( (n 0 (1+ n))
+ (aa z (/ aa 2)))
+ ((not (divides? 2 aa)) n)))
+(defun my-cdr (z)
+ (do ( (n 0 (1+ n))
+ (aa z (/ aa 3)))
+ ((not (divides? 3 aa)) n)))
blob - /dev/null
blob + 232b68da7db0eb9a96e5adeb9afa3a4d06f7815a (mode 644)
--- /dev/null
+++ ex2-5.scm
@@ -0,0 +1,34 @@
+;; Exercise 2.5. Show that we can represent pairs of nonnegative integers using only numbers and arithmetic operations if we represent the pair a and b as the integer that is the product 2^a 3^b. Give the corresponding definitions of the procedures cons, car, and cdr.
+
+(define (expt base n)
+ (if (= n 0)
+ 1
+ (* base (expt base (- n 1)))))
+
+(define (cons a b)
+ (* (expt 2 a)
+ (expt 3 b)))
+
+(define (car x)
+ (if (not (= (remainder x 2) 0))
+ 0
+ (1+ (car (/ x 2)))))
+(define (cdr x)
+ (if (not (= (remainder x 3) 0))
+ 0
+ (1+ (cdr (/ x 3)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (car (cons 5 9)) 5)
+(test-case (cdr (cons 5 9)) 9)
+(test-case (car (cons 12 25)) 12)
+(test-case (cdr (cons 12 25)) 25)
+(test-case (car (cons 0 1)) 0)
+(test-case (cdr (cons 1 0)) 0)
+(test-case (car (cons 0 6)) 0)
+(test-case (cdr (cons 9 0)) 0)
+
blob - /dev/null
blob + dc855047f37e8aab86837aa40d33a184e283a296 (mode 644)
--- /dev/null
+++ ex2-5.scm~
@@ -0,0 +1,11 @@
+(defun my-cons (x y)
+ (lambda (m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (t (error "Argument not 0 or 1 -- CONS ~S~%" m)))))
+(defun my-car (z)
+ (funcall z 0))
+(defun my-cdr (z)
+ (funcall z 1))
+
+(defun
blob - /dev/null
blob + 692e9fa001335945a27e2b573c5ff91c6a8ee68a (mode 644)
--- /dev/null
+++ ex2-50.scm
@@ -0,0 +1,198 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below
blob - /dev/null
blob + 3cdfa4181430c88c36b89e27d74f4eb3f854ad42 (mode 644)
--- /dev/null
+++ ex2-50.scm~
@@ -0,0 +1,130 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
blob - /dev/null
blob + 99cc7b1c488a94fb6e360e77d80a2565dcceacf3 (mode 644)
--- /dev/null
+++ ex2-51-sol.scm
@@ -0,0 +1,29 @@
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter
+ painter2
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (paint-down
+ (transform-painter
+ painter1
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0))))
+ (lambda (frame)
+ (paint-up frame)
+ (paint-down frame))))
+(define (below-rot painter1 painter2)
+ (rotate90 (beside
+ (rotate270 painter1)
+ (rotate270 painter2))))
+
+ Exercise 2.52. Make changes to the square limit of wave shown in figure 2.9 by working at each of the levels described above. In particular:
+
+a. Add some segments to the primitive wave painter of exercise 2.49 (to add a smile, for example).
+
+b. Change the pattern constructed by corner-split (for example, by using only one copy of the up-split and right-split images instead of two).
+
+c. Modify the version of square-limit that uses square-of-four so as to assemble the corners in a different pattern. (For example, you might make the big Mr. Rogers look outward from each corner of the square.)
blob - /dev/null
blob + 8fcac70745f248c035906e8851e256f928d9357c (mode 644)
--- /dev/null
+++ ex2-51-sol.scm~
@@ -0,0 +1 @@
+(define (below
blob - /dev/null
blob + 2505bfe40c66f911c2bd0320ffff43de19e2384a (mode 644)
--- /dev/null
+++ ex2-51.scm
@@ -0,0 +1,217 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below bottom top)
+ (lambda (frame)
+ (let ((split-point (make-vector 0.0 0.5)))
+ (bot-transform (transform-painter bottom
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (top-transform (transform-painter top
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0)))
+ (bottom frame)
+ (top frame))))
+(define (below bottom top)
+ (rotate90 (beside (rotate270 bottom) (rotate270 top))))
+
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter painter2
blob - /dev/null
blob + 692e9fa001335945a27e2b573c5ff91c6a8ee68a (mode 644)
--- /dev/null
+++ ex2-51.scm~
@@ -0,0 +1,198 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below
blob - /dev/null
blob + e4987ef682a984daa274925591aa5c6651d0ab00 (mode 644)
--- /dev/null
+++ ex2-52.scm
@@ -0,0 +1,228 @@
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below bottom top)
+ (lambda (frame)
+ (let ((split-point (make-vector 0.0 0.5)))
+ (bot-transform (transform-painter bottom
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (top-transform (transform-painter top
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0)))
+ (bottom frame)
+ (top frame))))
+(define (below bottom top)
+ (rotate90 (beside (rotate270 bottom) (rotate270 top))))
+
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter painter2
+
+;; Exercise 2.52. Make changes to the square limit of wave shown in figure 2.9 by working at each of the levels described above. In particular:
+
+;; c. Modify the version of square-limit that uses square-of-four so as to assemble the corners in a different pattern. (For example, you might make the big Mr. Rogers look outward from each corner of the square.)
+
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four identity flip-horiz
+ flip-vert (compose flip-vert flip-horiz))))
+;;rotate180
+ (combine4 (corner-split painter n))))
+
blob - /dev/null
blob + 3d5ad8284468ab19965af719f6db930d4a5644c8 (mode 644)
--- /dev/null
+++ ex2-52.scm~
@@ -0,0 +1,24 @@
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter
+ painter2
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (paint-down
+ (transform-painter
+ painter1
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0))))
+ (lambda (frame)
+ (paint-up frame)
+ (paint-down frame))))
+(define (below-rot painter1 painter2)
+ (rotate90 (beside
+ (rotate270 painter1)
+ (rotate270 painter2))))
+
+ Exercise 2.52. Make changes to the square limit of wave shown in figure 2.9 by working at each of the levels described above. In particular:
+
blob - /dev/null
blob + 85f3859a5893cc3af1712322613c309d8ca04608 (mode 644)
--- /dev/null
+++ ex2-53.lisp
@@ -0,0 +1,6 @@
+(defun memq (item x)
+ (cond ((null x) nil)
+ ((eql item (car x)) x)
+ (t (memq item (cdr x)))))
+
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + b365a57954a233c8225d1db16bcc33a008d0ee16 (mode 644)
--- /dev/null
+++ ex2-53.scm
@@ -0,0 +1,20 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+(test-case (list 'a 'b 'c) '(a b c))
+(test-case (list (list 'george)) '((george)))
+(test-case (cdr '((x1 x2) (y1 y2))) '((y1 y2)))
+(test-case (cadr '((x1 x2) (y1 y2))) '(y1 y2))
+(test-case (pair? (car '(a short list))) #f)
+(test-case (memq 'red '((red shoes) (blue socks))) #f)
+(test-case (memq 'red '(red shoes blue socks)) '(red shoes blue socks))
blob - /dev/null
blob + 9160f9f4ab4df631708415f26d6a19582730ea1c (mode 644)
--- /dev/null
+++ ex2-53.scm~
@@ -0,0 +1,2 @@
+(* (+ 23 45) (+ x 9))
+(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))
blob - /dev/null
blob + 3f82db01cc48dce390acd81990a37b8b36e385b3 (mode 644)
--- /dev/null
+++ ex2-54-sol.scm
@@ -0,0 +1,9 @@
+(define (equal? p1 p2)
+ (cond ((and (null? p1) (null? p2)) #t)
+ ((or (null? p1) (null? p2)) #f)
+ ((and (pair? p1) (pair? p2))
+ (and (equal? (car p1) (car p2))
+ (equal? (cdr p1) (cdr p2))))
+ ((or (pair? p1) (pair? p2)) #f)
+ (else (eq? p1 p2))))
+(car ''abracadabra)
blob - /dev/null
blob + 865b39749e13f5865d99d98c878d1989b400525d (mode 644)
--- /dev/null
+++ ex2-54-sol.scm~
@@ -0,0 +1,8 @@
+(define (equal? p1 p2)
+ (cond ((and (null? p1) (null? p2)) #t)
+ ((or (null? p1) (null? p2)) #f)
+ ((and (pair? p1) (pair? p2))
+ (and (equal? (car p1) (car p2))
+ (equal? (cdr p1) (cdr p2))))
+ ((or (pair? p1) (pair? p2)) #f)
+ (else (eq? p1 p2))))
blob - /dev/null
blob + 837d67ccb61eba4eb66563b4b0b3d117c11e2fd5 (mode 644)
--- /dev/null
+++ ex2-54.lisp
@@ -0,0 +1,16 @@
+(defun memq (item x)
+ (cond ((null x) nil)
+ ((eql item (car x)) x)
+ (t (memq item (cdr x)))))
+
+(defun equal? (la lb)
+ (cond
+ ((and (symbolp la) (symbolp lb))
+ (eql la lb))
+ ((symbolp la) (symbolp lb))
+ ((symbolp lb) (symbolp la))
+ ((null la) (null lb))
+ ((null lb) (null la))
+ (t (and
+ (equal? (car la) (car lb))
+ (equal? (cdr la) (cdr lb))))))
blob - /dev/null
blob + 03da06aa24322e5cf49e397df7d4e8263f0d68c6 (mode 644)
--- /dev/null
+++ ex2-54.lisp~
@@ -0,0 +1,6 @@
+(defun memq (item x)
+ (cond ((null x) nil)
+ ((eql item (car x)) x)
+ (t (memq item (cdr x)))))
+
+(defun equal?
blob - /dev/null
blob + 1b36124a2ec8089f8933c754c9e9cdc9451d0967 (mode 644)
--- /dev/null
+++ ex2-54.scm
@@ -0,0 +1,38 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+
+(define (equal? a b)
+ (cond ((and (null? a)
+ (null? b))
+ #t)
+ ((and (not (pair? a))
+ (not (pair? b))
+ (eq? a b))
+ #t)
+ ((and (pair? a)
+ (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b))))
+ (else #f)))
+
+(test-case (equal? 4 4) #t)
+(test-case (equal? 4 0) #f)
+(test-case (equal? 4 '()) #f)
+(test-case (equal? '() 4) #f)
+(test-case (equal? '() '()) #t)
+(test-case (equal? '(4) '()) #f)
+(test-case (equal? '((4) (3)) '((4 3))) #f)
+(test-case (equal? '((4) (3)) '((4) (3))) #t)
+(test-case (equal? '((4) (3)) '((4) (2))) #f)
+(test-case (equal? '(4 3 2) '(4 3 2 5)) #f)
blob - /dev/null
blob + abdf15a6d391c4c1aa8909660d3176559a20581f (mode 644)
--- /dev/null
+++ ex2-54.scm~
@@ -0,0 +1,30 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+(test-case (list 'a 'b 'c) '(a b c))
+(test-case (list (list 'george)) '((george)))
+(test-case (cdr '((x1 x2) (y1 y2))) '((y1 y2)))
+(test-case (cadr '((x1 x2) (y1 y2))) '(y1 y2))
+(test-case (pair? (car '(a short list))) #f)
+(test-case (memq 'red '((red shoes) (blue socks))) #f)
+(test-case (memq 'red '(red shoes blue socks)) '(red shoes blue socks))
+
+ Exercise 2.54. Two lists are said to be equal? if they contain equal elements arranged in the same order. For example,
+
+(equal? '(this is a list) '(this is a list))
+
+is true, but
+
+(equal? '(this is a list) '(this (is a) list))
+
+is false. To be more precise, we can define equal? recursively in terms of the basic eq? equality of symbols by saying that a and b are equal? if they are both symbols and the symbols are eq?, or if they are both lists such that (car a) is equal? to (car b) and (cdr a) is equal? to (cdr b). Using this idea, implement equal? as a procedure.36
blob - /dev/null
blob + af9e196b3b38f67b265198a6f8e1974bf5ca243b (mode 644)
--- /dev/null
+++ ex2-55.scm
@@ -0,0 +1,48 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+
+(define (equal? a b)
+ (cond ((and (null? a)
+ (null? b))
+ #t)
+ ((and (not (pair? a))
+ (not (pair? b))
+ (eq? a b))
+ #t)
+ ((and (pair? a)
+ (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b))))
+ (else #f)))
+
+(test-case (equal? 4 4) #t)
+(test-case (equal? 4 0) #f)
+(test-case (equal? 4 '()) #f)
+(test-case (equal? '() 4) #f)
+(test-case (equal? '() '()) #t)
+(test-case (equal? '(4) '()) #f)
+(test-case (equal? '((4) (3)) '((4 3))) #f)
+(test-case (equal? '((4) (3)) '((4) (3))) #t)
+(test-case (equal? '((4) (3)) '((4) (2))) #f)
+(test-case (equal? '(4 3 2) '(4 3 2 5)) #f)
+
+;; Exercise 2.55. Eva Lu Ator types to the interpreter the expression
+
+(car ''abracadabra)
+
+;; To her surprise, the interpreter prints back quote. Explain.
+
+(car '(quote abracadabra))
+(car (list quote abracadabra))
+;; ''abracadabra is actually (quote (quote abracadabra)), which is the same as '(quote abracadabra). The interpreter sees the symbol quote as the first element in a two-element list.
blob - /dev/null
blob + 1b36124a2ec8089f8933c754c9e9cdc9451d0967 (mode 644)
--- /dev/null
+++ ex2-55.scm~
@@ -0,0 +1,38 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+
+(define (equal? a b)
+ (cond ((and (null? a)
+ (null? b))
+ #t)
+ ((and (not (pair? a))
+ (not (pair? b))
+ (eq? a b))
+ #t)
+ ((and (pair? a)
+ (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b))))
+ (else #f)))
+
+(test-case (equal? 4 4) #t)
+(test-case (equal? 4 0) #f)
+(test-case (equal? 4 '()) #f)
+(test-case (equal? '() 4) #f)
+(test-case (equal? '() '()) #t)
+(test-case (equal? '(4) '()) #f)
+(test-case (equal? '((4) (3)) '((4 3))) #f)
+(test-case (equal? '((4) (3)) '((4) (3))) #t)
+(test-case (equal? '((4) (3)) '((4) (2))) #f)
+(test-case (equal? '(4 3 2) '(4 3 2 5)) #f)
blob - /dev/null
blob + 9e659186182c0ed1d5c445bd4bbc66d439288dcb (mode 644)
--- /dev/null
+++ ex2-56-sol.scm
@@ -0,0 +1,32 @@
+(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))))
+ (else
+ (error "unknown expression type -- DERIV" exp))))
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+(define (exponentiation? x)
+ (and (pair? x) (eq? (car x) '**)))
+(define (base e) (cadr e))
+(define (exponent e) (caddr e))
blob - /dev/null
blob + acf16f3817925ece7dd95639b9192418882a3066 (mode 644)
--- /dev/null
+++ ex2-56-sol.scm~
@@ -0,0 +1,15 @@
+(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))))
+ (else
+ (error "unknown expression type -- DERIV" exp))))
blob - /dev/null
blob + 950240996369b7cb31664ad4b57d5b7b40875662 (mode 644)
--- /dev/null
+++ ex2-56.lisp
@@ -0,0 +1,36 @@
+(defun make-exponentiation (base exp)
+ (cond ((=number? exp 0) 1)
+ ((=number? exp 1) base)
+ ((and (numberp base) (numberp exp))
+ (expt base exp))
+ (t (list '** base exp))))
+
+(defun exponentiation? (x)
+ (and (consp x) (eql (car x) '**)))
+(defun base (x)
+ (cadr s))
+(defun exponent (s)
+ (caddr s))
+(defun deriv (expr var)
+ (cond ((numberp expr) 0)
+ ((variable? expr)
+ (if (same-variable? expr var) 1 0))
+ ((exponentiation? expr)
+ (make-product
+ (make-product
+ (exponent expr)
+ (make-exponentiation
+ (base expr)
+ (1- (exponent expr))))
+ (deriv (base expr) var)))
+ ((sum? expr)
+ (make-sum (deriv (addend expr) var)
+ (deriv (augend expr) var)))
+ ((product? expr)
+ (make-sum
+ (make-product (multiplier expr)
+ (deriv (multiplicand expr) var))
+ (make-product (deriv (multiplier expr) var)
+ (multiplicand expr))))
+ (t (error "unknown expression type -- DERIV ~A" expr))))
+
blob - /dev/null
blob + dc48c676007dde7e3577624029e29ca14a7e0e8c (mode 644)
--- /dev/null
+++ ex2-56.lisp~
@@ -0,0 +1,6 @@
+(defun make-exponentiation (base exp)
+ (cond ((=number? exp 0) 1)
+ ((=number? exp 1) base)
+ ((and (numberp base) (numberp exp))
+ (expt base exp))
+ (t (list '** base exp))))
blob - /dev/null
blob + f688ddbf1820fc59b0d4c79def479961da528160 (mode 644)
--- /dev/null
+++ ex2-56.scm
@@ -0,0 +1,103 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(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))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
blob - /dev/null
blob + f688ddbf1820fc59b0d4c79def479961da528160 (mode 644)
--- /dev/null
+++ ex2-56.scm~
@@ -0,0 +1,103 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(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))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
blob - /dev/null
blob + 5a23284b0846c6597d0701308ee0638e39a1a940 (mode 644)
--- /dev/null
+++ ex2-57-sol.scm
@@ -0,0 +1,45 @@
+(define (non-num-members as)
+ (filter (lambda (x) (not (number? x)))
+ as))
+(define (num-members as)
+ (filter number? as))
+(define (more-than-one-number? as)
+ (let ((nums (num-members as)))
+ (if (or (null? nums) (null? (cdr nums)))
+ false
+ true)))
+(define (zero-is-the-only-number? as)
+ (let ((nums (num-members as)))
+ (if (null? nums)
+ false
+ (and (= (car nums) 0) (null? (cdr nums))))))
+
+(define (make-sum . as)
+ (cond ((null? as) 0)
+ ((null? (cdr as)) (car as))
+ ((null? (non-num-members as)) (apply + as))
+ ((more-than-one-number? as)
+ (apply make-sum
+ (append (non-num-members as)
+ (list (apply + (num-members as))))))
+ ((zero-is-the-only-number? as)
+ (apply make-sum (non-num-members as)))
+ (else (append '(+) as))))
+(define (make-product . ms)
+ (cond ((null? ms) 1)
+ ((null? (cdr ms)) (car ms))
+ ((null? (non-num-members ms)) (apply * ms))
+ ((more-than-one-number? ms)
+ (apply make-product
+ (append (non-num-members ms)
+ (list (apply * (num-members ms))))))
+ ((zero-is-the-only-number? ms) 0)
+ ((one-is-the-only-number? ms)
+ (apply make-product (non-num-members ms)))
+ (else (append '(*) ms))))
+
+
+(define (augend s)
+ (apply make-sum (cddr s)))
+(define (multiplicand p)
+ (apply make-product (cddr p)))
blob - /dev/null
blob + 56b01a75e73106c2c746481a416257f1206d3620 (mode 644)
--- /dev/null
+++ ex2-57-sol.scm~
@@ -0,0 +1,4 @@
+(define (augend s)
+ (if (null? (cdddr s))
+ (caddr s)
+ (cons '+ (cddr s))))
blob - /dev/null
blob + 0a0422b99b5fdf5eab4c7f735848d79c3f916c53 (mode 644)
--- /dev/null
+++ ex2-57.lisp
@@ -0,0 +1,31 @@
+(defun make-sum (&rest nums)
+ (append (list '+) nums))
+
+(make-sum '())
+'(+)
+(make-sum '(3))
+'(+ 3)
+(make-sum '(3 4))
+'(+ 3 4)
+(make-sum '(3 4 5))
+'(+ 3 4 5)
+(defun sum? (x)
+ (and (consp x) (eql (car x) '+)))
+(defun addend (s)
+ (cadr s))
+(defun augend (s)
+ (let ((aug (cddr s)))
+ (if (= (length aug) 1)
+ (car aug)
+ (append (list '+) aug))))
+(defun make-product (&rest nums)
+ (append (list '*) nums))
+(defun product? (x)
+ (and (consp x) (eql (car x) '*)))
+(defun multiplier (s)
+ (cadr s))
+(defun multiplicand (s)
+ (let ((m (cddr s)))
+ (if (= (length m) 1)
+ (car m)
+ (append (list '*) m))))
blob - /dev/null
blob + 161101bcd96899f1699b0d93d7bef6dc044f9534 (mode 644)
--- /dev/null
+++ ex2-57.lisp~
@@ -0,0 +1,2 @@
+(defun make-sum (&rest nums)
+ (append (list '+) nums))
blob - /dev/null
blob + 9570f7c39876dfdf9d8fc6b90ed2700addb15ade (mode 644)
--- /dev/null
+++ ex2-57.scm
@@ -0,0 +1,196 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(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))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
+;; Exercise 2.57. Extend the differentiation program to handle sums and products of arbitrary numbers of (two or more) terms. Then the last example above could be expressed as
+
+;; (deriv '(* x y (+ x 3)) 'x)
+
+;; Try to do this by changing only the representation for sums and products, without changing the deriv procedure at all. For example, the addend of a sum would be the first term, and the augend would be the sum of the rest of the terms.
+
+;; (define (collect-terms term structure)
+;; ...)
+;; (make-sum 1 2 3 4 5)
+;; (+ 1 (+ 2 (+ 3 (+ 4 5))))
+
+;; (+ (+ (+ (+ 4 5)
+;; 3)
+;; 2)
+;; 1)
+
+;; (+ 1 x 4 y -2)
+;; (+ 3 x y)
+;; (+
+
+;; (test-case (combine-terms 1 '()) 0)
+;; (test-case (combine-terms '(+ 1 2 3)
+;; (test-case (+ 1 x 4 y -2) '(+ 3 x y))
+;; (test-case (+ 1 (* x y) (* 2 x y) -3) '(+ -2 (* 3 x y)))
+
+;; (test-case (combine-constants '(+ 1 2 3)) 6)
+;; (define (combine-constants exp)
+;; (define (combine accum terms)
+;; (cond ((null? terms) accum)
+;; ((number? terms) (+ accum terms))
+;; ((product? terms) terms)
+;; ((exponentiation? terms) terms)
+;; ((sum? terms)
+;; (if (number? (addend terms))
+;; (combine (+ accum (addend terms)) (augend terms))
+;; (make-sum ()
+
+;; (augend terms)
+;; (combine (+ accum (addend terms)) (augend terms)))))
+;; (combine 0 exp))
+
+;; combines terms within items that share term in common
+(define (combine-terms term items)
+ (cond ((null? items) 0)
+ ((
+ ((number? term)
+ ...)
+ (else ...)))
+
+;; we no longer combine constants, nor do we combine like terms
+;; all sums must have at least 2 terms
+(define (make-sum . items)
+ (cond ((null? items) 0)
+ ((null? (cdr items)) (car items))
+ (else (append (list '+) items))))
+
+;; (define (make-sum . exps)
+;; (define (make-sum-recur items)
+;; (cond ((null? items) 0)
+;; (else (list '+ (car items) (make-sum (cdr items))))))
+;; (make-sum-recur items))
+
+ ;; (if (null? augends)
+ ;; addend
+ ;; (cons addend (make-sum (car augends) (cdr augends)))))
+ ;; (list '+ addend augends))
+(define (make-product . items)
+ (append (list '*) items))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; assuming that all sums must contain at least 1 term
+'(+ 1 2)
+'(1 2)
+'(2)
+(define (augend s)
+ (cond ((null? (cddr s)) 0)
+ ((null? (cdddr s))
+ (caddr s))
+(define (multiplicand p) ...)
blob - /dev/null
blob + f688ddbf1820fc59b0d4c79def479961da528160 (mode 644)
--- /dev/null
+++ ex2-57.scm~
@@ -0,0 +1,103 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(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))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
blob - /dev/null
blob + fd36fc4420c5206e6678d8e3ab7921b3ca088977 (mode 644)
--- /dev/null
+++ ex2-57b.scm
@@ -0,0 +1,238 @@
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+(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))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;; (test-case (make-exponentiation 0 0) "0^0 undefined")
+;; (test-case (make-exponentiation 0 1) 0)
+;; (test-case (make-exponentiation 1 0) 1)
+;; (test-case (make-exponentiation 5 5) 3125)
+;; (test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+;; (test-case (make-exponentiation 'x 1) 'x)
+;; (test-case (make-exponentiation 1 'x) 1)
+;; (test-case (make-exponentiation 'x 5) '(** x 5))
+;; (test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+;; (test-case (make-exponentiation 5 'x) '(** 5 x))
+;; (test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
+;; Exercise 2.57. Extend the differentiation program to handle sums and products of arbitrary numbers of (two or more) terms. Then the last example above could be expressed as
+
+;; (deriv '(* x y (+ x 3)) 'x)
+
+;; Try to do this by changing only the representation for sums and products, without changing the deriv procedure at all. For example, the addend of a sum would be the first term, and the augend would be the sum of the rest of the terms.
+
+(define (make-sum . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (num (fold-right + 0 nums)))
+ (cond ((= num 0) (cond ((null? non-nums) 0)
+ ((null? (cdr non-nums)) (car non-nums))
+ (else (append (list '+) non-nums))))
+ ((null? non-nums) num)
+ (else (append (list '+)
+ non-nums
+ (list num))))))
+(define (make-sum . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (num (fold-right + 0 nums)))
+ (cond ((= num 0) (cond ((null? non-nums) 0)
+ ((null? (cdr non-nums)) (car non-nums))
+ (else (append (list '+) non-nums))))
+ ((null? non-nums) num)
+ (else (append (list '+)
+ non-nums
+ (list num))))))
+(define (make-product . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (num (fold-right * 1 nums)))
+ (cond ((null? exps) 1)
+ ((= num 0) 0)
+ ((null? non-nums) num)
+ ((null? (cdr non-nums)) (if (= num 1)
+ (car non-nums)
+ (append (list '* num) non-nums)))
+ (else (if (= num 1)
+ (cons '* non-nums)
+ (append (list '* num) non-nums))))))
+
+ ;; ((= nums 1) (cond ((null? non-nums) 1)
+ ;; ((null? (cdr non-nums)) (car non-nums))
+ ;; (else (append (list '*) non-nums))))
+ ;; (else
+
+(test-case (make-sum) 0)
+(test-case (make-sum 0) 0)
+(test-case (make-sum 0 'x) 'x)
+(test-case (make-sum 1 2 3 4 5) 15)
+(test-case (make-sum 1 'x) '(+ x 1))
+(test-case (make-sum 1 5 'x) '(+ x 6))
+(test-case (make-sum 1 5 'x 'y) '(+ x y 6))
+(test-case (make-sum -3 3 'x 'y) '(+ x y))
+(test-case (make-sum -3 3 'x) 'x)
+(test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5) '(+ a b c d -2))
+(test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3) '(+ a b c d))
+(test-case (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ 2 5 -4)
+ '(+ (* 5 x) (* 3 y) 3))
+(test-case (make-sum (make-product 5 'x)
+ (make-product 2 0 'y)
+ (make-product (make-sum 5 -5) 'x)
+ (make-product (make-sum 2 4 -6) 'y)
+ (make-product (make-product 0 1) 'z)
+ (make-product 4 'z)
+ -3 -2 -1
+ (make-product 2 3))
+ '(+ (* 5 x) (* 4 z)))
+
+(test-case (make-product) 1)
+(test-case (make-product 1) 1)
+(test-case (make-product 5) 5)
+(test-case (make-product 'x) 'x)
+(test-case (make-product 5 'x) '(* 5 x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0) 0)
+(test-case (make-product 0 1 3 2) 0)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(* 10 x))
+(test-case (make-product 5 'x 'y 'z 0) 0)
+(test-case (make-product 5 'x 'y 'z) '(* 5 x y z))
+(test-case (make-product 5 'x 2 -3 'y) '(* -30 x y))
+(test-case (make-product 5 1/5 'x) 'x)
+(test-case (make-product 5 1/5 'x 'y) '(* x y))
+(test-case (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3))
+ '(* 13 x y))
+(test-case (make-product (make-sum (make-sum 2 4)
+ (make-product 3 -2))
+ (make-product 4 'y))
+ 0)
+
+
+(define (addend s) (cadr s))
+(define (augend s) (apply make-sum (cddr s)))
+;; alternatively,
+;; (if (null? (cdddr s))