commit 665c255dd18a42b23f14a5dad17cc3139d573d4a from: jrmu date: Fri Aug 04 04:57:27 2023 UTC Import sources commit - /dev/null commit + 665c255dd18a42b23f14a5dad17cc3139d573d4a 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 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)) +;; (caddr s) +;; (apply make-sum (cddr s)))) + +(define (multiplier p) (cadr p)) +(define (multiplicand p) (apply make-product (cddr p))) + +(test-case (augend (make-sum 1 'x)) 1) +(test-case (augend (make-sum 1 5 'x)) 6) +(test-case (augend (make-sum 1 5 'x 'y)) '(+ y 6)) +(test-case (augend (make-sum -3 3 'x 'y)) 'y) +(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) '(+ b c d -2)) +(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3)) '(+ b c d)) +(test-case (augend (make-sum (make-product 5 'x) + (make-product 3 'y) + 2 5 -4)) + '(+ (* 3 y) 3)) +(test-case (augend (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))) + '(* 4 z)) + +(test-case (multiplicand (make-product 5 'x)) 'x) +(test-case (multiplicand (make-product 5 'x 'y 'z)) '(* x y z)) +(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(* x y)) +(test-case (multiplicand (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + '(* x y)) +(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3)))) +;; (make-sum (make-product 'x (deriv '(* y (+ x 3)) 'x)) +;; '(* y (+ x 3)))) +;; (make-sum (make-product 'x 'y) +;; '(* y (+ x 3))) +;; (make-sum '(* x y) +;; '(* y (+ x 3))) +;; '(+ (* x y) (* y (+ x 3))) + blob - /dev/null blob + 9570f7c39876dfdf9d8fc6b90ed2700addb15ade (mode 644) --- /dev/null +++ ex2-57b.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 + b1cec46bd8957322c96705aeacfcdc6f86f4fcb5 (mode 644) --- /dev/null +++ ex2-58-sol.scm @@ -0,0 +1,27 @@ +(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))) + #f + #t))) +(define (zero-is-the-only-number? as) + (let ((nums (num-members as))) + (if (null? nums) + #f + (and (= (car nums) 0) (null? (cdr nums)))))) +(define (one-is-the-only-number? as) + (let ((nums (num-members as))) + (if (null? nums) + #f + (and (= (car nums) 1) (null? (cdr nums)))))) +(define (insert-signs result items sign) + (cond ((null? items) result) + ((null? result) + (insert-signs (list (car items)) (cdr items) sign)) + (else (insert-signs (append result (list sign (car items))) + (cdr items) sign)))) + + blob - /dev/null blob + f1c862d5f0b079baffb695cd462cad0a746e929c (mode 644) --- /dev/null +++ ex2-58-sol.scm~ @@ -0,0 +1,100 @@ +(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 (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 (sum? x) + (and (pair? x) (eq? (cadr x) '+))) +(define (addend s) (car s)) +(define (augend s) (caddr s)) +(define (product? x) + (and (pair? x) (eq? (cadr x) '*))) +(define (multiplier p) (car p)) +(define (multiplicand p) (caddr p)) +(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))) + #f + #t))) +(define (zero-is-the-only-number? as) + (let ((nums (num-members as))) + (if (null? nums) + #f + (and (= (car nums) 0) (null? (cdr nums)))))) +(define (one-is-the-only-number? as) + (let ((nums (num-members as))) + (if (null? nums) + #f + (and (= (car nums) 1) (null? (cdr nums)))))) +(define (insert-signs result items sign) + (cond ((null? items) result) + ((null? result) + (insert-signs (list (car items)) (cdr items) sign)) + (else (insert-signs (append result (list sign (car items))) + (cdr items) sign)))) + +(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 (insert-signs '() 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 (insert-signs '() ms '*)))) +(define (sum? x) + (cond ((not (pair? x)) #f) + ((member '+ x) true) + (else #f))) +(define (product? x) + (cond ((not (pair? x)) #f) + ((and (not (sum? x)) (member '* x)) true) + (else #f))) +(define (addend s) + (let* ((index (list-index (lambda (x) (eq? x '+)) s)) + (a (take s index))) + (if (null? (cdr a)) + (car a) + a))) +(define (augend s) + (let* ((index (list-index (lambda (x) (eq? x '+)) s)) + (b (drop s (+ index 1)))) + (if (null? (cdr b)) + (car b) + b))) +(define (multiplier p) + (let* ((index (list-index (lambda (x) (eq? x '*)) p)) + (a (take p index))) + (if (null? (cdr a)) + (car a) + a))) +(define (multiplicand p) + (let* ((index (list-index (lambda (x) (eq? x '*)) p)) + (b (drop p (+ index 1)))) + (if (null? (cdr b)) + (car b) + b))) +(multiplier '(x * y * (z + 2))) blob - /dev/null blob + 8ec5b5cf030cc84bf5dbd465a00fffa97008f516 (mode 644) --- /dev/null +++ ex2-58.lisp @@ -0,0 +1,55 @@ +(defun make-sum (a1 a2) + (list a1 '+ a2)) +(defun make-product (m1 m2) + (list m1 '* m2)) +(defun sum? (x) + (and (consp x) (eql (cadr x) '+))) +(defun addend (x) + (car x)) +(defun augend (s) + (caddr s)) +(defun product? (x) + (and (consp x) (eql (cadr x) '*))) +(defun multiplier (s) + (car s)) +(defun multiplicand (s) + (caddr s)) + +(defvar *stream* '() "Token stream") +(defun init-stream (stream) + "Initialize the stream" + (setq *stream* stream)) +(defun next-token () + "Returns the next token of the stream" + (car *stream*)) +(defun scan () + (pop *stream*)) +(defvar *stream-stack* '() "Stack of streams") +(defun push-stream (stream) + "Push the current *stream* on stack, and set this tream as *stream*" + (push *stream* *stream-stack*) + (init-stream stream)) +(defun pop-stream () + (init-stream (pop *stream-stack))) +(defun parse-factor () + (let ((tok (next-token))) + (cond + ((or (numberp tok) (sybolp tok)) + (scan) + tok) + ((listp tok) + (push-strea tok) + (let ((sum (parse-sum))) + (pop-stream) + (scan) + sum)) + (t (error "Bad token in parse-atom -- ~A" tok))))) +(defun parse-term () + (let ((lfact (parse-factor))) + (if (eq (next-token) '*) + (progn + (scan) + (let ((rterm (parse-term))) + (list '* lfact rterm))) + lfact))) +(defun (parse- blob - /dev/null blob + 8187faeb6e9aa6cceb2a8f0ebd984ce19aff79fc (mode 644) --- /dev/null +++ ex2-58.lisp~ @@ -0,0 +1,16 @@ +(defun make-sum (a1 a2) + (list a1 '+ a2)) +(defun make-product (m1 m2) + (list m1 '* m2)) +(defun sum? (x) + (and (consp x) (eql (cadr x) '+))) +(defun addend (x) + (car x)) +(defun augend (s) + (caddr s)) +(defun product? (x) + (and (consp x) (eql (cadr x) '*))) +(defun multiplier (s) + (car s)) +(defun multiplicand (s) + (caddr s)) blob - /dev/null blob + 551fcf0f677d1750eb29c0f559807c0f721e210e (mode 644) --- /dev/null +++ ex2-58.scm @@ -0,0 +1,172 @@ +(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 (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)))) + (error "unknown expression type -- DERIV" exp))) + +;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? + +(define (add-signs exps sign) + (cond ((null? exps) '()) + ((null? (cdr exps)) exps) + (else (cons (car exps) + (cons sign + (add-signs (cdr exps) sign)))))) +(define (add-plus-signs exps) + (cond ((null? exps) '()) + ((null? (cdr exps)) exps) + ((sum? (car exps)) (append (list (addend (car exps)) + (augend (car exps))) + (add-plus-signs (cdr exps)))) + (else (append (list (car exps) '+) + (add-plus-signs (cdr exps)))))) +(define (add-mult-signs exps) + (cond ((null? exps) '()) + ((null? (cdr exps)) exps) + (else (cons (car exps) + (cons '* + (add-mult-signs (cdr exps))))))) + +(define (make-sum . exps) + (let* ((nums (filter number? exps)) + (non-nums (filter (lambda (exp) (not (number? exp))) exps)) + (sum-of-nums (fold-right + 0 nums))) + (cond ((null? non-nums) sum-of-nums) + ((and (= sum-of-nums 0) + (null? (cdr non-nums))) (car non-nums)) + ((= sum-of-nums 0) (add-plus-signs non-nums)) + (else (add-plus-signs (append non-nums (list sum-of-nums))))))) +(define (make-product . exps) + (let* ((nums (filter number? exps)) + (non-nums (filter (lambda (exp) (not (number? exp))) exps)) + (product-of-nums (fold-right * 1 nums))) + (cond ((null? non-nums) product-of-nums) + ((= product-of-nums 0) 0) + ((and (= product-of-nums 1) + (null? (cdr non-nums))) (car non-nums)) + ((= product-of-nums 1) (add-mult-signs non-nums)) + (else (add-mult-signs (cons product-of-nums non-nums)))))) +(define (addend s) + (if (eq? '+ (cadr s)) + (list (car x)) + (cons (car x) + (cons (cadr x) + (addend (cddr x)))))) + +(define (augend s) + (cond ((and (eq? '+ (cadr s)) + (null? (cdddr s))) + (caddr s)) + ((eq? '+ (cadr s)) (cddr s)) + ((eq? '* (cadr s)) (augend (cddr s))))) + +(define (sum? x) + (and (pair? x) + (not (null? (cdr x))) + (or (eq? (cadr x) '+) + (sum? (cddr x))))) + +(define (multiplier p) (car p)) +(define (multiplicand p) (caddr p)) + +(define (product? x) + (and (pair? x) (eq? (cadr x) '*))) + + +;; addend +(test-case (addend '(a + b + c)) 'a) +(test-case (addend '(3 * x + 4 * y)) '(3 * x)) +(test-case (addend '(4 + x * y * (1 + z) + (2 * 2))) '(y * x * (z + 1))) +(test-case (addend '(2 * x * y + 4)) '(2 * x * y)) + +;; augend +(test-case (augend '(x + 6)) 6) +(test-case (augend '(x + y + 6)) '(y + 6)) +(test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5)) +(test-case (augend '(5 * x + 3 * y + 3)) + '(3 * y + 3)) + +;; sum? +(test-case (sum? '(5 + x)) #t) +(test-case (sum? '(5 * x + 3)) #t) +(test-case (sum? '(8 * x)) #f) +(test-case (sum? 5) #f) +(test-case (sum? '(5 * x + 8 * y)) #t) +(test-case (sum? '(((5 * x) + 3) + 2)) #t) +(test-case (make-sum 0 'x) 'x) +(test-case (make-sum 1 2) 3) +(test-case (make-sum 1 'x) '(x + 1)) +(test-case (make-sum 'x 'y) '(x + y)) +(test-case (make-sum (make-sum -3 'y) + (make-sum 3 'x)) '(y + -3 + x + 3)) ;; not the most simplified +(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +(test-case (make-sum -3 'y 3 'x) '(y + x)) +(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4)) +(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y)) +(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y)) +(test-case (make-sum (make-product 'a 'b) + (make-product 'c (make-sum 'd 1) 'e) + (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) + '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +(test-case (make-product 5 'x) '(5 * x)) +(test-case (make-product 5 2) 10) +(test-case (make-product 0 'x) 0) +(test-case (make-product 5 2 'x) '(10 * x)) +(test-case (make-product 5 1/5 'x 'y) '(x * y)) +(test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z)) +(test-case (make-product (make-sum 5 'x) + (make-product 'x 'y) + (make-sum 'z 2)) + '((5 + x) * x * y * (z + 2))) +;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses +(test-case (make-sum (make-sum -5 6 'x) + 'y + (make-sum -3 3)) + '(x + 1 + y)) ;; notice that the constant 1 is not right-most +(test-case (make-product (make-sum 2 4 (make-product 3 -2)) + (make-product 4 'y)) 0) +(test-case (make-sum (make-product 5 'x) + (make-product 3 'y) + (make-product 2 'y) + (make-product 2 3)) + '(5 * x + 3 * y + 2 * y + 6)) +(test-case (make-sum (make-product 5 'x 'y) + (make-product 4 'a 'b 'c)) + '(5 * x * y + 4 * a * b * c)) + + +(test-case (multiplier '(20 * x * ( (make-product (make-product 5 4 'x (make-sum 1 'y)) + (make-sum 2 'z))) + '(20 * x * (y + 1))) +(test-case (multiplier (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + 13) +(test-case (multiplicand (make-product 5 'x)) 'x) +(test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z)) +(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y)) +(test-case (multiplicand (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + '(x * y)) + +(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3)))) blob - /dev/null blob + e72a051467120ae90b574e74ddf87a8d2ea4c2fe (mode 644) --- /dev/null +++ ex2-58.scm~ @@ -0,0 +1,148 @@ +(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 (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)))) + (error "unknown expression type -- DERIV" exp))) + +;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? + +(define (add-signs exps sign) + (cond ((null? exps) '()) + ((null? (cdr exps)) exps) + (else (cons (car exps) + (cons sign + (add-signs (cdr exps) sign)))))) +(define (make-sum . exps) + (let* ((nums (filter number? exps)) + (non-nums (filter (lambda (exp) (not (number? exp))) exps)) + (sum-of-nums (fold-right + 0 nums))) + (cond ((null? non-nums) sum-of-nums) + ((and (= sum-of-nums 0) + (null? (cdr non-nums))) (car non-nums)) + ((= sum-of-nums 0) (add-signs non-nums '+)) + (else (add-signs (append non-nums (list sum-of-nums)) '+))))) +(define (make-product . exps) + (let* ((nums (filter number? exps)) + (non-nums (filter (lambda (exp) (not (number? exp))) exps)) + (product-of-nums (fold-right * 1 nums))) + (cond ((null? non-nums) product-of-nums) + ((= product-of-nums 0) 0) + ((and (= product-of-nums 1) + (null? (cdr non-nums))) (car non-nums)) + ((= product-of-nums 1) (add-signs non-nums '*)) + (else (add-signs (cons product-of-nums non-nums) '*))))) +(define (addend s) + (if (eq? '+ (cadr s)) + (car s) + (cons (car s) + (addend (cddr s))))) +(define (augend s) + (cond ((and (eq? '+ (cadr s)) + (null? (cdddr s))) + (caddr s)) + ((eq? '+ (cadr s)) (cddr s)) + ((eq? '* (cadr s)) (augend (cddr s))))) +(define (multiplier p) (car p)) +(define (multiplicand p) (caddr p)) + +(define (sum? x) + (and (pair? x) (eq? (cadr x) '+))) +(define (product? x) + (and (pair? x) (eq? (cadr x) '*))) + + +(test-case (make-sum 0 'x) 'x) +(test-case (make-sum 1 2) 3) +(test-case (make-sum 1 'x) '(x + 1)) +(test-case (make-sum 'x 'y) '(x + y)) +(test-case (make-sum (make-sum -3 'y) + (make-sum 3 'x)) '(y + -3 + x + 3)) ;; not the most simplified +(test-case (make-sum -3 'y 3 'x) '(y + x)) +(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4)) +(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y)) +(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y)) +(test-case (make-sum (make-product 'a 'b) + (make-product 'c (make-sum 'd 1) 'e) + (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) + '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +(test-case (make-product 5 'x) '(5 * x)) +(test-case (make-product 5 2) 10) +(test-case (make-product 0 'x) 0) +(test-case (make-product 5 2 'x) '(10 * x)) +(test-case (make-product 5 1/5 'x) 'x) +(test-case (make-product 5 1/5 'x 'y) '(x * y)) +(test-case (make-sum (make-sum -5 6 'x) 'y (make-sum -3 3)) + '(x + 1 + y)) ;; notice that the constant 1 is not right-most +(test-case (make-product (make-sum 2 4 (make-product 3 -2)) (make-product 4 'y)) 0) +(test-case (make-sum (make-product 5 'x) + (make-product 3 'y) + (make-product 2 'y) + (make-product 2 3)) + '(5 * x + 3 * y + 2 * y + 6)) +(test-case (make-sum (make-product 5 'x) + (make-product 0 'y) + (make-product (make-sum 5 -5) 'x) + (make-product 4 'z) + (make-sum -3 -3) + (make-product 2 3)) + '(5 * x + 4 * z)) + +(test-case (addend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) 'a) +(test-case (addend (make-sum (make-product '3 'x) (make-product 4 'y))) '(3 * x)) +(test-case (addend (make-sum 4 (make-product 1 'y 'x (make-sum 1 'z)) (make-product 2 2))) '(y * x * (z + 1))) +(test-case (addend '(2 * x * y + 4)) '(2 * x * y)) +(test-case (augend (make-sum 1 'x)) 1) +(test-case (augend (make-sum 1 5 'x)) 6) +(test-case (augend (make-sum 1 5 'x 'y)) '(y + 6)) +(test-case (augend (make-sum -3 3 'x 'y)) 'y) +(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) '(b + c + d + -2)) +(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3)) '(b + c + d)) +(test-case (augend (make-sum (make-product 5 'x) + (make-product 3 'y) + 2 5 -4)) + '(3 * y + 3)) +(test-case (augend (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))) + '(4 * z)) + +(test-case (multiplier (make-product (make-product 5 4 'x (make-sum 1 'y)) + (make-sum 2 'z))) + '(20 * x * (y + 1))) +(test-case (multiplier (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + 13) +(test-case (multiplicand (make-product 5 'x)) 'x) +(test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z)) +(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y)) +(test-case (multiplicand (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + '(x * y)) + +(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3)))) blob - /dev/null blob + 7ecac9b8e9145b03f382baf87565ca8a9aa2a84d (mode 644) --- /dev/null +++ ex2-58b.scm @@ -0,0 +1,315 @@ +(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 (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)))) + (error "unknown expression type -- DERIV" exp))) + +;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? + +(define (sum? x) + (and (not (number? x)) + (not (variable? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '+) + (sum? (cddr x))))) +;; sum? +;; (newline) +;; (display "sum??") +;; (newline) +;; (test-case (sum? '(5 + x)) #t) +;; (test-case (sum? '(5 * x + 3)) #t) +;; (test-case (sum? '(8 * x)) #f) +;; (test-case (sum? 5) #f) +;; (test-case (sum? '(5 * x + 8 * y)) #t) +;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t) + +;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list +(define (product? x) + (and (not (number? x)) + (not (variable? x)) + (not (sum? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '*) + (product? (cddr x))))) +;; (newline) +;; (display "product?") +;; (newline) +;; (test-case (product? '(2 * x * y + 4)) #f) +;; (test-case (product? '(x * y * z)) #t) +;; (test-case (product? '((x + 1) * y)) #t) +;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f) +;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f) + +;; If the first operation is +, we return the first element in the list +;; Otherwise, we join the first two elements to the addend of the rest +;; of the list. +(define (addend s) + (if (eq? '+ (cadr s)) + (car s) +;; we do not test if (cadddr s) is a number or variable because it might +;; be a single nested list + (if (eq? (cadddr s) '+) + (list (car s) (cadr s) (addend (cddr s))) + (cons (car s) + (cons (cadr s) + (addend (cddr s))))))) +;; (newline) +;; (display "addend") +;; (newline) +;; (test-case (addend '(a + b + c)) 'a) +;; (test-case (addend '(3 * x + 4 * y)) '(3 * x)) +;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1))) +;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y)) +;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2))) +;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) * (y + 3))) + +;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements. +(define (augend s) + (if (eq? '+ (cadr s)) + (if (null? (cdddr s)) + (caddr s) + (cddr s)) + (augend (cddr s)))) +;; (newline) +;; (display "augend") +;; (newline) +;; (test-case (augend '(x + 6)) '6) +;; (test-case (augend '(x + y + 6)) '(y + 6)) +;; (test-case (augend '(x + y * x)) '(y * x)) +;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5)) +;; (test-case (augend '(5 * x + 3 * y + 3)) +;; '(3 * y + 3)) +;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) + +(define (multiplier p) + (car p)) +;; (newline) +;; (display "multiplier") +;; (newline) +;; (test-case (multiplier '(5 * x)) 5) +;; (test-case (multiplier '(x * (x + 2))) 'x) +;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1)) +;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2)) +;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5)) +;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4)) +;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z)) + +(define (multiplicand p) + (if (null? (cdddr p)) + (caddr p) + (cddr p))) +;; (newline) +;; (display "multiplicand") +;; (newline) +;; (test-case (multiplicand '(5 * x)) 'x) +;; (test-case (multiplicand '(x * (x + 2))) '(x + 2)) +;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3))) +;; (test-case (multiplicand '((5 * x + 2) * y)) 'y) +;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) +;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z)) +;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y)) + +;; given a list of items to sum, check to see if any of the items are sums. +;; If they are, return a new list with the addend and augends as separate expressions +(define (break-sums exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (sum? x) + (cons (addend x) + (break-sums (cons (augend x) (cdr exps)))) + (cons x (break-sums (cdr exps))))))) + +;; (newline) +;; (display "break-sums") +;; (newline) +;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3)) +;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3)) +;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7)) + +;; interpolate '+ signs between expressions +(define (add-plus-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) + (if (or (number? x) + (variable? x)) + (list x) + x)) ;; when x is a one-element list like '((x * y)) + ((or (number? x) + (variable? x)) + (cons x (cons '+ (add-plus-signs remnant)))) + ((sum? x) + (error "unexpected sum")) + ((product? x) + (cons (multiplier x) + (cons '* + (add-plus-signs (cons (multiplicand x) remnant))))) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-plus-signs") +;; (newline) +;; (test-case (add-plus-signs '()) '()) +;; (test-case (add-plus-signs '(1)) '(1)) +;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4)) +;; (test-case (add-plus-signs '((x * y))) '(x * y)) +;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5)) +;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1))) +;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4)))) +;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4))) + +;; If the term is: +;; a number or a variable: we deal with it is without adding or removing any parentheses +;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term. +;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends as separate terms +(define (make-sum . exps) + (let* ((terms (break-sums exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (sum-of-nums (fold-right + 0 nums))) + (cond ((null? non-nums) sum-of-nums) + ((and (= sum-of-nums 0) + (null? (cdr non-nums))) (car non-nums)) + ((= sum-of-nums 0) (add-plus-signs non-nums)) + (else (add-plus-signs (append non-nums (list sum-of-nums))))))) +;; (newline) +;; (display "make-sum") +;; (newline) +;; (test-case (make-sum 0 'x) 'x) +;; (test-case (make-sum 1 2) 3) +;; (test-case (make-sum 1 'x) '(x + 1)) +;; (test-case (make-sum 'x 'y) '(x + y)) +;; (test-case (make-sum (make-sum -3 'y) +;; (make-sum 3 'x)) '(y + x)) +;; (make-sum '(y + -3) '(x + 3)) +;; (make-sum 'y -3 'x 3) +;; (test-case (make-sum -3 'y 3 'x) '(y + x)) +;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +;; (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials +;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4)) +;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y)) +;; (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) + +;; given a list of items to multiply, check to see if any of the items are products. +;; If they are, return a new list with the multiplier and multiplicands as separate expressions +(define (break-products exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (product? x) + (cons (multiplier x) + (break-products (cons (multiplicand x) (cdr exps)))) + (cons x (break-products (cdr exps))))))) + +;; (newline) +;; (display "break-products") +;; (newline) +;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3)) +;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3)) +;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y)) + +;; interpolate '* signs between expressions +(define (add-mult-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) + (if (or (number? x) + (variable? x) + (sum? x)) + (list x) + x)) ;; when x is a one-element list like '((x ** y)) + ((or (number? x) + (variable? x) + (sum? x)) + (cons x (cons '* (add-mult-signs remnant)))) + ((product? x) + (error "unexpected product")) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-mult-signs") +;; (newline) +;; (test-case (add-mult-signs '()) '()) +;; (test-case (add-mult-signs '(1)) '(1)) +;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z)) +;; (test-case (add-mult-signs '((x * y))) '(x * y)) +;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y))) +;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x))) +;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4))) +;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4))) + +;; If the exp is a: +;; variable or number, we just multiply without adding any extra parentheses +;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term +;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms. +;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term + +(define (make-product . exps) + (let* ((terms (break-products exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (product-of-nums (fold-right * 1 nums))) + (cond ((null? non-nums) product-of-nums) + ((= product-of-nums 0) 0) + ((and (= product-of-nums 1) + (null? (cdr non-nums))) (car non-nums)) + ((= product-of-nums 1) (add-mult-signs non-nums)) + (else (add-mult-signs (cons product-of-nums non-nums)))))) + +;; (test-case (make-product 5 '(5 * x)) '(25 * x)) +;; (test-case (make-product 5 'x) '(5 * x)) +;; (test-case (make-product 5 2) 10) +;; (test-case (make-product 0 'x) 0) +;; (test-case (make-product 5 2 'x) '(10 * x)) +;; (test-case (make-product 5 1/5 'x 'y) '(x * y)) +;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x)) +;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y)) +;; (test-case (make-product (make-sum 5 'x) +;; (make-product 'x 'y) +;; (make-sum 'z 2)) +;; '((x + 5) * x * y * (z + 2))) +;; (test-case (make-product +;; (make-sum (make-product 5 'x) +;; (make-product 3 'y)) +;; (make-sum (make-product 2 'y) +;; (make-product 2 3)) +;; (make-sum (make-sum 'x 4) (make-product 3 'y))) +;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4))) +(test-case (make-sum (make-product 'a 'b) + (make-product 'c (make-sum 'd 1) 'e) + (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) + '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +(test-case (make-product (make-sum 5 'x) + (make-product 'x 'y) + (make-sum 'z 2)) + '((x + 5) * x * y * (z + 2))) + + + + +(test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3))) blob - /dev/null blob + 5cc4dad5e705fdba7a9b3c72d9a7fe60c2d5f0b3 (mode 644) --- /dev/null +++ ex2-58b.scm~ @@ -0,0 +1,440 @@ +(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 (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)))) + (error "unknown expression type -- DERIV" exp))) + +;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? + +(define (sum? x) + (and (not (number? x)) + (not (variable? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '+) + (sum? (cddr x))))) +;; sum? +;; (newline) +;; (display "sum??") +;; (newline) +;; (test-case (sum? '(5 + x)) #t) +;; (test-case (sum? '(5 * x + 3)) #t) +;; (test-case (sum? '(8 * x)) #f) +;; (test-case (sum? 5) #f) +;; (test-case (sum? '(5 * x + 8 * y)) #t) +;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t) + +;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list +(define (product? x) + (and (not (number? x)) + (not (variable? x)) + (not (sum? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '*) + (product? (cddr x))))) +;; (newline) +;; (display "product?") +;; (newline) +;; (test-case (product? '(2 * x * y + 4)) #f) +;; (test-case (product? '(x * y * z)) #t) +;; (test-case (product? '((x + 1) * y)) #t) +;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f) +;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f) + +;; If the first operation is +, we return the first element in the list +;; Otherwise, we join the first two elements to the addend of the rest +;; of the list. +(define (addend s) + (if (eq? '+ (cadr s)) + (car s) +;; we do not test if (cadddr s) is a number or variable because it might +;; be a single nested list + (if (eq? (cadddr s) '+) + (list (car s) (cadr s) (addend (cddr s))) + (cons (car s) + (cons (cadr s) + (addend (cddr s))))))) +;; (newline) +;; (display "addend") +;; (newline) +;; (test-case (addend '(a + b + c)) 'a) +;; (test-case (addend '(3 * x + 4 * y)) '(3 * x)) +;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1))) +;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y)) +;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2))) +;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) * (y + 3))) + +;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements. +(define (augend s) + (if (eq? '+ (cadr s)) + (if (null? (cdddr s)) + (caddr s) + (cddr s)) + (augend (cddr s)))) +;; (newline) +;; (display "augend") +;; (newline) +;; (test-case (augend '(x + 6)) '6) +;; (test-case (augend '(x + y + 6)) '(y + 6)) +;; (test-case (augend '(x + y * x)) '(y * x)) +;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5)) +;; (test-case (augend '(5 * x + 3 * y + 3)) +;; '(3 * y + 3)) +;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) + +(define (multiplier p) + (car p)) +;; (newline) +;; (display "multiplier") +;; (newline) +;; (test-case (multiplier '(5 * x)) 5) +;; (test-case (multiplier '(x * (x + 2))) 'x) +;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1)) +;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2)) +;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5)) +;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4)) +;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z)) + +(define (multiplicand p) + (if (null? (cdddr p)) + (caddr p) + (cddr p))) +;; (newline) +;; (display "multiplicand") +;; (newline) +;; (test-case (multiplicand '(5 * x)) 'x) +;; (test-case (multiplicand '(x * (x + 2))) '(x + 2)) +;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3))) +;; (test-case (multiplicand '((5 * x + 2) * y)) 'y) +;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) +;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z)) +;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y)) + +;; given a list of items to sum, check to see if any of the items are sums. +;; If they are, return a new list with the addend and augends as separate expressions +(define (break-sums exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (sum? x) + (cons (addend x) + (break-sums (cons (augend x) (cdr exps)))) + (cons x (break-sums (cdr exps))))))) + +;; (newline) +;; (display "break-sums") +;; (newline) +;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3)) +;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3)) +;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7)) + +;; interpolate '+ signs between expressions +(define (add-plus-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) (if (or (number? x) + (variable? x)) + (list x) + x)) ;; when x is a one-element list like '((x * y)) + ((or (number? x) + (variable? x)) (cons x (cons '+ (add-plus-signs remnant)))) + ((sum? x) (error "unexpected sum")) +;; if x is a product or some other complicated expression + ((product? x) (cons (multiplier x) + (cons '* + (add-plus-signs (cons (multiplicand x) remnant))))) + ;; (cons (multiplicand x) + ;; (cons '+ (add-plus-signs remnant)))))) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-plus-signs") +;; (newline) +;; (test-case (add-plus-signs '()) '()) +;; (test-case (add-plus-signs '(1)) '(1)) +;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4)) +;; (test-case (add-plus-signs '((x * y))) '(x * y)) +;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5)) +;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1))) +;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4)))) +;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4))) + +;; If the term is: +;; a number or a variable: we deal with it is without adding or removing any parentheses +;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term. +;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends individually. + +(define (make-sum . exps) + (let* ((terms (break-sums exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (sum-of-nums (fold-right + 0 nums))) + (cond ((null? non-nums) sum-of-nums) + ((and (= sum-of-nums 0) + (null? (cdr non-nums))) (car non-nums)) + ((= sum-of-nums 0) (add-plus-signs non-nums)) + (else (add-plus-signs (append non-nums (list sum-of-nums))))))) +(newline) +(display "make-sum") +(newline) +(test-case (make-sum 0 'x) 'x) +(test-case (make-sum 1 2) 3) +(test-case (make-sum 1 'x) '(x + 1)) +(test-case (make-sum 'x 'y) '(x + y)) +(test-case (make-sum (make-sum -3 'y) + (make-sum 3 'x)) '(y + x)) +(make-sum '(y + -3) '(x + 3)) +(make-sum 'y -3 'x 3) +(test-case (make-sum -3 'y 3 'x) '(y + x)) +(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +(test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials +(test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4)) +(test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y)) +(test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) + +;; (test-case (make-product (make-sum 5 'x) +;; (make-product 'x 'y) +;; (make-sum 'z 2)) +;; '((5 + x) * x * y * (z + 2))) +;; ;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses +;; (test-case (make-sum (make-sum -5 6 'x) +;; 'y +;; (make-sum -3 3)) +;; '(x + 1 + y)) ;; notice that the constant 1 is not right-most +;; (test-case (make-product (make-sum 2 4 (make-product 3 -2)) +;; (make-product 4 'y)) 0) +;; (test-case (make-sum (make-product 5 'x) +;; (make-product 3 'y) +;; (make-product 2 'y) +;; (make-product 2 3)) +;; '(5 * x + 3 * y + 2 * y + 6)) +;; (test-case (make-sum (make-product 5 'x 'y) +;; (make-product 4 'a 'b 'c)) +;; '(5 * x * y + 4 * a * b * c)) + + +(define (make-product . exps) + (let* ((nums (filter number? exps)) + (non-nums (filter (lambda (exp) (not (number? exp))) exps)) + (product-of-nums (fold-right * 1 nums))) + (cond ((null? non-nums) product-of-nums) + ((= product-of-nums 0) 0) + ((and (= product-of-nums 1) + (null? (cdr non-nums))) (car non-nums)) + ((= product-of-nums 1) (add-mult-signs non-nums)) + (else (add-mult-signs (cons product-of-nums non-nums)))))) + +(test-case (make-product 5 'x) '(5 * x)) +(test-case (make-product 5 2) 10) +(test-case (make-product 0 'x) 0) +(test-case (make-product 5 2 'x) '(10 * x)) +(test-case (make-product 5 1/5 'x 'y) '(x * y)) +(test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x)) +(test-case (make-product '(x + 3) 'y) '((x + 3) * y)) +(test-case + +If the exp is a: +variable or number, we just multiply without adding any extra parentheses +sum, then we must put parentheses around it and then multiply +product, then we just multiply without adding any extra parentheses +a complex expression, we just multiply without adding any extra parenthese around it + +;; (define (add-mult-signs exps) +;; (cond ((null? exps) '()) +;; ((null? (cdr exps)) exps) +;; (else (cons (car exps) +;; (cons '* +;; (add-mult-signs (cdr exps))))))) + + + + +'((2 * y + 3 * x) (4 * z + 5 * a)) +;; if there is no sum in exp, remove the parentheses + + + + + + + + + + + + + +;; make-sum +(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4)) +(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y)) +(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y)) +(test-case (make-sum (make-product 'a 'b) + (make-product 'c (make-sum 'd 1) 'e) + (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) + '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +(test-case (make-product 5 'x) '(5 * x)) +(test-case (make-product 5 2) 10) +(test-case (make-product 0 'x) 0) +(test-case (make-product 5 2 'x) '(10 * x)) +(test-case (make-product 5 1/5 'x 'y) '(x * y)) +(test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z)) +(test-case (make-product (make-sum 5 'x) + (make-product 'x 'y) + (make-sum 'z 2)) + '((5 + x) * x * y * (z + 2))) +;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses +(test-case (make-sum (make-sum -5 6 'x) + 'y + (make-sum -3 3)) + '(x + 1 + y)) ;; notice that the constant 1 is not right-most +(test-case (make-product (make-sum 2 4 (make-product 3 -2)) + (make-product 4 'y)) 0) +(test-case (make-sum (make-product 5 'x) + (make-product 3 'y) + (make-product 2 'y) + (make-product 2 3)) + '(5 * x + 3 * y + 2 * y + 6)) +(test-case (make-sum (make-product 5 'x 'y) + (make-product 4 'a 'b 'c)) + '(5 * x * y + 4 * a * b * c)) + + +(test-case (multiplier '(20 * x * ( (make-product (make-product 5 4 'x (make-sum 1 'y)) + (make-sum 2 'z))) + '(20 * x * (y + 1))) +(test-case (multiplier (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + 13) +(test-case (multiplicand (make-product 5 'x)) 'x) +(test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z)) +(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y)) +(test-case (multiplicand (make-product (make-sum 5 6 4 -2) + 'x 'y + (make-sum 1 -3 3))) + '(x * y)) + +(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3)))) + + +;; (define (make-sum . exps) +;; (let* ((nums (filter number? exps)) +;; (non-nums (filter (lambda (exp) (not (number? exp))) exps)) +;; (sum-of-nums (fold-right + 0 nums))) +;; (cond ((null? non-nums) sum-of-nums) +;; ((and (= sum-of-nums 0) +;; (null? (cdr non-nums))) (car non-nums)) +;; ((= sum-of-nums 0) (add-plus-signs non-nums)) +;; (else (add-plus-signs (append non-nums (list sum-of-nums))))))) + + + + + + + +(define (remove-parens exps) + (cond ((sum? exps) ...) + ...)) +(newline) +(display "remove-parens") +(newline) +(test-case (remove-parens '(0 x)) '(0 x)) +(test-case (remove-parents +(make-sum '(y + -3) + '(x + 3) + '(y + x + 3)) +(test-case (make-sum -3 'y 3 'x) '(y + x)) +(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +(test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum z (make-sum 1 x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials + +;; (test-case (remove-parens '(( + +;; (define (make-sum . exps) +;; (let* ((terms (append exps)) +;; (nums (filter number? terms)) +;; (non-nums (filter (lambda (exp) (not (number? exp))) terms)) +;; (sum-of-nums (fold-right + 0 nums))) +;; (cond ((null? non-nums) sum-of-nums) +;; ((and (= sum-of-nums 0) +;; (null? (cdr non-nums))) (car non-nums)) +;; ((= sum-of-nums 0) (add-signs non-nums '+)) +;; (else (add-plus-signs (append non-nums (list sum-of-nums))))))) + +;;given a list of expressions to add, remove unnecessary groupings +(define (extract-terms exps) + (if (null? exps) + '() + (let ((first-exp (car exps))) + (if (sum? first-exp) + (cons (addend first-exp) + (append (extract-terms (augend first-exp)) + (extract-terms (cdr exps)))))))) + (cons first-exp (extract-terms (cdr exprs))) + + + +(test-case (extract-terms '((y + -3) (x + 3))) '(y + +(test-case (make-sum (make-sum -3 'y) + (make-sum 3 'x)) '(y + x + 3)) +(make-sum '(y + -3) '(x + 3)) +(make-sum 'y -3 'x 3) +(test-case (make-sum -3 'y 3 'x) '(y + x)) +(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +(test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum z (make-sum 1 x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials + +(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4)) +(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y)) +(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y)) +(test-case (make-sum (make-product 'a 'b) + (make-product 'c (make-sum 'd 1) 'e) + (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) + '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +(test-case (make-product 5 'x) '(5 * x)) +(test-case (make-product 5 2) 10) +(test-case (make-product 0 'x) 0) +(test-case (make-product 5 2 'x) '(10 * x)) +(test-case (make-product 5 1/5 'x 'y) '(x * y)) +(test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z)) +(test-case (make-product (make-sum 5 'x) + (make-product 'x 'y) + (make-sum 'z 2)) + '((5 + x) * x * y * (z + 2))) +;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses +(test-case (make-sum (make-sum -5 6 'x) + 'y + (make-sum -3 3)) + '(x + 1 + y)) ;; notice that the constant 1 is not right-most +(test-case (make-product (make-sum 2 4 (make-product 3 -2)) + (make-product 4 'y)) 0) +(test-case (make-sum (make-product 5 'x) + (make-product 3 'y) + (make-product 2 'y) + (make-product 2 3)) + '(5 * x + 3 * y + 2 * y + 6)) +(test-case (make-sum (make-product 5 'x 'y) + (make-product 4 'a 'b 'c)) + '(5 * x * y + 4 * a * b * c)) blob - /dev/null blob + c990407070822ff655fd1ff7456c92885402f559 (mode 644) --- /dev/null +++ ex2-58c.scm @@ -0,0 +1,315 @@ +(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 (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)))) + (error "unknown expression type -- DERIV" exp))) + +;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? + +(define (sum? x) + (and (not (number? x)) + (not (variable? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '+) + (sum? (cddr x))))) +;; sum? +;; (newline) +;; (display "sum??") +;; (newline) +;; (test-case (sum? '(5 + x)) #t) +;; (test-case (sum? '(5 * x + 3)) #t) +;; (test-case (sum? '(8 * x)) #f) +;; (test-case (sum? 5) #f) +;; (test-case (sum? '(5 * x + 8 * y)) #t) +;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t) + +;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list +(define (product? x) + (and (not (number? x)) + (not (variable? x)) + (not (sum? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '*) + (product? (cddr x))))) +;; (newline) +;; (display "product?") +;; (newline) +;; (test-case (product? '(2 * x * y + 4)) #f) +;; (test-case (product? '(x * y * z)) #t) +;; (test-case (product? '((x + 1) * y)) #t) +;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f) +;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f) + +;; If the first operation is +, we return the first element in the list +;; Otherwise, we join the first two elements to the addend of the rest +;; of the list. +(define (addend s) + (if (eq? '+ (cadr s)) + (car s) +;; we do not test if (cadddr s) is a number or variable because it might +;; be a single nested list + (if (eq? (cadddr s) '+) + (list (car s) (cadr s) (addend (cddr s))) + (cons (car s) + (cons (cadr s) + (addend (cddr s))))))) +;; (newline) +;; (display "addend") +;; (newline) +;; (test-case (addend '(a + b + c)) 'a) +;; (test-case (addend '(3 * x + 4 * y)) '(3 * x)) +;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1))) +;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y)) +;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2))) +;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) * (y + 3))) + +;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements. +(define (augend s) + (if (eq? '+ (cadr s)) + (if (null? (cdddr s)) + (caddr s) + (cddr s)) + (augend (cddr s)))) +;; (newline) +;; (display "augend") +;; (newline) +;; (test-case (augend '(x + 6)) '6) +;; (test-case (augend '(x + y + 6)) '(y + 6)) +;; (test-case (augend '(x + y * x)) '(y * x)) +;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5)) +;; (test-case (augend '(5 * x + 3 * y + 3)) +;; '(3 * y + 3)) +;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) + +(define (multiplier p) + (car p)) +;; (newline) +;; (display "multiplier") +;; (newline) +;; (test-case (multiplier '(5 * x)) 5) +;; (test-case (multiplier '(x * (x + 2))) 'x) +;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1)) +;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2)) +;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5)) +;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4)) +;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z)) + +(define (multiplicand p) + (if (null? (cdddr p)) + (caddr p) + (cddr p))) +;; (newline) +;; (display "multiplicand") +;; (newline) +;; (test-case (multiplicand '(5 * x)) 'x) +;; (test-case (multiplicand '(x * (x + 2))) '(x + 2)) +;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3))) +;; (test-case (multiplicand '((5 * x + 2) * y)) 'y) +;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) +;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z)) +;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y)) + +;; given a list of items to sum, check to see if any of the items are sums. +;; If they are, return a new list with the addend and augends as separate expressions +(define (break-sums exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (sum? x) + (cons (addend x) + (break-sums (cons (augend x) (cdr exps)))) + (cons x (break-sums (cdr exps))))))) + +;; (newline) +;; (display "break-sums") +;; (newline) +;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3)) +;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3)) +;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7)) + +;; interpolate '+ signs between expressions +(define (add-plus-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) + (if (or (number? x) + (variable? x)) + (list x) + x)) ;; when x is a one-element list like '((x * y)) + ((or (number? x) + (variable? x)) + (cons x (cons '+ (add-plus-signs remnant)))) + ((sum? x) + (error "unexpected sum")) + ((product? x) + (cons (multiplier x) + (cons '* + (add-plus-signs (cons (multiplicand x) remnant))))) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-plus-signs") +;; (newline) +;; (test-case (add-plus-signs '()) '()) +;; (test-case (add-plus-signs '(1)) '(1)) +;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4)) +;; (test-case (add-plus-signs '((x * y))) '(x * y)) +;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5)) +;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1))) +;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4)))) +;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4))) + +;; If the term is: +;; a number or a variable: we deal with it is without adding or removing any parentheses +;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term. +;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends as separate terms +(define (make-sum . exps) + (let* ((terms (break-sums exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (sum-of-nums (fold-right + 0 nums))) + (cond ((null? non-nums) sum-of-nums) + ((and (= sum-of-nums 0) + (null? (cdr non-nums))) (car non-nums)) + ((= sum-of-nums 0) (add-plus-signs non-nums)) + (else (add-plus-signs (append non-nums (list sum-of-nums))))))) +;; (newline) +;; (display "make-sum") +;; (newline) +;; (test-case (make-sum 0 'x) 'x) +;; (test-case (make-sum 1 2) 3) +;; (test-case (make-sum 1 'x) '(x + 1)) +;; (test-case (make-sum 'x 'y) '(x + y)) +;; (test-case (make-sum (make-sum -3 'y) +;; (make-sum 3 'x)) '(y + x)) +;; (make-sum '(y + -3) '(x + 3)) +;; (make-sum 'y -3 'x 3) +;; (test-case (make-sum -3 'y 3 'x) '(y + x)) +;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +;; (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials +;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4)) +;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y)) +;; (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) + +;; given a list of items to multiply, check to see if any of the items are products. +;; If they are, return a new list with the multiplier and multiplicands as separate expressions +(define (break-products exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (product? x) + (cons (multiplier x) + (break-products (cons (multiplicand x) (cdr exps)))) + (cons x (break-products (cdr exps))))))) + +;; (newline) +;; (display "break-products") +;; (newline) +;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3)) +;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3)) +;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y)) + +;; interpolate '* signs between expressions +(define (add-mult-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) + (if (or (number? x) + (variable? x) + (sum? x)) + (list x) + x)) ;; when x is a one-element list like '((x ** y)) + ((or (number? x) + (variable? x) + (sum? x)) + (cons x (cons '* (add-mult-signs remnant)))) + ((product? x) + (error "unexpected product")) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-mult-signs") +;; (newline) +;; (test-case (add-mult-signs '()) '()) +;; (test-case (add-mult-signs '(1)) '(1)) +;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z)) +;; (test-case (add-mult-signs '((x * y))) '(x * y)) +;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y))) +;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x))) +;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4))) +;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4))) + +;; If the exp is a: +;; variable or number, we just multiply without adding any extra parentheses +;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term +;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms. +;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term + +(define (make-product . exps) + (let* ((terms (break-products exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (product-of-nums (fold-right * 1 nums))) + (cond ((null? non-nums) product-of-nums) + ((= product-of-nums 0) 0) + ((and (= product-of-nums 1) + (null? (cdr non-nums))) (car non-nums)) + ((= product-of-nums 1) (add-mult-signs non-nums)) + (else (add-mult-signs (cons product-of-nums non-nums)))))) + +;; (test-case (make-product 5 '(5 * x)) '(25 * x)) +;; (test-case (make-product 5 'x) '(5 * x)) +;; (test-case (make-product 5 2) 10) +;; (test-case (make-product 0 'x) 0) +;; (test-case (make-product 5 2 'x) '(10 * x)) +;; (test-case (make-product 5 1/5 'x 'y) '(x * y)) +;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x)) +;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y)) +;; (test-case (make-product (make-sum 5 'x) +;; (make-product 'x 'y) +;; (make-sum 'z 2)) +;; '((x + 5) * x * y * (z + 2))) +;; (test-case (make-product +;; (make-sum (make-product 5 'x) +;; (make-product 3 'y)) +;; (make-sum (make-product 2 'y) +;; (make-product 2 3)) +;; (make-sum (make-sum 'x 4) (make-product 3 'y))) +;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4))) +;; (test-case (make-sum (make-product 'a 'b) +;; (make-product 'c (make-sum 'd 1) 'e) +;; (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) +;; '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +;; (test-case (make-product (make-sum 5 'x) +;; (make-product 'x 'y) +;; (make-sum 'z 2)) +;; '((x + 5) * x * y * (z + 2))) + + + + +(test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3))) blob - /dev/null blob + 7ecac9b8e9145b03f382baf87565ca8a9aa2a84d (mode 644) --- /dev/null +++ ex2-58c.scm~ @@ -0,0 +1,315 @@ +(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 (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)))) + (error "unknown expression type -- DERIV" exp))) + +;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? + +(define (sum? x) + (and (not (number? x)) + (not (variable? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '+) + (sum? (cddr x))))) +;; sum? +;; (newline) +;; (display "sum??") +;; (newline) +;; (test-case (sum? '(5 + x)) #t) +;; (test-case (sum? '(5 * x + 3)) #t) +;; (test-case (sum? '(8 * x)) #f) +;; (test-case (sum? 5) #f) +;; (test-case (sum? '(5 * x + 8 * y)) #t) +;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t) + +;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list +(define (product? x) + (and (not (number? x)) + (not (variable? x)) + (not (sum? x)) + (not (null? (cdr x))) + (or (eq? (cadr x) '*) + (product? (cddr x))))) +;; (newline) +;; (display "product?") +;; (newline) +;; (test-case (product? '(2 * x * y + 4)) #f) +;; (test-case (product? '(x * y * z)) #t) +;; (test-case (product? '((x + 1) * y)) #t) +;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f) +;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f) + +;; If the first operation is +, we return the first element in the list +;; Otherwise, we join the first two elements to the addend of the rest +;; of the list. +(define (addend s) + (if (eq? '+ (cadr s)) + (car s) +;; we do not test if (cadddr s) is a number or variable because it might +;; be a single nested list + (if (eq? (cadddr s) '+) + (list (car s) (cadr s) (addend (cddr s))) + (cons (car s) + (cons (cadr s) + (addend (cddr s))))))) +;; (newline) +;; (display "addend") +;; (newline) +;; (test-case (addend '(a + b + c)) 'a) +;; (test-case (addend '(3 * x + 4 * y)) '(3 * x)) +;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1))) +;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y)) +;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2))) +;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) * (y + 3))) + +;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements. +(define (augend s) + (if (eq? '+ (cadr s)) + (if (null? (cdddr s)) + (caddr s) + (cddr s)) + (augend (cddr s)))) +;; (newline) +;; (display "augend") +;; (newline) +;; (test-case (augend '(x + 6)) '6) +;; (test-case (augend '(x + y + 6)) '(y + 6)) +;; (test-case (augend '(x + y * x)) '(y * x)) +;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5)) +;; (test-case (augend '(5 * x + 3 * y + 3)) +;; '(3 * y + 3)) +;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) +;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) + +(define (multiplier p) + (car p)) +;; (newline) +;; (display "multiplier") +;; (newline) +;; (test-case (multiplier '(5 * x)) 5) +;; (test-case (multiplier '(x * (x + 2))) 'x) +;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1)) +;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2)) +;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5)) +;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4)) +;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z)) + +(define (multiplicand p) + (if (null? (cdddr p)) + (caddr p) + (cddr p))) +;; (newline) +;; (display "multiplicand") +;; (newline) +;; (test-case (multiplicand '(5 * x)) 'x) +;; (test-case (multiplicand '(x * (x + 2))) '(x + 2)) +;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3))) +;; (test-case (multiplicand '((5 * x + 2) * y)) 'y) +;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) +;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z)) +;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y)) + +;; given a list of items to sum, check to see if any of the items are sums. +;; If they are, return a new list with the addend and augends as separate expressions +(define (break-sums exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (sum? x) + (cons (addend x) + (break-sums (cons (augend x) (cdr exps)))) + (cons x (break-sums (cdr exps))))))) + +;; (newline) +;; (display "break-sums") +;; (newline) +;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3)) +;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3)) +;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7)) + +;; interpolate '+ signs between expressions +(define (add-plus-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) + (if (or (number? x) + (variable? x)) + (list x) + x)) ;; when x is a one-element list like '((x * y)) + ((or (number? x) + (variable? x)) + (cons x (cons '+ (add-plus-signs remnant)))) + ((sum? x) + (error "unexpected sum")) + ((product? x) + (cons (multiplier x) + (cons '* + (add-plus-signs (cons (multiplicand x) remnant))))) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-plus-signs") +;; (newline) +;; (test-case (add-plus-signs '()) '()) +;; (test-case (add-plus-signs '(1)) '(1)) +;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4)) +;; (test-case (add-plus-signs '((x * y))) '(x * y)) +;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5)) +;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1))) +;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4)))) +;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4))) + +;; If the term is: +;; a number or a variable: we deal with it is without adding or removing any parentheses +;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term. +;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends as separate terms +(define (make-sum . exps) + (let* ((terms (break-sums exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (sum-of-nums (fold-right + 0 nums))) + (cond ((null? non-nums) sum-of-nums) + ((and (= sum-of-nums 0) + (null? (cdr non-nums))) (car non-nums)) + ((= sum-of-nums 0) (add-plus-signs non-nums)) + (else (add-plus-signs (append non-nums (list sum-of-nums))))))) +;; (newline) +;; (display "make-sum") +;; (newline) +;; (test-case (make-sum 0 'x) 'x) +;; (test-case (make-sum 1 2) 3) +;; (test-case (make-sum 1 'x) '(x + 1)) +;; (test-case (make-sum 'x 'y) '(x + y)) +;; (test-case (make-sum (make-sum -3 'y) +;; (make-sum 3 'x)) '(y + x)) +;; (make-sum '(y + -3) '(x + 3)) +;; (make-sum 'y -3 'x 3) +;; (test-case (make-sum -3 'y 3 'x) '(y + x)) +;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d)) +;; (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials +;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4)) +;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y)) +;; (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) + +;; given a list of items to multiply, check to see if any of the items are products. +;; If they are, return a new list with the multiplier and multiplicands as separate expressions +(define (break-products exps) + (if (null? exps) + '() + (let ((x (car exps))) + (if (product? x) + (cons (multiplier x) + (break-products (cons (multiplicand x) (cdr exps)))) + (cons x (break-products (cdr exps))))))) + +;; (newline) +;; (display "break-products") +;; (newline) +;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3)) +;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3)) +;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y)) + +;; interpolate '* signs between expressions +(define (add-mult-signs exps) + (if (null? exps) + '() ;; this should never execute + (let ((x (car exps)) + (remnant (cdr exps))) + (cond ((null? remnant) + (if (or (number? x) + (variable? x) + (sum? x)) + (list x) + x)) ;; when x is a one-element list like '((x ** y)) + ((or (number? x) + (variable? x) + (sum? x)) + (cons x (cons '* (add-mult-signs remnant)))) + ((product? x) + (error "unexpected product")) + (else (error "expression type not yet implemented")))))) +;; (newline) +;; (display "add-mult-signs") +;; (newline) +;; (test-case (add-mult-signs '()) '()) +;; (test-case (add-mult-signs '(1)) '(1)) +;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z)) +;; (test-case (add-mult-signs '((x * y))) '(x * y)) +;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y))) +;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x))) +;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4))) +;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4))) + +;; If the exp is a: +;; variable or number, we just multiply without adding any extra parentheses +;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term +;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms. +;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term + +(define (make-product . exps) + (let* ((terms (break-products exps)) + (nums (filter number? terms)) + (non-nums (filter (lambda (exp) (not (number? exp))) terms)) + (product-of-nums (fold-right * 1 nums))) + (cond ((null? non-nums) product-of-nums) + ((= product-of-nums 0) 0) + ((and (= product-of-nums 1) + (null? (cdr non-nums))) (car non-nums)) + ((= product-of-nums 1) (add-mult-signs non-nums)) + (else (add-mult-signs (cons product-of-nums non-nums)))))) + +;; (test-case (make-product 5 '(5 * x)) '(25 * x)) +;; (test-case (make-product 5 'x) '(5 * x)) +;; (test-case (make-product 5 2) 10) +;; (test-case (make-product 0 'x) 0) +;; (test-case (make-product 5 2 'x) '(10 * x)) +;; (test-case (make-product 5 1/5 'x 'y) '(x * y)) +;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x)) +;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y)) +;; (test-case (make-product (make-sum 5 'x) +;; (make-product 'x 'y) +;; (make-sum 'z 2)) +;; '((x + 5) * x * y * (z + 2))) +;; (test-case (make-product +;; (make-sum (make-product 5 'x) +;; (make-product 3 'y)) +;; (make-sum (make-product 2 'y) +;; (make-product 2 3)) +;; (make-sum (make-sum 'x 4) (make-product 3 'y))) +;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4))) +(test-case (make-sum (make-product 'a 'b) + (make-product 'c (make-sum 'd 1) 'e) + (make-product (make-sum 'f 2) (make-sum 'g 3) 'h)) + '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h)) +(test-case (make-product (make-sum 5 'x) + (make-product 'x 'y) + (make-sum 'z 2)) + '((x + 5) * x * y * (z + 2))) + + + + +(test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3))) blob - /dev/null blob + 3da4a716fdb208f1a1d1cbb3d82f844812ad86dc (mode 644) --- /dev/null +++ ex2-59-sol.scm @@ -0,0 +1,5 @@ +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) (union-set (cdr set1) set2)) + (else (cons (car set1) (union-set (cdr set1) set2))))) blob - /dev/null blob + fa2a1f3391289f0bfa5a8951686918d1f693a1dc (mode 644) --- /dev/null +++ ex2-59.lisp @@ -0,0 +1,7 @@ +(defun union-set (set1 set2) + (append + set1 + (remove-if + (lambda (x) + (element-of-set? x set1)) + set2))) blob - /dev/null blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644) blob - /dev/null blob + 354c6572d6c2d6c9c2fd14e017f924dd7f8db5a2 (mode 644) --- /dev/null +++ ex2-59.scm @@ -0,0 +1,33 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + +(define (element-of-set? x set) + (cond ((null? set) false) + ((equal? x (car set)) true) + (else (element-of-set? x (cdr set))))) +(define (adjoin-set x set) + (if (element-of-set? x set) + set + (cons x set))) +(define (intersection-set set1 set2) + (cond ((or (null? set1) (null? set2)) '()) + ((element-of-set? (car set1) set2) + (cons (car set1) + (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) (union-set (cdr set1) set2)) + (else (cons (car set1) (union-set (cdr set1) set2))))) + +(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4)) + + blob - /dev/null blob + 9df7d9eb5dfa240ab3252de61e5348c5631f8c09 (mode 644) --- /dev/null +++ ex2-59.scm~ @@ -0,0 +1,20 @@ +(element-of-set? x (adjoin-set x S)) +(element-of-set? x (union-set S T)) +(or (element-of-set? x S) (element-of-set? x T)) +(element-of-set? x '()) +(define (element-of-set? x set) + (cond ((null? set) false) + ((equal? x (car set)) true) + (else (element-of-set? x (cdr set))))) +(define (adjoin-set x set) + (if (element-of-set? x set) + set + (cons x set))) +(define (intersection-set set1 set2) + (cond ((or (null? set1) (null? set2)) '()) + ((element-of-set? (car set1) set2) + (cons (car set1) + (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) + +(define (union-set blob - /dev/null blob + b36ea77e3959cc80f78cfcc00abb71a42cda520b (mode 644) --- /dev/null +++ ex2-6.lisp @@ -0,0 +1,16 @@ +(defvar zero + (lambda (f) + (lambda (x) x))) +(defun add-1 (n) + (lambda (f) + (lambda (x) + (funcall f (funcall (funcall n f) x))))) +(defvar one + (lambda (f) + (lambda (x) (funcall f x)))) +(defvar two + (lambda (f) + (lambda (x) (funcall f (funcall f x))))) +(defun add (a b) + (lambda (f) + (lambda (x) (funcall (funcall a f) (funcall (funcall b f) x))))) blob - /dev/null blob + 935382723ab73954eace1960c85e94f2eb259e14 (mode 644) --- /dev/null +++ ex2-6.lisp~ @@ -0,0 +1,3 @@ +(defvar zero + (lambda (f) + (lambda (x) x))) blob - /dev/null blob + b8848df39fef6746cd92053597d5352111886380 (mode 644) --- /dev/null +++ ex2-6.scm @@ -0,0 +1,33 @@ +;; Exercise 2.6. In case representing pairs as procedures wasn't mind-boggling enough, consider that, in a language that can manipulate procedures, we can get by without numbers (at least insofar as nonnegative integers are concerned) by implementing 0 and the operation of adding 1 as + +(define zero (lambda (f) (lambda (x) x))) + +(define (add-1 n) + (lambda (f) (lambda (x) (f ((n f) x))))) + +;; This representation is known as Church numerals, after its inventor, Alonzo Church, the logician who invented the calculus. + +;; Define one and two directly (not in terms of zero and add-1). (Hint: Use substitution to evaluate (add-1 zero)). Give a direct definition of the addition procedure + (not in terms of repeated application of add-1). + +(define one (add-1 zero)) + +(lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) x)) f) x)))) +;;(lambda (f) (lambda (x) (f ((n f) x)))) +(lambda (f) (lambda (x) (f (((lambda (f) f)) x)))) +(lambda (f) (lambda (x) (f ((lambda (f) f) x)))) +(lambda (f) (lambda (x) (f x))) +(lambda (f) (lambda (x) (f x))) + +(define one (lambda (f) (lambda (x) (f x)))) +(define two (add-1 one)) + +(lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) (f x))) f) x)))) +(lambda (f) (lambda (x) (f ((lambda (x) (f x)) x)))) +(lambda (f) (lambda (x) (f (f x)))) + +(define two (lambda (f) (lambda (x) (f (f x))))) + +;; Give a direct definition of the addition procedure + (not in terms of repeated application of add-1). + +(define (+ a b) + (lambda (f) (lambda (x) ((a f) ((b f) x))))) blob - /dev/null blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644) blob - /dev/null blob + f86fe2479d75b584f06a5f6c799a35b654af4de4 (mode 644) --- /dev/null +++ ex2-60.scm @@ -0,0 +1,69 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + +(define (element-of-set? x set) + (cond ((null? set) false) + ((equal? x (car set)) true) + (else (element-of-set? x (cdr set))))) +(define (adjoin-set x set) + (if (element-of-set? x set) + set + (cons x set))) +(define (intersection-set set1 set2) + (cond ((or (null? set1) (null? set2)) '()) + ((element-of-set? (car set1) set2) + (cons (car set1) + (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) (union-set (cdr set1) set2)) + (else (cons (car set1) (union-set (cdr set1) set2))))) + +(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4)) + +;; Exercise 2.60. We specified that a set would be represented as a list with no duplicates. Now suppose we allow duplicates. For instance, the set {1,2,3} could be represented as the list (2 3 2 1 3 2 2). Design procedures element-of-set?, adjoin-set, union-set, and intersection-set that operate on this representation. How does the efficiency of each compare with the corresponding procedure for the non-duplicate representation? Are there applications for which you would use this representation in preference to the non-duplicate one? + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((equal? x (car set)) #t) + (else (element-of-set? x (cdr set))))) +(test-case (element-of-set? 4 '(1 3 5 2 3 5 5)) #f) +(test-case (element-of-set? 3 '(1 3 5 2 3 5 5)) #t) + +(define (adjoin-set x set) + (cons x set)) + +(test-case (adjoin-set 5 '()) '(5)) +(test-case (adjoin-set 5 '(1 3)) '(5 1 3)) +(test-case (adjoin-set 5 '(5 5 1 3)) '(5 5 5 1 3)) + +(define (union-set set1 set2) + (append set1 set2)) + +(test-case (union-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 3 5 4 2 8 1 5)) + +(define (intersection-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) + (cons (car set1) (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) + +(test-case (intersection-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 5 4 2 8 1 5)) + +;; the new set has a lot of duplicated entries so that element-of-set? and +;; intersection-set are much slower. The more duplicate entries, the slower +;; they become. However, adjoin-set and union-set become extremely easy and +;; fast to implement. You might use this representation when it is more +;; important to be able to join two sets or add new elements to a set +;; than it is to see if an element belongs to a set or is part of an +;; intersection of two sets. blob - /dev/null blob + 354c6572d6c2d6c9c2fd14e017f924dd7f8db5a2 (mode 644) --- /dev/null +++ ex2-60.scm~ @@ -0,0 +1,33 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + +(define (element-of-set? x set) + (cond ((null? set) false) + ((equal? x (car set)) true) + (else (element-of-set? x (cdr set))))) +(define (adjoin-set x set) + (if (element-of-set? x set) + set + (cons x set))) +(define (intersection-set set1 set2) + (cond ((or (null? set1) (null? set2)) '()) + ((element-of-set? (car set1) set2) + (cons (car set1) + (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) (union-set (cdr set1) set2)) + (else (cons (car set1) (union-set (cdr set1) set2))))) + +(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4)) + + blob - /dev/null blob + a0f25894ba5e4acd2dbecfbb6485293bbdaeeeb9 (mode 644) --- /dev/null +++ ex2-61.scm @@ -0,0 +1,41 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (element-of-set? x set) + (cond ((null? set) false) + ((= x (car set)) true) + ((< x (car set)) false) + (else (element-of-set? x (cdr set))))) +(define (intersection-set set1 set2) + (if (or (null? set1) (null? set2)) + '() + (let ((x1 (car set1)) (x2 (car set2))) + (cond ((= x1 x2) (cons x1 + (intersection-set (cdr set1) + (cdr set2)))) + ((< x1 x2) (intersection-set (cdr set1) + set2)) + ((> x1 x2) (intersection-set set1 + (cdr set2))))))) + +;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation. + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((= x (car set)) set) + ((< x (car set)) (cons x set)) + (else (cons (car set) (adjoin-set x (cdr set)))))) + +(test-case (adjoin-set 5 '()) '(5)) +(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9)) +(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9)) + + Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists. blob - /dev/null blob + f86fe2479d75b584f06a5f6c799a35b654af4de4 (mode 644) --- /dev/null +++ ex2-61.scm~ @@ -0,0 +1,69 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + +(define (element-of-set? x set) + (cond ((null? set) false) + ((equal? x (car set)) true) + (else (element-of-set? x (cdr set))))) +(define (adjoin-set x set) + (if (element-of-set? x set) + set + (cons x set))) +(define (intersection-set set1 set2) + (cond ((or (null? set1) (null? set2)) '()) + ((element-of-set? (car set1) set2) + (cons (car set1) + (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) (union-set (cdr set1) set2)) + (else (cons (car set1) (union-set (cdr set1) set2))))) + +(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4)) + +;; Exercise 2.60. We specified that a set would be represented as a list with no duplicates. Now suppose we allow duplicates. For instance, the set {1,2,3} could be represented as the list (2 3 2 1 3 2 2). Design procedures element-of-set?, adjoin-set, union-set, and intersection-set that operate on this representation. How does the efficiency of each compare with the corresponding procedure for the non-duplicate representation? Are there applications for which you would use this representation in preference to the non-duplicate one? + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((equal? x (car set)) #t) + (else (element-of-set? x (cdr set))))) +(test-case (element-of-set? 4 '(1 3 5 2 3 5 5)) #f) +(test-case (element-of-set? 3 '(1 3 5 2 3 5 5)) #t) + +(define (adjoin-set x set) + (cons x set)) + +(test-case (adjoin-set 5 '()) '(5)) +(test-case (adjoin-set 5 '(1 3)) '(5 1 3)) +(test-case (adjoin-set 5 '(5 5 1 3)) '(5 5 5 1 3)) + +(define (union-set set1 set2) + (append set1 set2)) + +(test-case (union-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 3 5 4 2 8 1 5)) + +(define (intersection-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((element-of-set? (car set1) set2) + (cons (car set1) (intersection-set (cdr set1) set2))) + (else (intersection-set (cdr set1) set2)))) + +(test-case (intersection-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 5 4 2 8 1 5)) + +;; the new set has a lot of duplicated entries so that element-of-set? and +;; intersection-set are much slower. The more duplicate entries, the slower +;; they become. However, adjoin-set and union-set become extremely easy and +;; fast to implement. You might use this representation when it is more +;; important to be able to join two sets or add new elements to a set +;; than it is to see if an element belongs to a set or is part of an +;; intersection of two sets. blob - /dev/null blob + 3752e1bcc5f60a0b5a9ab9c3b0b0e0e74e436465 (mode 644) --- /dev/null +++ ex2-62-sol.scm @@ -0,0 +1,26 @@ +(define (element-of-set? x set) + (cond ((null? set) false) + ((= x (car set)) true) + ((< x (car set)) false) + (else (element-of-set? x (cdr set))))) +(define (intersection-set set1 set2) + (if (or (null? set1) (null? set2)) + '() + (let ((x1 (car set1)) (x2 (car set2))) + (cond ((= x1 x2) (cons x1 (intersection-set (cdr set1) (cdr set2)))) + ((< x1 x2) (intersection-set (cdr set1) set2)) + ((< x2 x1) (intersection-set set1 (cdr set2))))))) +(define (adjoin-set x set) + (cond ((null? set) (cons x '())) + ((= x (car set)) set) + ((< x (car set)) (cons x set)) + ((> x (car set)) (cons (car set) + (adjoin-set x (cdr set)))))) +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + ((= (car set1) (car set2)) + (cons (car set1) (union-set (cdr set1) (cdr set2)))) + ((< (car set1) (car set2)) + (cons (car set1) (union-set (cdr set1) set2))) + (else (cons (car set2) (union-set set1 (cdr set2)))))) blob - /dev/null blob + 9a92014f76eabc433096459e37fcaafbb93b526f (mode 644) --- /dev/null +++ ex2-62-sol.scm~ @@ -0,0 +1,5 @@ +(define (element-of-set? x set) + (cond ((null? set) false) + ((= x (car set)) true) + ((< x (car set)) false) + (else (element-of-set? x (cdr set))))) blob - /dev/null blob + 758b3e0e59c519d62b8f90d72dd224cc309dcdc9 (mode 644) --- /dev/null +++ ex2-62.lisp @@ -0,0 +1,36 @@ +(defun union-set (set1 set2) + (append + set1 + (remove-if + (lambda (x) + (element-of-set? x set1)) + set22))) +(defun element-of-multiset? (x set) + (member x set :test #'equal)) +(defun intersection-multiset (set1 set2) + (cond ((or (null set1) (null set2)) '()) + ((element-of-multiset? (car set1) set2) + (cons (car set1) + (intersection-multiset (cdr set1) set2))) + (t (intersection-multiset (cdr set1) set2)))) +(defun adjoin-multiset (x set) + (cons x set)) +(defun union-multiset (set1 set2) + (append set1 set2)) + +(defun adjoin-set (x set) + (cond ((null set) (cons x '())) + ((< x (car set)) (cons x set)) + ((= x (car set)) set) + (t (cons (car set) + (adjoin-set x (cdr set)))))) +(defun union-set (set1 set2) + (let ((x1 (car set1)) (x2 (car set2))) + (cond ((null x1) set2) + ((null x2) set1) + ((= x1 x2) + (cons x1 (union-set (cdr set1) (cdr set2)))) + ((< x1 x2) + (cons x1 (union-set (cdr set1) set2))) + (t + (cons x2 (union-set set1 (cdr set2))))))) blob - /dev/null blob + 96b0585b719670fc241a0ae8f99cf092fa411694 (mode 644) --- /dev/null +++ ex2-62.lisp~ @@ -0,0 +1,57 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (element-of-set? x set) + (cond ((null? set) false) + ((= x (car set)) true) + ((< x (car set)) false) + (else (element-of-set? x (cdr set))))) +(define (intersection-set set1 set2) + (if (or (null? set1) (null? set2)) + '() + (let ((x1 (car set1)) (x2 (car set2))) + (cond ((= x1 x2) (cons x1 + (intersection-set (cdr set1) + (cdr set2)))) + ((< x1 x2) (intersection-set (cdr set1) + set2)) + ((> x1 x2) (intersection-set set1 + (cdr set2))))))) + +;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation. + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((= x (car set)) set) + ((< x (car set)) (cons x set)) + (else (cons (car set) (adjoin-set x (cdr set)))))) + +(test-case (adjoin-set 5 '()) '(5)) +(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9)) +(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9)) + +;; Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists. + +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + (else + (let ((x1 (car set1)) + (x2 (car set2))) + (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2)))) + ((< x1 x2) (cons x1 (union-set (cdr set1) set2))) + ((> x1 x2) (cons x2 (union-set set1 (cdr set2))))))))) + +(test-case (union-set '(1 2 3 4 5) '(2 3 4)) '(1 2 3 4 5)) +(test-case (union-set '(1 2 3) '()) '(1 2 3)) +(test-case (union-set '() '(1 2 3)) '(1 2 3)) +(test-case (union-set '(1 2 3 4 5) '(6 7 8 9 10)) '(1 2 3 4 5 6 7 8 9 10)) +(test-case (union-set '(1 3 5 7) '(2 3 4 5)) '(1 2 3 4 5 7)) blob - /dev/null blob + 96b0585b719670fc241a0ae8f99cf092fa411694 (mode 644) --- /dev/null +++ ex2-62.scm @@ -0,0 +1,57 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (element-of-set? x set) + (cond ((null? set) false) + ((= x (car set)) true) + ((< x (car set)) false) + (else (element-of-set? x (cdr set))))) +(define (intersection-set set1 set2) + (if (or (null? set1) (null? set2)) + '() + (let ((x1 (car set1)) (x2 (car set2))) + (cond ((= x1 x2) (cons x1 + (intersection-set (cdr set1) + (cdr set2)))) + ((< x1 x2) (intersection-set (cdr set1) + set2)) + ((> x1 x2) (intersection-set set1 + (cdr set2))))))) + +;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation. + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((= x (car set)) set) + ((< x (car set)) (cons x set)) + (else (cons (car set) (adjoin-set x (cdr set)))))) + +(test-case (adjoin-set 5 '()) '(5)) +(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9)) +(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9)) + +;; Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists. + +(define (union-set set1 set2) + (cond ((null? set1) set2) + ((null? set2) set1) + (else + (let ((x1 (car set1)) + (x2 (car set2))) + (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2)))) + ((< x1 x2) (cons x1 (union-set (cdr set1) set2))) + ((> x1 x2) (cons x2 (union-set set1 (cdr set2))))))))) + +(test-case (union-set '(1 2 3 4 5) '(2 3 4)) '(1 2 3 4 5)) +(test-case (union-set '(1 2 3) '()) '(1 2 3)) +(test-case (union-set '() '(1 2 3)) '(1 2 3)) +(test-case (union-set '(1 2 3 4 5) '(6 7 8 9 10)) '(1 2 3 4 5 6 7 8 9 10)) +(test-case (union-set '(1 3 5 7) '(2 3 4 5)) '(1 2 3 4 5 7)) blob - /dev/null blob + a0f25894ba5e4acd2dbecfbb6485293bbdaeeeb9 (mode 644) --- /dev/null +++ ex2-62.scm~ @@ -0,0 +1,41 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (element-of-set? x set) + (cond ((null? set) false) + ((= x (car set)) true) + ((< x (car set)) false) + (else (element-of-set? x (cdr set))))) +(define (intersection-set set1 set2) + (if (or (null? set1) (null? set2)) + '() + (let ((x1 (car set1)) (x2 (car set2))) + (cond ((= x1 x2) (cons x1 + (intersection-set (cdr set1) + (cdr set2)))) + ((< x1 x2) (intersection-set (cdr set1) + set2)) + ((> x1 x2) (intersection-set set1 + (cdr set2))))))) + +;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation. + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((= x (car set)) set) + ((< x (car set)) (cons x set)) + (else (cons (car set) (adjoin-set x (cdr set)))))) + +(test-case (adjoin-set 5 '()) '(5)) +(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5)) +(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9)) +(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9)) + + Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists. blob - /dev/null blob + a9f5db0d7f13c2ddd42b52258a4697109a27900a (mode 644) --- /dev/null +++ ex2-63-sol.scm @@ -0,0 +1,15 @@ +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) blob - /dev/null blob + 52ea5b0e15be8c0d2b5f024995ab567448ff3bca (mode 644) --- /dev/null +++ ex2-63-sol.scm~ @@ -0,0 +1,6 @@ +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) blob - /dev/null blob + f6ad0a861bc86803da1bb605f2a9745093ccc34e (mode 644) --- /dev/null +++ ex2-63.scm @@ -0,0 +1,48 @@ +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) + +;; a. Do the two procedures produce the same result for every tree? If not, how do the results differ? What lists do the two procedures produce for the trees in figure 2.16? + +;; Yes, they produce the same result for every tree. They both produce '(1, 3, 5, 7, 9, 11) + +;; b. Do the two procedures have the same order of growth in the number of steps required to convert a balanced tree with n elements to a list? If not, which one grows more slowly? + +;; No, the second procedure is faster. Each procedure makes around n calls to itself (slightly more calls since there are 2 extra per tree with empty leaves). However, the first procedure uses append whereas the second one uses cons. Append has order of growth of (length list1), so I'm guessing the overall order of growth for tree->list-1 is n^2? whereas it is n? for tree->list-2. blob - /dev/null blob + bd27e61af567d5cd9cb80387634c5a7800a8d78f (mode 644) --- /dev/null +++ ex2-63.scm~ @@ -0,0 +1,25 @@ +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) blob - /dev/null blob + 8aa54fb859cd12ddf62b7bdec24091a65d49a369 (mode 644) --- /dev/null +++ ex2-64-sol.scm @@ -0,0 +1,17 @@ +(define (list->tree elements) + (car (partial-tree elements (length elements)))) + +(define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let ((left-size (quotient (- n 1) 2))) + (let ((left-result (partial-tree elts left-size))) + (let ((left-tree (car left-result)) + (non-left-elts (cdr left-result)) + (right-size (- n (+ left-size 1)))) + (let ((this-entry (car non-left-elts)) + (right-result (partial-tree (cdr non-left-elts) right-size))) + (let ((right-tree (car right-result)) + (remaining-elts (cdr right-result))) + (cons (make-tree this-entry left-tree right-tree) + remaining-elts)))))))) blob - /dev/null blob + 1b01040857912da11f6aabc88fc5b5fed97de149 (mode 644) --- /dev/null +++ ex2-64-sol.scm~ @@ -0,0 +1,67 @@ +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) + +(define (list->tree elements) + (car (partial-tree elements (length elements)))) + +(define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let ((left-size (quotient (- n 1) 2))) + (let ((left-result (partial-tree elts left-size))) + (let ((left-tree (car left-result)) + (non-left-elts (cdr left-result)) + (right-size (- n (+ left-size 1)))) + (let ((this-entry (car non-left-elts)) + (right-result (partial-tree (cdr non-left-elts) + right-size))) + (let ((right-tree (car right-result)) + (remaining-elts (cdr right-result))) + (cons (make-tree this-entry left-tree right-tree) + remaining-elts)))))))) + +;; a. Write a short paragraph explaining as clearly as you can how partial-tree works. Draw the tree produced by list->tree for the list (1 3 5 7 9 11). + +;; If we want a tree with 0 elements in it, we just return an empty tree (nil). Otherwise, we're going to build a tree by finding the middle element of a list rounded down (so if we had 6 elements, the middle element will be 3. If we have 7 elements, it will be 4). We then create a tree with the middle element as the entry of the tree and then call ourselves recursively to build the left-branch of the tree and the right-branch of the tree. We then return this tree along with any elements that have not been put into the tree. The reason we need the remaining elements is because it helps us quickly pass along all the elements of the list that go into the entry and right branch of the tree. + +;; b. What is the order of growth in the number of steps required by list->tree to convert a list of n elements? + +;; We call partial-tree O(n) times for a list of n elements (a bit more again because we also call it when n = 0). It looks like the order of growth is roughly O(n). blob - /dev/null blob + 92ca09ffa4830153458b67c6bcd57df6b6ba6d9f (mode 644) --- /dev/null +++ ex2-64.lisp @@ -0,0 +1 @@ +(defun partial-tree blob - /dev/null blob + cea74c0cf0c339042170e0728c45f12e0e60c9eb (mode 644) --- /dev/null +++ ex2-64.scm @@ -0,0 +1,83 @@ +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) + +(define (list->tree elements) + (car (partial-tree elements (length elements)))) + +(define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let ((left-size (quotient (- n 1) 2))) + (let ((left-result (partial-tree elts left-size))) + (let ((left-tree (car left-result)) + (non-left-elts (cdr left-result)) + (right-size (- n (+ left-size 1)))) + (let ((this-entry (car non-left-elts)) + (right-result (partial-tree (cdr non-left-elts) + right-size))) + (let ((right-tree (car right-result)) + (remaining-elts (cdr right-result))) + (cons (make-tree this-entry left-tree right-tree) + remaining-elts)))))))) + +;; a. Write a short paragraph explaining as clearly as you can how partial-tree works. Draw the tree produced by list->tree for the list (1 3 5 7 9 11). + +;; If we want a tree with 0 elements in it, we just return an empty tree (nil). Otherwise, we're going to build a tree by finding the middle element of a list rounded down (so if we had 6 elements, the middle element will be 3. If we have 7 elements, it will be 4). We then create a tree with the middle element as the entry of the tree and then call ourselves recursively to build the left-branch of the tree and the right-branch of the tree. We then return this tree along with any elements that have not been put into the tree. The reason we need the remaining elements is because it helps us quickly pass along all the elements of the list that go into the entry and right branch of the tree. + +;; b. What is the order of growth in the number of steps required by list->tree to convert a list of n elements? + +;; We call partial-tree O(n) times for a list of n elements (a bit more again because we also call it when n = 0). It looks like the order of growth is roughly O(n). + +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (cons-tree->list tree larger-items) + (if (null? tree) + larger-items + (cons-tree->list (left-branch tree) + (cons (entry tree) + (cons-tree->list (right-branch tree) + larger-items))))) + (cons-tree->list tree '())) blob - /dev/null blob + cea74c0cf0c339042170e0728c45f12e0e60c9eb (mode 644) --- /dev/null +++ ex2-64.scm~ @@ -0,0 +1,83 @@ +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) + +(define (list->tree elements) + (car (partial-tree elements (length elements)))) + +(define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let ((left-size (quotient (- n 1) 2))) + (let ((left-result (partial-tree elts left-size))) + (let ((left-tree (car left-result)) + (non-left-elts (cdr left-result)) + (right-size (- n (+ left-size 1)))) + (let ((this-entry (car non-left-elts)) + (right-result (partial-tree (cdr non-left-elts) + right-size))) + (let ((right-tree (car right-result)) + (remaining-elts (cdr right-result))) + (cons (make-tree this-entry left-tree right-tree) + remaining-elts)))))))) + +;; a. Write a short paragraph explaining as clearly as you can how partial-tree works. Draw the tree produced by list->tree for the list (1 3 5 7 9 11). + +;; If we want a tree with 0 elements in it, we just return an empty tree (nil). Otherwise, we're going to build a tree by finding the middle element of a list rounded down (so if we had 6 elements, the middle element will be 3. If we have 7 elements, it will be 4). We then create a tree with the middle element as the entry of the tree and then call ourselves recursively to build the left-branch of the tree and the right-branch of the tree. We then return this tree along with any elements that have not been put into the tree. The reason we need the remaining elements is because it helps us quickly pass along all the elements of the list that go into the entry and right branch of the tree. + +;; b. What is the order of growth in the number of steps required by list->tree to convert a list of n elements? + +;; We call partial-tree O(n) times for a list of n elements (a bit more again because we also call it when n = 0). It looks like the order of growth is roughly O(n). + +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (cons-tree->list tree larger-items) + (if (null? tree) + larger-items + (cons-tree->list (left-branch tree) + (cons (entry tree) + (cons-tree->list (right-branch tree) + larger-items))))) + (cons-tree->list tree '())) blob - /dev/null blob + ecaf75569b62d79c7752ab7ebec1619b5e842f70 (mode 644) --- /dev/null +++ ex2-65.lisp @@ -0,0 +1,13 @@ +(defun union-set-bintree (set1 set2) + (let* ((lset1 (tree->list-1 set1)) + (lset2 (tree->list-1 set2)) + (lunion (union-set lset1 lset2)) + (union (list->tree lunion))) + union)) +(defun intersection-set-bintree (set1 set2) + (let* ((lset1 (tree->list-1 set1)) + (lset2 (tree->list-1 set2)) + (lintersect (intersection-set lset1 lset2)) + (intersect (list->tree lintersect))) + intersect)) + blob - /dev/null blob + 63ff6d5707449a6d620a0938de2364612dca38f8 (mode 644) --- /dev/null +++ ex2-65.lisp~ @@ -0,0 +1,2 @@ +(defun union-set-bintree (set1 set2) + (let* ((lset1 (tree->list-1 set1 blob - /dev/null blob + af81dd6ec266bc944ceb448e2017c4efefa81f2a (mode 644) --- /dev/null +++ ex2-65.scm @@ -0,0 +1,160 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) + +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) + +(define (list->tree elements) + (car (partial-tree elements (length elements)))) + +(define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let* ((left-size (quotient (- n 1) 2)) + (left-results (partial-tree elts left-size)) + (left-tree (car left-results)) + (right-size (- n (+ left-size 1))) + (right-result (partial-tree (cddr left-results) right-size)) + (right-tree (car right-result))) + (cons (make-tree (cadr left-results) + left-tree + right-tree) + (cdr right-result))))) + +(test-case (list->tree '()) '()) +(test-case (list->tree '(1)) '(1 () ())) +(test-case (list->tree '(1 2 3 4 5 6 7 8 9 10)) + '(5 (2 (1 () ()) (3 () (4 () ()))) (8 (6 () (7 () ())) (9 () (10 () ()))))) + + +;; Exercise 2.65. Use the results of exercises 2.63 and 2.64 to give O(n) implementations of union-set and intersection-set for sets implemented as (balanced) binary trees. + +(define (union-set set1 set2) + (define (union-set-list list1 list2) + (cond ((null? list1) list2) + ((null? list2) list1) + (else + (let ((l1 (car list1)) + (l2 (car list2))) + (cond ((= l1 l2) + (cons l1 (union-set-list (cdr list1) (cdr list2)))) + ((< l1 l2) + (cons l1 (union-set-list (cdr list1) list2))) + ((> l1 l2) + (cons l2 (union-set-list list1 (cdr list2))))))))) + (list->tree (union-set-list (tree->list-2 set1) + (tree->list-2 set2)))) + + +(test-case (union-set '() '()) '()) +(test-case (union-set (make-tree 5 '() '()) '()) '(5 () ())) +(test-case (union-set '() (make-tree 5 (make-tree 3 '() '()) (make-tree 7 '() '()))) '(5 (3 () ()) (7 () ()))) +(test-case + (union-set + (make-tree 3 + (make-tree 1 + (make-tree 0 '() '()) + (make-tree 2 '() '())) + (make-tree 5 + (make-tree 4 '() '()) + (make-tree 6 '() '()))) + (make-tree 1 + '() + (make-tree 3 + '() + (make-tree 5 + '() + (make-tree 7 + '() + (make-tree 9 + '() + '())))))) + '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ()))))) +(test-case + (union-set + '(3 (1 (0 () ()) + (2 () ())) + (5 (4 () ()) + (6 () ()))) + '(1 () (3 () (5 () (7 () (9 () ())))))) + '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ()))))) +(test-case + (union-set + '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ()))))))) + '(11 (4 (3 (2 () ()) ()) (9 () ())) (12 () (15 (14 (13 () ()) ()) ())))) + '(8 (3 (1 () (2 () ())) (5 (4 () ()) (7 () ()))) (12 (10 (9 () ()) (11 () ())) (14 (13 () ()) (15 () ()))))) + +(define (intersection-set set1 set2) + (define (intersection-list list1 list2) + (if (or (null? list1) + (null? list2)) + '() + (let ((l1 (car list1)) + (l2 (car list2))) + (cond ((= l1 l2) (cons l1 (intersection-list (cdr list1) (cdr list2)))) + ((< l1 l2) (intersection-list (cdr list1) list2)) + ((> l1 l2) (intersection-list list1 (cdr list2))))))) + (list->tree (intersection-list (tree->list-2 set1) + (tree->list-2 set2)))) + +(test-case (intersection-set '() '()) '()) +(test-case (intersection-set '(5 () ()) + '()) + '()) +(test-case (intersection-set '() + '(5 () ())) + '()) +(test-case (intersection-set + '(3 () ()) + '(5 (3 () ()) (7 () ()))) + '(3 () ())) +(test-case (intersection-set + '(3 (1 (0 () ()) (2 () ())) (5 (4 () ()) (6 () ()))) + '(1 () (3 () (5 () (7 () (9 () ())))))) + '(3 (1 () ()) (5 () ()))) +(test-case + (intersection-set + '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ()))))))) + '(11 (4 (3 (2 () ()) ()) (9 () ())) (12 () (15 (14 (13 () ()) ()) ())))) + '(4 (2 () (3 () ())) (12 (11 () ()) (14 () ())))) + blob - /dev/null blob + 7ac142753e517868aa45d4262b1babc4eff1fb56 (mode 644) --- /dev/null +++ ex2-65.scm~ @@ -0,0 +1,145 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) +(define (tree->list-1 tree) + (if (null? tree) + '() + (append (tree->list-1 (left-branch tree)) + (cons (entry tree) + (tree->list-1 (right-branch tree)))))) +(define (tree->list-2 tree) + (define (copy-to-list tree result-list) + (if (null? tree) + result-list + (copy-to-list (left-branch tree) + (cons (entry tree) + (copy-to-list (right-branch tree) + result-list))))) + (copy-to-list tree '())) + +(define (list->tree elements) + (car (partial-tree elements (length elements)))) + +(define (partial-tree elts n) + (if (= n 0) + (cons '() elts) + (let ((left-size (quotient (- n 1) 2))) + (let ((left-result (partial-tree elts left-size))) + (let ((left-tree (car left-result)) + (non-left-elts (cdr left-result)) + (right-size (- n (+ left-size 1)))) + (let ((this-entry (car non-left-elts)) + (right-result (partial-tree (cdr non-left-elts) + right-size))) + (let ((right-tree (car right-result)) + (remaining-elts (cdr right-result))) + (cons (make-tree this-entry left-tree right-tree) + remaining-elts)))))))) + +;; Exercise 2.65. Use the results of exercises 2.63 and 2.64 to give (n) implementations of union-set and intersection-set for sets implemented as (balanced) binary trees.41 + +(define (union-set set1 set2) + (define (union-set-list list1 list2) + (cond ((null? list1) list2) + ((null? list2) list1) + (else + (let ((l1 (car list1)) + (l2 (car list2))) + (cond ((= l1 l2) + (cons l1 (union-set-list (cdr list1) (cdr list2)))) + ((< l1 l2) + (cons l1 (union-set-list (cdr list1) list2))) + ((> l1 l2) + (cons l2 (union-set-list list1 (cdr list2))))))))) + (list->tree (union-set-list (tree->list-2 set1) + (tree->list-2 set2)))) + + +(test-case (union-set '() '()) '()) +(test-case (union-set (make-tree 5 '() '()) '()) '(5 () ())) +(test-case (union-set '() (make-tree 5 (make-tree 3 '() '()) (make-tree 7 '() '()))) '(5 (3 () ()) (7 () ()))) +(test-case + (union-set + (make-tree 3 + (make-tree 1 + (make-tree 0 '() '()) + (make-tree 2 '() '())) + (make-tree 5 + (make-tree 4 '() '()) + (make-tree 6 '() '()))) + (make-tree 1 + '() + (make-tree 3 + '() + (make-tree 5 + '() + (make-tree 7 + '() + (make-tree 9 + '() + '())))))) + '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ()))))) +(test-case + (union-set + (make-tree 3 + (make-tree 1 + (make-tree 0 '() '()) + (make-tree 2 '() '())) + (make-tree 5 + (make-tree 4 '() '()) + (make-tree 6 '() '()))) + (make-tree 1 + '() + (make-tree 3 + '() + (make-tree 5 + '() + (make-tree 7 + '() + (make-tree 9 + '() + '())))))) + '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ()))))) +(test-case + (union-set + '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ()))))))) + '(11 (4 (3 () (2 () ())) (9 () ())) (12 () (15 (14 (13 () ()) ()) ())))) + '(8 (3 (1 () (2 () ())) (5 (4 () ()) (7 () ()))) (12 (10 (9 () ()) (11 () ())) (14 (13 () ()) (15 () ()))))) + + (make-tree 0 '() '()) + (make-tree 2 '() '())) + (make-tree 5 + (make-tree 4 '() '()) + (make-tree 6 '() '()))) blob - /dev/null blob + 233892455ea8c7e73a767f3c068075b6084052f5 (mode 644) --- /dev/null +++ ex2-66.lisp @@ -0,0 +1,19 @@ +(defun lookup (given-key set) + (if (null? set) + nil + (let* ((cur-entry (entry set)) + (cur-key (key cur-entry))) + (cond ((= cur-key given-key) cur-entry) + ((< given-key cur-key) + (lookup given-key (left-branch set))) + ((> given-key cur-key) + (lookup + given-key + (right-branch set))))))) + +(defun make-record (key data) + (list key data)) +(defun key (record) + (car record)) +(defun data (record) + (cadr record)) blob - /dev/null blob + 085d11dc92663c04bbb8ea465eda928912b58180 (mode 644) --- /dev/null +++ ex2-66.lisp~ @@ -0,0 +1,12 @@ +(defun lookup (given-key set) + (if (null? set) + nil + (let* ((cur-entry (entry set)) + (cur-key (key cur-entry))) + (cond ((= cur-key given-key) cur-entry) + ((< given-key cur-key) + (lookup given-key (left-branch set))) + ((> given-key cur-key) + (lookup + given-key + (right-branch set))))))) blob - /dev/null blob + 6413db8b56bb66687dda878bc515a2e7d3a12af0 (mode 644) --- /dev/null +++ ex2-66.scm @@ -0,0 +1,39 @@ +(define (entry tree) (car tree)) +(define (left-branch tree) (cadr tree)) +(define (right-branch tree) (caddr tree)) +(define (make-tree entry left right) + (list entry left right)) + +(define (element-of-set? x set) + (cond ((null? set) #f) + ((= x (entry set)) #t) + ((< x (entry set)) + (element-of-set? x (left-branch set))) + ((> x (entry set)) + (element-of-set? x (right-branch set))))) + +(define (adjoin-set x set) + (cond ((null? set) (make-tree x '() '())) + ((= x (entry set)) set) + ((< x (entry set)) + (make-tree (entry set) + (adjoin-set x (left-branch set)) + (right-branch set))) + ((> x (entry set)) + (make-tree (entry set) + (left-branch set) + (adjoin-set x (right-branch set)))))) + +;; Exercise 2.66. Implement the lookup procedure for the case where the set of records is structured as a binary tree, ordered by the numerical values of the keys. + +(define (lookup given-key set-of-records) + (if (null? set-of-records) + #f + (let ((record (entry set-of-records)) + (record-key (key record))) + (cond ((= given-key record-key) + record) + ((< given-key record-key) + (lookup given-key (left-branch set-of-records))) + ((> given-key record-key) + (lookup given-key (right-branch set-of-records))))))) blob - /dev/null blob + ae6b838a5e2eda609237c090ad14234ebe310022 (mode 644) --- /dev/null +++ ex2-66.scm~ @@ -0,0 +1,3 @@ +(define (lookup given-key set-of-records) + (cond ((null? set-of-records) false) + ((equal? given blob - /dev/null blob + f2c9e7fe09bf94c3c8765eee73627527d94d27b8 (mode 644) --- /dev/null +++ ex2-67.scm @@ -0,0 +1,73 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +;; Exercise 2.67. Define an encoding tree and a sample message: + +(define sample-tree + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'D 1) + (make-leaf 'C 1))))) + +(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) +(test-case (decode sample-message sample-tree) '(A D A B B C A)) blob - /dev/null blob + 3b4dbc4053a4d3697b98a9b78c76b75b066e6ef4 (mode 644) --- /dev/null +++ ex2-67.scm~ @@ -0,0 +1,101 @@ +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits branch) + (cond ((if (and (null? bits) + (leaf? branch)) + (list (symbol-leaf branch)) + ;; ((null? branch) + ;; ("error: symbol not found")) + ((leaf? branch) + (cons (symbol-leaf branch) + (decode-1 (cdr bits) + (choose-branch (car bits) tree)))) + (else (decode-1 (cdr bits) + (choose-branch (car bits) branch))))) + (decode-1 bits tree)) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) blob - /dev/null blob + 735a5ad1d7320578e7dbdf5d670d0b7c80664846 (mode 644) --- /dev/null +++ ex2-68.lisp @@ -0,0 +1,76 @@ +(load "common") +(defun make-leaf (symbol weight) + (list 'leaf sym weight)) +(defun leaf? (obj) + (eq (car obj) 'leaf)) +(defun symbol-leaf (x) + (cadr x)) +(defun weight-leaf (x) + (caddr x)) +(defun make-code-tree (left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) +(defun left-branch (tree) + (car tree)) +(defun right-branch (tree) + (cadr tree)) +(defun symbols (tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(defun weight (tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) +(defun adjoin-set (x set) + "Add a new element _x_ into a set of elements, sorted by weight" + (cond ((null set) (list x)) + ((< (weight x) (weight (car set))) + (cons x set)) + (t (cons (car set) + (adjoin-set x (cdr set)))))) +(defun make-leaf-set (pairs) + (if (null pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) +(defun decode (bits tree) + (labels ((decode-1 (bits branch) + (if (null bits) + '() + (let ((next-branch (choose-branch (car bits) branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch)))))) + (decode-1 bits tree))) +(defun choose-branch (bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (t (error "bad bit -- CHOOSE-BRANCH ~A" bit)))) + +(defvar sample-tree + (make-code-tree + (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree + (make-leaf 'D 1) + (make-leaf 'C 2))))) +(defvar sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) + +(defun encode-symbol (sym tree) + (labels ((tree-walk (sym node encoding) + (if (leaf? node) + encoding + (cond + ((element-of-set? sym (symbols (left-branch node))) + (tree-walk sym (left-branch node) (cons 0 encoding))) + ((element-of-set? sym (symbols (right-branch node))) + (tree-walk sym (right-branch node) (cons 1 encoding))) + (t (error "Symbol not in tree -- ~A" sym)))))) + (reverse (tree-walk sym tree '())))) blob - /dev/null blob + 9962c9b410a9096b91ba49613dc2b90444863551 (mode 644) --- /dev/null +++ ex2-68.lisp~ @@ -0,0 +1,33 @@ +(load "common") +(defun make-leaf (symbol weight) + (list 'leaf sym weight)) +(defun leaf? (obj) + (eq (car obj) 'leaf)) +(defun symbol-leaf (x) + (cadr x)) +(defun weight-leaf (x) + (caddr x)) +(defun make-code-tree (left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) +(defun left-branch (tree) + (car tree)) +(defun right-branch (tree) + (cadr tree)) +(defun symbols (tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(defun weight (tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) +(defun adjoin-set (x set) + "Add a new element _x_ into a set of elements, sorted by weight" + (cond ((null set) (list x)) + ((< (weight x) (weight (car set))) + (cons x set)) + (t (cons (car set) + (adjoin-set x (cdr set)))))) blob - /dev/null blob + 8ae8fea1e82f219528c65eb5853fb3e1ba94a495 (mode 644) --- /dev/null +++ ex2-68.scm @@ -0,0 +1,124 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +;; Exercise 2.68. The encode procedure takes as arguments a message and a tree and produces the list of bits that gives the encoded message. + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +;; (test-case (element-of-set 'A '()) #f) +;; (test-case (element-of-set 'A '(1 B C D)) #f) +;; (test-case (element-of-set 'A '(1 A B C)) #t) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +;; (define (encode-symbol sym tree) +;; (cond ((null? tree) (error "empty tree")) +;; ((leaf? tree) '()) +;; ((element-of-set sym (symbols (left-branch tree))) +;; (cons 0 (encode-symbol sym (left-branch tree)))) +;; ((element-of-set sym (symbols (right-branch tree))) +;; (cons 1 (encode-symbol sym (right-branch tree)))) +;; (else (error "symbol not in tree"))))) + +;; Encode-symbol is a procedure, which you must write, that returns the list of bits that encodes a given symbol according to a given tree. You should design encode-symbol so that it signals an error if the symbol is not in the tree at all. Test your procedure by encoding the result you obtained in exercise 2.67 with the sample tree and seeing whether it is the same as the original sample message. + +(define sample-tree + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'D 1) + (make-leaf 'C 1))))) +(define sample-tree-2 + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'E 1) + (make-leaf 'C 1))))) + +(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) +(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0)) +(define sample-symbols '(A D A B B C A)) +(define sample-symbols-2 '(E C B A B E E A B B A A C A)) +(test-case (decode sample-message sample-tree) sample-symbols) + +(test-case (encode (decode sample-message sample-tree) sample-tree) sample-message) +;; (test-case (encode sample-symbols '()) "error: empty tree") +;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree") +(test-case (encode sample-symbols-2 sample-tree-2) sample-message-2) +(test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2) blob - /dev/null blob + f2c9e7fe09bf94c3c8765eee73627527d94d27b8 (mode 644) --- /dev/null +++ ex2-68.scm~ @@ -0,0 +1,73 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +;; Exercise 2.67. Define an encoding tree and a sample message: + +(define sample-tree + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'D 1) + (make-leaf 'C 1))))) + +(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) +(test-case (decode sample-message sample-tree) '(A D A B B C A)) blob - /dev/null blob + 05c25f89087f2829d45747139bb342a1cedb973b (mode 644) --- /dev/null +++ ex2-69.lisp @@ -0,0 +1,9 @@ +(defun generate-huffman-tree (pairs) + (successive-merge (make-leaf-set pairs))) +(defun successive-merge (node-set) + (if (null (cadr node-set)) + (car node-set) + (successive-merge + (adjoin-set (make-code-tree (car node-set) + (cadr node-set)) + (cddr node-set))))) blob - /dev/null blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644) blob - /dev/null blob + 179fc78f1abdb3aed52fc45f412afdf863975fff (mode 644) --- /dev/null +++ ex2-69.scm @@ -0,0 +1,180 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +(define sample-tree + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'D 1) + (make-leaf 'C 1))))) +(define sample-tree-2 + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'E 1) + (make-leaf 'C 1))))) + +(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) +(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0)) +(define sample-symbols '(A D A B B C A)) +(define sample-symbols-2 '(E C B A B E E A B B A A C A)) + +;; (test-case (decode sample-message sample-tree) sample-symbols) +;; (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message) +;; ;; (test-case (encode sample-symbols '()) "error: empty tree") +;; ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree") +;; (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2) +;; (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2) + +;; Exercise 2.69. The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm. + +(define (generate-huffman-tree pairs) + (successive-merge (make-leaf-set pairs))) + +;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.) + +(define (successive-merge leaf-set) + (cond ((null? leaf-set) (error "no leaves in leaf-set")) + ((null? (cdr leaf-set)) (car leaf-set)) + (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) + (car leaf-set)) + (cddr leaf-set)))))) + + +;; (test-case (generate-huffman-tree '()) "no leaves in leaf-set") +(test-case (generate-huffman-tree '((A 8))) '(leaf A 8)) +(test-case (generate-huffman-tree '((A 8) (B 3))) '((leaf A 8) (leaf B 3) (A B) 11)) ;; we'll put the element that appears later in the set of leaves on the left side of the tree by default +(test-case (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1))) + '((((leaf B 3) + ((leaf C 1) (leaf D 1) (C D) 2) + (B C D) + 5) + (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) + (B C D E F G H) + 9) + (leaf A 8) + (B C D E F G H A) + 17)) + +;; ((leaf H 1) (leaf G 1) (leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) (leaf B 3) (leaf A 8)) +;; ((leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) (leaf B 3) (leaf A 8)) +;; ((leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) (leaf B 3) (leaf A 8)) +;; (((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) ((leaf C 1) (leaf D 1) (C D) 2) (leaf B 3) (leaf A 8)) +;; (((leaf C 1) (leaf D 1) (C D) 2) +;; (leaf B 3) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (leaf A 8)) +;; ((((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; ((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (leaf A 8)) +;; ((leaf A 8) +;; (((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (B C D E F G H) +;; 9)) +;; (((((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (B C D E F G H) +;; 9) +;; (leaf A 8) +;; (B C D E F G H A) +;; 17)) +;; ((((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (B C D E F G H) +;; 9) +;; (leaf A 8) +;; (B C D E F G H A) +;; 17) blob - /dev/null blob + 7fc3e34bc39bc6f0b6f645a0342f2339f581d147 (mode 644) --- /dev/null +++ ex2-69.scm~ @@ -0,0 +1,131 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +;; Exercise 2.68. The encode procedure takes as arguments a message and a tree and produces the list of bits that gives the encoded message. + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +;; (test-case (element-of-set 'A '()) #f) +;; (test-case (element-of-set 'A '(1 B C D)) #f) +;; (test-case (element-of-set 'A '(1 A B C)) #t) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +;; (define (encode-symbol sym tree) +;; (cond ((null? tree) (error "empty tree")) +;; ((leaf? tree) '()) +;; ((element-of-set sym (symbols (left-branch tree))) +;; (cons 0 (encode-symbol sym (left-branch tree)))) +;; ((element-of-set sym (symbols (right-branch tree))) +;; (cons 1 (encode-symbol sym (right-branch tree)))) +;; (else (error "symbol not in tree"))))) + +;; Encode-symbol is a procedure, which you must write, that returns the list of bits that encodes a given symbol according to a given tree. You should design encode-symbol so that it signals an error if the symbol is not in the tree at all. Test your procedure by encoding the result you obtained in exercise 2.67 with the sample tree and seeing whether it is the same as the original sample message. + +(define sample-tree + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'D 1) + (make-leaf 'C 1))))) +(define sample-tree-2 + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'E 1) + (make-leaf 'C 1))))) + +(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) +(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0)) +(define sample-symbols '(A D A B B C A)) +(define sample-symbols-2 '(E C B A B E E A B B A A C A)) +(test-case (decode sample-message sample-tree) sample-symbols) + +(test-case (encode (decode sample-message sample-tree) sample-tree) sample-message) +;; (test-case (encode sample-symbols '()) "error: empty tree") +;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree") +(test-case (encode sample-symbols-2 sample-tree-2) sample-message-2) +(test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2) + +;; Exercise 2.69. The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm. + +(define (generate-huffman-tree pairs) + (successive-merge (make-leaf-set pairs))) + +;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.) blob - /dev/null blob + 55f82533de4af68dba5fb302180c789ae30ca9d8 (mode 644) --- /dev/null +++ ex2-7.scm @@ -0,0 +1,24 @@ +(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 a b) + (cons a b)) +(define (upper-bound x) + (cdr x)) +(define (lower-bound x) + (car x)) + + blob - /dev/null blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644) blob - /dev/null blob + d6198b67d62944a5e5434ab08cc57064aec77cea (mode 644) --- /dev/null +++ ex2-70.scm @@ -0,0 +1,148 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +(define (generate-huffman-tree pairs) + (successive-merge (make-leaf-set pairs))) + +(define (successive-merge leaf-set) + (cond ((null? leaf-set) (error "no leaves in leaf-set")) + ((null? (cdr leaf-set)) (car leaf-set)) + (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) + (car leaf-set)) + (cddr leaf-set)))))) + +;; Exercise 2.70. The following eight-symbol alphabet with associated relative frequencies was designed to efficiently encode the lyrics of 1950s rock songs. (Note that the ``symbols'' of an ``alphabet'' need not be individual letters.) + +;; A 2 NA 16 +;; BOOM 1 SHA 3 +;; GET 2 YIP 9 +;; JOB 2 WAH 1 +;; Use generate-huffman-tree (exercise 2.69) to generate a corresponding Huffman tree, and use encode (exercise 2.68) to encode the following message: + +(test-case (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))) + '((((((leaf get 2) (leaf job 2) (get job) 4) + (leaf sha 3) + (get job sha) + 7) + (((leaf boom 1) (leaf wah 1) (boom wah) 2) + (leaf a 2) + (boom wah a) + 4) + (get job sha boom wah a) + 11) + (leaf yip 9) + (get job sha boom wah a yip) + 20) + (leaf na 16) + (get job sha boom wah a yip na) + 36)) +(test-case (encode '(get a job sha na na na na na na na na get a job sha na na na na na na na na wah yip yip yip yip yip yip yip yip yip sha boom) + (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))) + '(0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 0 0 1 0 0 1 0 0)) + +;; GET 00000 +;; JOB 00001 +;; SHA 0001 +;; BOOM 00100 +;; WAH 00101 +;; A 0011 +;; YIP 01 +;; NA 1 + +;; Get a job + +;; Sha na na na na na na na na + +;; Get a job + +;; Sha na na na na na na na na + +;; Wah yip yip yip yip yip yip yip yip yip + +;; Sha boom + +;; How many bits are required for the encoding? What is the smallest number of bits that would be needed to encode this song if we used a fixed-length code for the eight-symbol alphabet? + +;; 5 bits are required at most for encoding a symbol, which is actually 2 bits more than fixed-length code + +;; Overall, though, only 84 bits are required using Huffman encoding vs. 108 bits for fixed-length code blob - /dev/null blob + 179fc78f1abdb3aed52fc45f412afdf863975fff (mode 644) --- /dev/null +++ ex2-70.scm~ @@ -0,0 +1,180 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +(define sample-tree + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'D 1) + (make-leaf 'C 1))))) +(define sample-tree-2 + (make-code-tree (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree (make-leaf 'E 1) + (make-leaf 'C 1))))) + +(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) +(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0)) +(define sample-symbols '(A D A B B C A)) +(define sample-symbols-2 '(E C B A B E E A B B A A C A)) + +;; (test-case (decode sample-message sample-tree) sample-symbols) +;; (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message) +;; ;; (test-case (encode sample-symbols '()) "error: empty tree") +;; ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree") +;; (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2) +;; (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2) + +;; Exercise 2.69. The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm. + +(define (generate-huffman-tree pairs) + (successive-merge (make-leaf-set pairs))) + +;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.) + +(define (successive-merge leaf-set) + (cond ((null? leaf-set) (error "no leaves in leaf-set")) + ((null? (cdr leaf-set)) (car leaf-set)) + (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) + (car leaf-set)) + (cddr leaf-set)))))) + + +;; (test-case (generate-huffman-tree '()) "no leaves in leaf-set") +(test-case (generate-huffman-tree '((A 8))) '(leaf A 8)) +(test-case (generate-huffman-tree '((A 8) (B 3))) '((leaf A 8) (leaf B 3) (A B) 11)) ;; we'll put the element that appears later in the set of leaves on the left side of the tree by default +(test-case (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1))) + '((((leaf B 3) + ((leaf C 1) (leaf D 1) (C D) 2) + (B C D) + 5) + (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) + (B C D E F G H) + 9) + (leaf A 8) + (B C D E F G H A) + 17)) + +;; ((leaf H 1) (leaf G 1) (leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) (leaf B 3) (leaf A 8)) +;; ((leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) (leaf B 3) (leaf A 8)) +;; ((leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) (leaf B 3) (leaf A 8)) +;; (((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) ((leaf C 1) (leaf D 1) (C D) 2) (leaf B 3) (leaf A 8)) +;; (((leaf C 1) (leaf D 1) (C D) 2) +;; (leaf B 3) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (leaf A 8)) +;; ((((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; ((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (leaf A 8)) +;; ((leaf A 8) +;; (((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (B C D E F G H) +;; 9)) +;; (((((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (B C D E F G H) +;; 9) +;; (leaf A 8) +;; (B C D E F G H A) +;; 17)) +;; ((((leaf B 3) +;; ((leaf C 1) (leaf D 1) (C D) 2) +;; (B C D) +;; 5) +;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4) +;; (B C D E F G H) +;; 9) +;; (leaf A 8) +;; (B C D E F G H A) +;; 17) blob - /dev/null blob + 517a3563a76b63ceb91a3e35e2f83ab912854df8 (mode 644) Binary files /dev/null and ex2-70.xcf differ blob - /dev/null blob + 58310bd1611ab3c2b8080f13bc330fbacc94fb1f (mode 644) --- /dev/null +++ ex2-71.scm @@ -0,0 +1,132 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +(define (generate-huffman-tree pairs) + (successive-merge (make-leaf-set pairs))) + +(define (successive-merge leaf-set) + (cond ((null? leaf-set) (error "no leaves in leaf-set")) + ((null? (cdr leaf-set)) (car leaf-set)) + (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) + (car leaf-set)) + (cddr leaf-set)))))) + +;; Exercise 2.71. Suppose we have a Huffman tree for an alphabet of n symbols, and that the relative frequencies of the symbols are 1, 2, 4, ..., 2^n-1. Sketch the tree for n=5; for n=10. In such a tree (for general n) how many bits are required to encode the most frequent symbol? the least frequent symbol? + +;; for a tree of n symbols, 1 bit for most frequent; n-1 bits for least frequent symbol + +;; Exercise 2.72. Consider the encoding procedure that you designed in exercise 2.68. What is the order of growth in the number of steps needed to encode a symbol? Be sure to include the number of steps needed to search the symbol list at each node encountered. To answer this question in general is difficult. Consider the special case where the relative frequencies of the n symbols are as described in exercise 2.71, and give the order of growth (as a function of n) of the number of steps needed to encode the most frequent and least frequent symbols in the alphabet. + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) +;; we're going to pretend this isn't here to speed up the procedure +;; ((not (element-of-set sym (symbols tree))) +;; (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +we must call encode-symbol the same number of times as the length of message +So, if message is m elements long, we must call encode-symbol m times + +Within encode-symbol, we must check through the list of symbols either on the left-branch or on the right-branch. If the symbol is on the left-branch, we just check 1 element. Otherwise, we must check, on average, (n-1)/2 elements. There is roughly a 50-50 chance that the symbol will be on the left-branch vs. right-branch. + +50%: 1 +25%: (n-1)/2 + 1 +12.5%: (n-1)/2 + (n-2)/2 + 1 +6.25%: ... + +Most frequent symbols O(1), but least-frequent symbol is O(n^2) blob - /dev/null blob + d6198b67d62944a5e5434ab08cc57064aec77cea (mode 644) --- /dev/null +++ ex2-71.scm~ @@ -0,0 +1,148 @@ +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(define (make-leaf symbol weight) + (list 'leaf symbol weight)) +(define (leaf? object) + (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) + +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (left-branch tree) (car tree)) +(define (right-branch tree) (cadr tree)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + +(define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch + (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit -- CHOOSE-BRANCH" bit)))) + +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +(define (encode message tree) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +(define (element-of-set x set) + (and (not (null? set)) + (or (equal? x (car set)) + (element-of-set x (cdr set))))) + +(define (encode-symbol sym tree) + (cond ((null? tree) (error "empty tree")) + ((not (element-of-set sym (symbols tree))) + (error "symbol not in tree")) + ((leaf? tree) '()) + ((element-of-set sym (symbols (left-branch tree))) + (cons 0 (encode-symbol sym (left-branch tree)))) + ((element-of-set sym (symbols (right-branch tree))) + (cons 1 (encode-symbol sym (right-branch tree)))))) + +(define (generate-huffman-tree pairs) + (successive-merge (make-leaf-set pairs))) + +(define (successive-merge leaf-set) + (cond ((null? leaf-set) (error "no leaves in leaf-set")) + ((null? (cdr leaf-set)) (car leaf-set)) + (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) + (car leaf-set)) + (cddr leaf-set)))))) + +;; Exercise 2.70. The following eight-symbol alphabet with associated relative frequencies was designed to efficiently encode the lyrics of 1950s rock songs. (Note that the ``symbols'' of an ``alphabet'' need not be individual letters.) + +;; A 2 NA 16 +;; BOOM 1 SHA 3 +;; GET 2 YIP 9 +;; JOB 2 WAH 1 +;; Use generate-huffman-tree (exercise 2.69) to generate a corresponding Huffman tree, and use encode (exercise 2.68) to encode the following message: + +(test-case (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))) + '((((((leaf get 2) (leaf job 2) (get job) 4) + (leaf sha 3) + (get job sha) + 7) + (((leaf boom 1) (leaf wah 1) (boom wah) 2) + (leaf a 2) + (boom wah a) + 4) + (get job sha boom wah a) + 11) + (leaf yip 9) + (get job sha boom wah a yip) + 20) + (leaf na 16) + (get job sha boom wah a yip na) + 36)) +(test-case (encode '(get a job sha na na na na na na na na get a job sha na na na na na na na na wah yip yip yip yip yip yip yip yip yip sha boom) + (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))) + '(0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 0 0 1 0 0 1 0 0)) + +;; GET 00000 +;; JOB 00001 +;; SHA 0001 +;; BOOM 00100 +;; WAH 00101 +;; A 0011 +;; YIP 01 +;; NA 1 + +;; Get a job + +;; Sha na na na na na na na na + +;; Get a job + +;; Sha na na na na na na na na + +;; Wah yip yip yip yip yip yip yip yip yip + +;; Sha boom + +;; How many bits are required for the encoding? What is the smallest number of bits that would be needed to encode this song if we used a fixed-length code for the eight-symbol alphabet? + +;; 5 bits are required at most for encoding a symbol, which is actually 2 bits more than fixed-length code + +;; Overall, though, only 84 bits are required using Huffman encoding vs. 108 bits for fixed-length code blob - /dev/null blob + e16d18f7ae8ac32627e2060a190d82fcb92d5938 (mode 644) Binary files /dev/null and ex2-71.xcf differ blob - /dev/null blob + 773308096879f19fc97fe1dca85048e7a77f8467 (mode 644) --- /dev/null +++ ex2-73-sol-2.scm @@ -0,0 +1,38 @@ +(define *op-table* (make-has-table 'equal)) +(define (put op type proc) + (hash-table-put! *op-table* (list op type) proc)) +(define (get op type) + (hash-table-get *op-table* (list op type) '())) + +(define (install-deriv-package) + (define (make-sum a1 a2) (list '+ a1 a2)) + (define (addend s) (car s)) + (define (augend s) (cadr s)) + (define (make-product m1 m2) (list '* m1 m2)) + (define (multiplier p) (car p)) + (define (multiplicand p) (cadr p)) + (define (deriv-sum exp var) + (make-sum (deriv (addend exp) var) + (deriv (augend exp) var))) + (define (deriv-product exp var) + (make-sum + (make-product (multiplier exp) + (deriv (multiplicand exp) var)) + (make-product (deriv (multiplier exp) var) + (multiplicand exp)))) + (define (make-exponentiation base exp) + (list '** base exp)) + (define (base s) (car s)) + (define (exponent s) (cadr s)) + (define (deriv-exponentiation exp var) + (make-product + (make-product + (exponent exp) + (make-exponentiation + (base exp) + (- (exponent exp) 1))) + (deriv (base exp) var))) + (put 'deriv '** deriv-exponentiation) + (put 'deriv '+ deriv-sum) + (put 'deriv '* deriv-product)) + blob - /dev/null blob + a47af84e01db32d502eae178483fd19f1ff8f14d (mode 644) --- /dev/null +++ ex2-73-sol-2.scm~ @@ -0,0 +1,5 @@ +(define *op-table* (make-has-table 'equal)) +(define (put op type proc) + (hash-table-put! *op-table* (list op type) proc)) +(define (get op type) + (hash-table-get *op-table* (list op type) '())) blob - /dev/null blob + 324b43b4083e918382c907e48fec4bd8e4bbf50e (mode 644) --- /dev/null +++ ex2-73-sol.scm @@ -0,0 +1,146 @@ +(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 (deriv exp var) + (cond ((number? exp) 0) + ((variable? exp) (if (same-variable? exp var) 1 0)) + (else ((get 'deriv (operator exp)) (operands exp) var)))) +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) + +#lang racket +(require rnrs/base-6) +(require rnrs/mutable-pairs-6) + +(define (assoc key records) + (cond ((null? records) #f) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) +(define (make-table) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + #f)) + #f))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (deriv exp var) + ((get 'deriv (operator exp)) (operands exp) var)) +(define (operator exp) + (cond ((number? exp) 'number) + ((variable? exp) 'variable) + (else (car exp)))) +(define (operands exp) + (if (pair? exp) + (cdr exp) + (list exp))) +(define (install-number-routines) + (define (derivative ops var) 0) + (put 'deriv 'number derivative)) +(define (install-variable-routines) + (define (derivative ops var) + (if (same-variable? (car ops) var) 1 0)) + (put 'deriv 'variable derivative)) +(install-number-routines) +(install-variable-routines) + +(define (install-sum-routines) + (define (derivative ops var) + (make-sum + (deriv (car ops) var) + (deriv (cadr ops) var))) + (put 'deriv '+ derivative)) +(define (install-product-routines) + (define (derivative ops var) + (make-sum + (make-product (car ops) + (deriv (cadr ops) var)) + (make-product (deriv (car ops) var) + (cadr ops)))) + (put 'deriv '* derivative)) +(install-sum-routines) +(install-product-routines) + +((exponentiation? exp) + (make-product + (make-product (exponent exp) + (make-exponentiation (base exp) + (make-sum (exponent exp) -1))) + (deriv (base exp) var))) + +(define (install-exponent-routines) + (define (derivative ops var) + (make-product + (make-product (cadr ops) + (make-exponentiation (car ops) + (make-sum (cadr ops) -1))) + (deriv (car ops) var))) + (put 'deriv '** derivative)) + +((get (operator exp) 'deriv) (operands exp) var) + +(define (install-derivative-routines) + (define (sum ops var) + (make-sum + (deriv (car ops) var) + (deriv (cadr ops) var))) + (define (product ops var) + (make-sum + (make-product (car ops) + (deriv (cadr ops) var)) + (make-product (deriv (car ops) var) + (cadr ops)))) + (define (exponent ops var) + (make-product + (make-product (cadr ops) + (make-exponentiation (car ops) + (make-sum (cadr ops) -1))) + (deriv (car ops) var))) + (put '+ 'deriv sum) + (put '* 'deriv product) + (put '** 'deriv exponent)) + + +;; weiquan + +(define (install-deriv-package) + (define (=number? exp num) + (and (number? exp) (= exp num))) +(define (make-sum a1 a2) + (cond ((=number? a1 0) a2 blob - /dev/null blob + e7d79045817d1238cdd7f267260af4bb9a4a7bae (mode 644) --- /dev/null +++ ex2-73-sol.scm~ @@ -0,0 +1,138 @@ +(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 (deriv exp var) + (cond ((number? exp) 0) + ((variable? exp) (if (same-variable? exp var) 1 0)) + (else ((get 'deriv (operator exp)) (operands exp) var)))) +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) + +#lang racket +(require rnrs/base-6) +(require rnrs/mutable-pairs-6) + +(define (assoc key records) + (cond ((null? records) #f) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) +(define (make-table) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + #f)) + #f))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (deriv exp var) + ((get 'deriv (operator exp)) (operands exp) var)) +(define (operator exp) + (cond ((number? exp) 'number) + ((variable? exp) 'variable) + (else (car exp)))) +(define (operands exp) + (if (pair? exp) + (cdr exp) + (list exp))) +(define (install-number-routines) + (define (derivative ops var) 0) + (put 'deriv 'number derivative)) +(define (install-variable-routines) + (define (derivative ops var) + (if (same-variable? (car ops) var) 1 0)) + (put 'deriv 'variable derivative)) +(install-number-routines) +(install-variable-routines) + +(define (install-sum-routines) + (define (derivative ops var) + (make-sum + (deriv (car ops) var) + (deriv (cadr ops) var))) + (put 'deriv '+ derivative)) +(define (install-product-routines) + (define (derivative ops var) + (make-sum + (make-product (car ops) + (deriv (cadr ops) var)) + (make-product (deriv (car ops) var) + (cadr ops)))) + (put 'deriv '* derivative)) +(install-sum-routines) +(install-product-routines) + +((exponentiation? exp) + (make-product + (make-product (exponent exp) + (make-exponentiation (base exp) + (make-sum (exponent exp) -1))) + (deriv (base exp) var))) + +(define (install-exponent-routines) + (define (derivative ops var) + (make-product + (make-product (cadr ops) + (make-exponentiation (car ops) + (make-sum (cadr ops) -1))) + (deriv (car ops) var))) + (put 'deriv '** derivative)) + +((get (operator exp) 'deriv) (operands exp) var) + +(define (install-derivative-routines) + (define (sum ops var) + (make-sum + (deriv (car ops) var) + (deriv (cadr ops) var))) + (define (product ops var) + (make-sum + (make-product (car ops) + (deriv (cadr ops) var)) + (make-product (deriv (car ops) var) + (cadr ops)))) + (define (exponent ops var) + (make-product + (make-product (cadr ops) + (make-exponentiation (car ops) + (make-sum (cadr ops) -1))) + (deriv (car ops) var))) + (put '+ 'deriv sum) + (put '* 'deriv product) + (put '** 'deriv exponent)) + blob - /dev/null blob + 0406d9f0430c2e8b8bf2806fbc6bb76a2e9ea757 (mode 644) --- /dev/null +++ ex2-73.lisp~ @@ -0,0 +1,3 @@ +(define *op-table* (make-has-table 'equal)) +(define (put op type proc) + (hash-table-put! *op-table* (list op type) proc)) blob - /dev/null blob + c0f93065dc48a7f9a5145bbb4260dfcad74556c9 (mode 644) --- /dev/null +++ ex2-73.scm @@ -0,0 +1,165 @@ +(define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) +(define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) +(define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) +(define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum -- CONTENTS" datum))) +(define (rectangular? z) + (eq? (type-tag z) 'rectangular)) +(define (polar? z) + (eq? (type-tag z) 'polar)) + +(define (install-rectangular-package) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (make-from-real-imag x y) + (cons x y)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) + (atan (imag-part z) (real-part z))) + (define (make-from-mag-ang r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polar-package) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (make-from-mag-ang r a) (cons r a)) + (define (real-part z) + (* (magnitude z) (cos (angle z)))) + (define (imag-part z) + (* (magnitude z) (sin (angle z)))) + (define (make-from-real-imag x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (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 (real-part z) (apply-generic 'real-part z)) +(define (imag-part z) (apply-generic 'imag-part z)) +(define (magnitude z) (apply-generic 'magnitude z)) +(define (angle z) (apply-generic 'angle z)) +(define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) +(define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + +;; We can regard this program as performing a dispatch on the type of the expression to be differentiated. In this situation the ``type tag'' of the datum is the algebraic operator symbol (such as +) and the operation being performed is deriv. We can transform this program into data-directed style by rewriting the basic derivative procedure as + +(define (deriv exp var) + (cond ((number? exp) 0) + ((variable? exp) (if (same-variable? exp var) 1 0)) + (else ((get 'deriv (operator exp)) (operands exp) + var)))) +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) + +;; a. Explain what was done above. Why can't we assimilate the predicates number? and same-variable? into the data-directed dispatch? + +;; If exp is a number, we return 0. If it is a variable and we are taking the derivative with respect the same variable, we return 1 (otherwise we return 0). Otherwise, we go to the operation-and-type table and look up the procedure with operation name 'deriv and data type with the same operator. We then apply this procedure on the operands of the expression (passed as a list) and the variable. + +;; We cannot assimilate the predicates because there are no operators for simple numbers and variables. These expressions are not lists. + +;; b. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above. + +(define (first-operand operands) + (car operands)) +(define (rest-operands operands) + (cdr operands)) +(define (deriv-sum operands var) + (make-sum (deriv (first-operand operands) var) + (deriv (rest-operands operands) var))) +(define (deriv-product operands var) + (make-sum + (make-product (first-operand operands) + (deriv (rest-operands operands) var)) + (make-product (deriv (first-operand operands) var) + (rest-operands operands)))) +(put 'deriv '+ deriv-sum) +(put 'deriv '* deriv-product) + +;; c. Choose any additional differentiation rule that you like, such as the one for exponents (exercise 2.56), and install it in this data-directed system. + +(define (exponentiation? exp) + (and (pair? exp) (eq? (car exp) '**))) +(define (base exp) + (cadr exp)) +(define (exponent exp) + (caddr exp)) +(define (=number? x num) + (and (number? x) (= x num))) +(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)))) + +(define (deriv-exp operands var) + (car operands) (cadr operands)...) + +(put 'deriv '** deriv-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))) + + +(define (deriv-exp) + +d. In this simple algebraic manipulator the type of an expression is the algebraic operator that binds it together. Suppose, however, we indexed the procedures in the opposite way, so that the dispatch line in deriv looked like + +((get (operator exp) 'deriv) (operands exp) var) + +What corresponding changes to the derivative system are required? blob - /dev/null blob + a5bf19b7d92ae76be916400631a76e4f2b351fe4 (mode 644) --- /dev/null +++ ex2-73.scm~ @@ -0,0 +1,171 @@ +(define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) +(define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) +(define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) +(define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum -- CONTENTS" datum))) +(define (rectangular? z) + (eq? (type-tag z) 'rectangular)) +(define (polar? z) + (eq? (type-tag z) 'polar)) + +(define (install-rectangular-package) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (make-from-real-imag x y) + (cons x y)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) + (atan (imag-part z) (real-part z))) + (define (make-from-mag-ang r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polar-package) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (make-from-mag-ang r a) (cons r a)) + (define (real-part z) + (* (magnitude z) (cos (angle z)))) + (define (imag-part z) + (* (magnitude z) (sin (angle z)))) + (define (make-from-real-imag x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (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 (real-part z) (apply-generic 'real-part z)) +(define (imag-part z) (apply-generic 'imag-part z)) +(define (magnitude z) (apply-generic 'magnitude z)) +(define (angle z) (apply-generic 'angle z)) +(define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) +(define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + +(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)))) + +;; We can regard this program as performing a dispatch on the type of the expression to be differentiated. In this situation the ``type tag'' of the datum is the algebraic operator symbol (such as +) and the operation being performed is deriv. We can transform this program into data-directed style by rewriting the basic derivative procedure as + +(define (deriv exp var) + (cond ((number? exp) 0) + ((variable? exp) (if (same-variable? exp var) 1 0)) + (else ((get 'deriv (operator exp)) (operands exp) + var)))) +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) + +;; a. Explain what was done above. Why can't we assimilate the predicates number? and same-variable? into the data-directed dispatch? + +;; If exp is a number, we return 0. If it is a variable and we are taking the derivative with respect the same variable, we return 1 (otherwise we return 0). Otherwise, we go to the operation-and-type table and look up the procedure with operation name 'deriv and data type with the same operator. We then apply this procedure on the operands of the expression (passed as a list) and the variable. + +;; We cannot assimilate the predicates because there are no operators for simple numbers and variables. These expressions are not lists. + +;; b. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above. + +(define (first-operand operands) + (car operands)) +(define (rest-operands operands) + (cdr operands)) +(define (deriv-sum operands var) + (make-sum (deriv (first-operand operands) var) + (deriv (rest-operands operands) var))) +(define (deriv-product operands var) + (make-sum + (make-product (first-operand operands) + (deriv (rest-operands operands) var)) + (make-product (deriv (first-operand operands) var) + (rest-operands operands)))) +(put 'deriv '+ deriv-sum) +(put 'deriv '* deriv-product) + +;; c. Choose any additional differentiation rule that you like, such as the one for exponents (exercise 2.56), and install it in this data-directed system. + +(define (exponentiation? exp) + (and (pair? exp) (eq? (car exp) '**))) +(define (base exp) + (cadr exp)) +(define (exponent exp) + (caddr 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))) +(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)))) + +(define (deriv-exp) + +d. In this simple algebraic manipulator the type of an expression is the algebraic operator that binds it together. Suppose, however, we indexed the procedures in the opposite way, so that the dispatch line in deriv looked like + +((get (operator exp) 'deriv) (operands exp) var) + +What corresponding changes to the derivative system are required? blob - /dev/null blob + 081cd536b12f2b25328c344a72c0f81409b4cd9c (mode 644) --- /dev/null +++ ex2-73b.scm @@ -0,0 +1,160 @@ +(define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) +(define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) +(define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) +(define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum -- CONTENTS" datum))) +(define (rectangular? z) + (eq? (type-tag z) 'rectangular)) +(define (polar? z) + (eq? (type-tag z) 'polar)) + +(define (install-rectangular-package) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (make-from-real-imag x y) + (cons x y)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) + (atan (imag-part z) (real-part z))) + (define (make-from-mag-ang r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polar-package) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (make-from-mag-ang r a) (cons r a)) + (define (real-part z) + (* (magnitude z) (cos (angle z)))) + (define (imag-part z) + (* (magnitude z) (sin (angle z)))) + (define (make-from-real-imag x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (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 (real-part z) (apply-generic 'real-part z)) +(define (imag-part z) (apply-generic 'imag-part z)) +(define (magnitude z) (apply-generic 'magnitude z)) +(define (angle z) (apply-generic 'angle z)) +(define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) +(define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + +;; We can regard this program as performing a dispatch on the type of the expression to be differentiated. In this situation the ``type tag'' of the datum is the algebraic operator symbol (such as +) and the operation being performed is deriv. We can transform this program into data-directed style by rewriting the basic derivative procedure as + +(define (deriv exp var) + (cond ((number? exp) 0) + ((variable? exp) (if (same-variable? exp var) 1 0)) + (else ((get 'deriv (operator exp)) (operands exp) + var)))) +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) + +;; a. Explain what was done above. Why can't we assimilate the predicates number? and same-variable? into the data-directed dispatch? + +;; If exp is a number, we return 0. If it is a variable and we are taking the derivative with respect the same variable, we return 1 (otherwise we return 0). Otherwise, we go to the operation-and-type table and look up the procedure with operation name 'deriv and data type with the same operator. We then apply this procedure on the operands of the expression (passed as a list) and the variable. + +;; We cannot assimilate the predicates because there are no operators for simple numbers and variables. These expressions are not lists. + +;; b. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above. + +(define (deriv-sum operands var) + (make-sum (deriv (car operands) var) + (deriv (cadr operands) var))) +(define (deriv-product operands var) + (let ((multiplier (car operands)) + (multiplicand (cadr operands))) + (make-sum + (make-product multiplier + (deriv multiplicand var)) + (make-product (deriv multiplier var) + multiplicand)))) +(put 'deriv '+ deriv-sum) +(put 'deriv '* deriv-product) + +;; c. Choose any additional differentiation rule that you like, such as the one for exponents (exercise 2.56), and install it in this data-directed system. + +(define (exponentiation? exp) + (and (pair? exp) (eq? (car exp) '**))) +(define (base exp) + (cadr exp)) +(define (exponent exp) + (caddr exp)) +(define (=number? x num) + (and (number? x) (= x num))) +(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)))) + +(define (deriv-exp operands var) + (let ((base (car operands)) + (exponent (cadr operands))) + (make-product (make-product + exponent + (make-exponentiation base (make-sum exponent -1))) + (deriv base var)))) + +(put 'deriv '** deriv-exp) + +;; d. In this simple algebraic manipulator the type of an expression is the algebraic operator that binds it together. Suppose, however, we indexed the procedures in the opposite way, so that the dispatch line in deriv looked like + +;; ((get (operator exp) 'deriv) (operands exp) var) + +;; What corresponding changes to the derivative system are required? + +;; All we need to do is change the put operations to (put 'operator 'operations procedure-name) +;; not a big deal blob - /dev/null blob + 68cce03be4d81159a9fcdafc2b85548704d15e79 (mode 644) --- /dev/null +++ ex2-74-sol.scm @@ -0,0 +1,15 @@ +(define (make-generic-file division file) + (list division file)) +(define (division-of-generic-file gf) + (car gf)) +(define (file-of-generic-file gf) + (cadr gf)) +(define (get-record employee file) + ((get 'get-record + (division-of-generic-file file)) + employee + (file-of-generic-file file))) +(define (get-salary employee) + ((get 'get-salary + (division-of-generic-employee employee)) + (employee-of-generic-employee employee))) blob - /dev/null blob + 73cb644c7d12da0f7900d8a8ea0facacef2c57ca (mode 644) --- /dev/null +++ ex2-74.scm @@ -0,0 +1,83 @@ +;; Exercise 2.74. Insatiable Enterprises, Inc., is a highly decentralized conglomerate company consisting of a large number of independent divisions located all over the world. The company's computer facilities have just been interconnected by means of a clever network-interfacing scheme that makes the entire network appear to any user to be a single computer. Insatiable's president, in her first attempt to exploit the ability of the network to extract administrative information from division files, is dismayed to discover that, although all the division files have been implemented as data structures in Scheme, the particular data structure used varies from division to division. A meeting of division managers is hastily called to search for a strategy to integrate the files that will satisfy headquarters' needs while preserving the existing autonomy of the divisions. + +;; Show how such a strategy can be implemented with data-directed programming. As an example, suppose that each division's personnel records consist of a single file, which contains a set of records keyed on employees' names. The structure of the set varies from division to division. Furthermore, each employee's record is itself a set (structured differently from division to division) that contains information keyed under identifiers such as address and salary. In particular: + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "invalid operation/type")))) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "invalid datum"))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "invalid datum"))) + +;; returns name of given record +(define (name record) + (apply-generic 'name record)) +(define (address record) + (apply-generic 'address record)) +(define (salary record) + (apply-generic 'salary record)) +(define (make-file1-record1 name salary address other) + ((get 'make-file1-record1 '(file1 record1)) name salary address other)) + + +(define (install-file1) + (define (make-record1 name salary address other) + (list name salary address other)) + (define (name-record1 record) + (car record)) + ;; we'll implement the file as a simple unordered list + (define (in-file? file name) + (and (not (null? file)) + (or (eq? (car file) name) + (cond ((null? file) #f) + ((eq? (car file) name) #t) + (else (in-file? (cdr file) name)))) + (define + ) + (put 'make-file1-record1 + '(file1 record1) + (lambda (name salary address other) + (attach-tag '(file1 record1) + (make-record1 name salary address other)))) + + (put 'name '(file1 record1) ...) + + + +;; I should define an in-file? procedure and an add-record procedure instead + +;; (define (make-file-internal list-of-records) +;; list-of-records) +;; (put 'make-file 'file1 (lambda (list-of-records) +;; (attach-tag 'file1 (make-file-interal list-of-records)))) +;; (define (make-file1 list-of-records) +;; ((get 'make-file 'file1) list-of-records)) + +;; a. Implement for headquarters a get-record procedure that retrieves a specified employee's record from a specified personnel file. The procedure should be applicable to any division's file. Explain how the individual divisions' files should be structured. In particular, what type information must be supplied? + +;; get specified record from specified file +(define (get-record file name) + (apply-generic 'get-record file name)) + +(define (get-record-file1 file name) + (cond ((null? file) (error "person not found" name)) + ((eq? (car file) name) (car file)) + (else (get-record-file1 (cdr file) name)))) +(put 'get-record '(file1 file1-record) get-record-file1) + +;; b. Implement for headquarters a get-salary procedure that returns the salary information from a given employee's record from any division's personnel file. How should the record be structured in order to make this operation work? + +;; c. Implement for headquarters a find-employee-record procedure. This should search all the divisions' files for the record of a given employee and return the record. Assume that this procedure takes as arguments an employee's name and a list of all the divisions' files. + +;; d. When Insatiable takes over a new company, what changes must be made in order to incorporate the new personnel information into the central system? blob - /dev/null blob + dca008fc5a5a03d4bd142967badd457ebed446ba (mode 644) --- /dev/null +++ ex2-74.scm~ @@ -0,0 +1,102 @@ +(define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) +(define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) +(define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) +(define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum -- CONTENTS" datum))) +(define (rectangular? z) + (eq? (type-tag z) 'rectangular)) +(define (polar? z) + (eq? (type-tag z) 'polar)) + +(define (install-rectangular-package) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (make-from-real-imag x y) + (cons x y)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) + (atan (imag-part z) (real-part z))) + (define (make-from-mag-ang r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polar-package) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (make-from-mag-ang r a) (cons r a)) + (define (real-part z) + (* (magnitude z) (cos (angle z)))) + (define (imag-part z) + (* (magnitude z) (sin (angle z)))) + (define (make-from-real-imag x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (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 (real-part z) (apply-generic 'real-part z)) +(define (imag-part z) (apply-generic 'imag-part z)) +(define (magnitude z) (apply-generic 'magnitude z)) +(define (angle z) (apply-generic 'angle z)) +(define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) +(define (make-from-mag-ang r a) +: ((get 'make-from-mag-ang 'polar) r a)) + +;; Exercise 2.74. Insatiable Enterprises, Inc., is a highly decentralized conglomerate company consisting of a large number of independent divisions located all over the world. The company's computer facilities have just been interconnected by means of a clever network-interfacing scheme that makes the entire network appear to any user to be a single computer. Insatiable's president, in her first attempt to exploit the ability of the network to extract administrative information from division files, is dismayed to discover that, although all the division files have been implemented as data structures in Scheme, the particular data structure used varies from division to division. A meeting of division managers is hastily called to search for a strategy to integrate the files that will satisfy headquarters' needs while preserving the existing autonomy of the divisions. + +;; Show how such a strategy can be implemented with data-directed programming. As an example, suppose that each division's personnel records consist of a single file, which contains a set of records keyed on employees' names. The structure of the set varies from division to division. Furthermore, each employee's record is itself a set (structured differently from division to division) that contains information keyed under identifiers such as address and salary. In particular: + +;; a. Implement for headquarters a get-record procedure that retrieves a specified employee's record from a specified personnel file. The procedure should be applicable to any division's file. Explain how the individual divisions' files should be structured. In particular, what type information must be supplied? + +;; b. Implement for headquarters a get-salary procedure that returns the salary information from a given employee's record from any division's personnel file. How should the record be structured in order to make this operation work? + +;; c. Implement for headquarters a find-employee-record procedure. This should search all the divisions' files for the record of a given employee and return the record. Assume that this procedure takes as arguments an employee's name and a list of all the divisions' files. + +;; d. When Insatiable takes over a new company, what changes must be made in order to incorporate the new personnel information into the central system? blob - /dev/null blob + 0940cc82474644be3a6e0c8be90c9d97920ebc20 (mode 644) --- /dev/null +++ ex2-75.scm @@ -0,0 +1,24 @@ +(define (make-from-real-imag x y) + (define (dispatch op) + (cond ((eq? op 'real-part) x) + ((eq? op 'imag-part) y) + ((eq? op 'magnitude) + (sqrt (+ (square x) (square y)))) + ((eq? op 'angle) (atan y x)) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) + +(define (apply-generic op arg) (arg op)) + +;; Exercise 2.75. Implement the constructor make-from-mag-ang in message-passing style. This procedure should be analogous to the make-from-real-imag procedure given above. + +(define (make-from-mag-ang r a) + (define (dispatch op) + (cond ((eq? op 'real-part) (* r (cos a))) + ((eq? op 'imag-part) (* r (sin a))) + ((eq? op 'magnitude) r) + ((eq? op 'angle) a) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) + + blob - /dev/null blob + 6470f4c5cce628e2bd387490e0a39208164c03f4 (mode 644) --- /dev/null +++ ex2-75.scm~ @@ -0,0 +1,9 @@ +(define (make-from-real-imag x y) + (define (dispatch op) + (cond ((eq? op 'real-part) x) + ((eq? op 'imag-part) y) + ((eq? op 'magnitude) + (sqrt (+ (square x) (square y)))) + ((eq? op 'angle) (atan y x)) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) blob - /dev/null blob + e855c0469c7466abf6b1ca59aea191a06ec66d2a (mode 644) --- /dev/null +++ ex2-76.scm @@ -0,0 +1,30 @@ +(define (make-from-real-imag x y) + (define (dispatch op) + (cond ((eq? op 'real-part) x) + ((eq? op 'imag-part) y) + ((eq? op 'magnitude) + (sqrt (+ (square x) (square y)))) + ((eq? op 'angle) (atan y x)) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) + +(define (apply-generic op arg) (arg op)) + +;; Exercise 2.75. Implement the constructor make-from-mag-ang in message-passing style. This procedure should be analogous to the make-from-real-imag procedure given above. + +(define (make-from-mag-ang r a) + (define (dispatch op) + (cond ((eq? op 'real-part) (* r (cos a))) + ((eq? op 'imag-part) (* r (sin a))) + ((eq? op 'magnitude) r) + ((eq? op 'angle) a) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) + +;; Exercise 2.76. As a large system with generic operations evolves, new types of data objects or new operations may be needed. For each of the three strategies -- generic operations with explicit dispatch, data-directed style, and message-passing-style -- describe the changes that must be made to a system in order to add new types or new operations. Which organization would be most appropriate for a system in which new types must often be added? Which would be most appropriate for a system in which new operations must often be added? + +;; For generic operations with explicit dispatch, you need to update every single one of the generic selectors each time you add a new data type. You'll also need to add a new constructor for that data type. If you add a new generic operation, all of the data types that want to support it will need to provide a procedure. The maintainer of the generic operation needs to know about all the data types in order to make a proper dispatch. Explicit dispatch is the most burdensome to maintain. + +;; For data-directed and message-passing style, each time you add a new data type, there is no need for the generic operation to be updated. For data-directed style, the implementor of the new data type just needs to put the corresponding procedure into the table. For message-passing style, a table does not even need to be updated. The implementor only needs to update his data object to learn how to handle any messages the object needs to support. + +;; When adding a new operation, for both cases, the implementor of the data type will need to add a new procedure (or learn how to respond to the new operation message) if the operation needs to be supported. blob - /dev/null blob + 0940cc82474644be3a6e0c8be90c9d97920ebc20 (mode 644) --- /dev/null +++ ex2-76.scm~ @@ -0,0 +1,24 @@ +(define (make-from-real-imag x y) + (define (dispatch op) + (cond ((eq? op 'real-part) x) + ((eq? op 'imag-part) y) + ((eq? op 'magnitude) + (sqrt (+ (square x) (square y)))) + ((eq? op 'angle) (atan y x)) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) + +(define (apply-generic op arg) (arg op)) + +;; Exercise 2.75. Implement the constructor make-from-mag-ang in message-passing style. This procedure should be analogous to the make-from-real-imag procedure given above. + +(define (make-from-mag-ang r a) + (define (dispatch op) + (cond ((eq? op 'real-part) (* r (cos a))) + ((eq? op 'imag-part) (* r (sin a))) + ((eq? op 'magnitude) r) + ((eq? op 'angle) a) + (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) + dispatch) + + blob - /dev/null blob + 1eee3e63f7a4f024b0ffa9a619253386fa3bf4dd (mode 644) --- /dev/null +++ ex2-77.scm @@ -0,0 +1,167 @@ +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "error -- invalid datum" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "error -- invalid datum" datum))) +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done)) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + blob - /dev/null blob + 92bddd9d88f24d3a797532da14f11af222424846 (mode 644) --- /dev/null +++ ex2-77.scm~ @@ -0,0 +1,107 @@ +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "invalid datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "invalid datum -- TYPE-TAG" datum))) +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "procedure not found -- APPLY-GENERIC" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) + (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (x) (tag x))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) + +(define (install-rational-package) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (make-rational n d) + ((get 'make 'rational) n d)) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complez x1 x2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (tag z) (attach-tag 'complex z)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) blob - /dev/null blob + a6f3cefa6cfca0d769007bb290ccf48fe4298612 (mode 644) --- /dev/null +++ ex2-77b.scm @@ -0,0 +1,189 @@ +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "error -- invalid datum" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "error -- invalid datum" datum))) +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done)) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; Exercise 2.77. Louis Reasoner tries to evaluate the expression (magnitude z) where z is the object shown in figure 2.24. To his surprise, instead of the answer 5 he gets an error message from apply-generic, saying there is no method for the operation magnitude on the types (complex). He shows this interaction to Alyssa P. Hacker, who says ``The problem is that the complex-number selectors were never defined for complex numbers, just for polar and rectangular numbers. All you have to do to make this work is add the following to the complex package:'' + +(put 'real-part '(complex) real-part) +(put 'imag-part '(complex) imag-part) +(put 'magnitude '(complex) magnitude) +(put 'angle '(complex) angle) + +;; We are exporting the selectors which are inside the complex package and putting them in the operation-and-type-table so that the generic procedures dispatch on type. These selectors are themselves generic procedures which depend upon selectors implemented in the rectangular/polar procedures which were exported to the operation-and-type-table. + +What happens is that we have a datum z. Since it is a complex number, it is dispatched to the complex package after being stripped of its tag. This datum is then identified as a rectangular number, stripped of its tag, and dispatched to the rectangular package. + +(define (real-part z) (apply-generic 'real-part z)) +(define (imag-part z) (apply-generic 'imag-part z)) +(define (magnitude z) (apply-generic 'magnitude z)) +(define (angle z) (apply-generic 'angle z)) + +;; Describe in detail why this works. As an example, trace through all the procedures called in evaluating the expression (magnitude z) where z is the object shown in figure 2.24. In particular, how many times is apply-generic invoked? What procedure is dispatched to in each case? + +A single call to (magnitude z) from outside the packages ends up as follows: +The tag identifies that z is a complex number. The appropriate procedure of operation 'magnitude and type '(complex) is called on the contents of z (which is a datum typed as 'rectangular). This procedure is itself a generic selector, so the datum it receives is identified as type 'rectangular. The rectangular procedure is then called on the contents of z. + +Apply-generic is invoked twice. blob - /dev/null blob + 1eee3e63f7a4f024b0ffa9a619253386fa3bf4dd (mode 644) --- /dev/null +++ ex2-77b.scm~ @@ -0,0 +1,167 @@ +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "error -- invalid datum" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "error -- invalid datum" datum))) +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done)) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + blob - /dev/null blob + 4388bba41d82bdf68eda64554e8d7806deb92ecc (mode 644) --- /dev/null +++ ex2-78-sol.scm @@ -0,0 +1,18 @@ +(define (attach-tag type-tag contents) + (if (number? contents) + 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 -- TYPE-TAG" datum)))) + +(put 'real-part '(complex) real-part) +(put 'imag-part '(complex) imag-part) +(put 'magnitude '(complex) magnitude) +(put 'angle '(complex) angle) + blob - /dev/null blob + fc62b8f66eb5f851c29827581659c3844cba743a (mode 644) --- /dev/null +++ ex2-78-sol.scm~ @@ -0,0 +1,10 @@ +(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 (attach-tag type-tag contents) blob - /dev/null blob + bd72318632956925a39dd9ec8aca1d767fad7443 (mode 644) --- /dev/null +++ ex2-78.scm @@ -0,0 +1,204 @@ +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "error -- invalid datum" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "error -- invalid datum" datum))) +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done)) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define get 2d-get) +(define put 2d-put!) + +(define (install-scheme-number-package) +(define (install-rational-package) +(define (install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + + + +(test-case (make-scheme-number 5) 5) +(test-case (make- blob - /dev/null blob + c388a33468cf23f921b66026bea3d614e49a42e8 (mode 644) --- /dev/null +++ ex2-78.scm~ @@ -0,0 +1,193 @@ +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "error -- invalid datum" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "error -- invalid datum" datum))) +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done)) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (make-scheme-number 5) 5) +(test-case (make- blob - /dev/null blob + af30b418c145d19bd4fe9a17ef8869a0b198434b (mode 644) --- /dev/null +++ ex2-78b.scm @@ -0,0 +1,262 @@ +;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +;; (define get 2d-get) +;; (define put 2d-put!) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (make-scheme-number 5) 5) +(test-case (contents (make-scheme-number 4)) 4) +(test-case (type-tag 5) 'scheme-number) +(test-case (add (make-scheme-number 5) + (make-scheme-number 5)) + 10) +(test-case + (div (make-scheme-number -12) + (sub (make-scheme-number 4) + (mul (make-scheme-number 3) + (make-scheme-number 2)))) + 6) + +(test-case (type-tag (make-rational 5 6)) 'rational) +(test-case (contents (make-rational 5 6)) (cons 5 6)) +(test-case (add (sub (add (make-rational 5 6) + (make-rational 3 4)) + (mul (make-rational 2 4) + (make-rational 1 4))) + (div (make-rational 3 4) + (make-rational 1 2))) + (cons 'rational (cons 71 24))) + +(test-case (add (sub (add (make-complex-from-real-imag 5 6) + (make-complex-from-mag-ang 3 4)) + (mul (make-complex-from-mag-ang 2 4) + (make-complex-from-real-imag 1 4))) + (div (make-complex-from-real-imag 3 4) + (make-complex-from-mag-ang 1 2))) + (cons 'complex (cons 'rectangular (cons 0.68068565 6.07986688)))) + blob - /dev/null blob + c9c7f6a2bf683daed21e394f505d774632d7e9a5 (mode 644) --- /dev/null +++ ex2-78b.scm~ @@ -0,0 +1,245 @@ +(define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + +(define (make-table) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- Table" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (display "tag installed") + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (display "add installed") + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + (display "grabbing procedure") + (test-case ((get 'add '(scheme-number scheme-number)) 3 4) 7) + (display "procedure grabbed") + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (make-scheme-number 5) 5) +(test-case (add (make-scheme-number 5) + (make-scheme-number 5)) + 10) +(test-case + (div (make-scheme-number -12) + (subtract (make-scheme-number 4) + (mul (make-scheme-number 3) + (make-scheme-number 2)))) + 6) blob - /dev/null blob + 55e1ff07e1a05a3aa98dc559268e1403a0855da0 (mode 644) --- /dev/null +++ ex2-79-sol.scm @@ -0,0 +1 @@ +(define (=zero? blob - /dev/null blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644) blob - /dev/null blob + f0b488870253040ee0dce7897415ac3efbdb8b97 (mode 644) --- /dev/null +++ ex2-79.scm @@ -0,0 +1,272 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'equ? '(rational rational) equ-rat?) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + (put 'equ? '(complex complex) equ-complex?) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) blob - /dev/null blob + af30b418c145d19bd4fe9a17ef8869a0b198434b (mode 644) --- /dev/null +++ ex2-79.scm~ @@ -0,0 +1,262 @@ +;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +;; (define get 2d-get) +;; (define put 2d-put!) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (make-scheme-number 5) 5) +(test-case (contents (make-scheme-number 4)) 4) +(test-case (type-tag 5) 'scheme-number) +(test-case (add (make-scheme-number 5) + (make-scheme-number 5)) + 10) +(test-case + (div (make-scheme-number -12) + (sub (make-scheme-number 4) + (mul (make-scheme-number 3) + (make-scheme-number 2)))) + 6) + +(test-case (type-tag (make-rational 5 6)) 'rational) +(test-case (contents (make-rational 5 6)) (cons 5 6)) +(test-case (add (sub (add (make-rational 5 6) + (make-rational 3 4)) + (mul (make-rational 2 4) + (make-rational 1 4))) + (div (make-rational 3 4) + (make-rational 1 2))) + (cons 'rational (cons 71 24))) + +(test-case (add (sub (add (make-complex-from-real-imag 5 6) + (make-complex-from-mag-ang 3 4)) + (mul (make-complex-from-mag-ang 2 4) + (make-complex-from-real-imag 1 4))) + (div (make-complex-from-real-imag 3 4) + (make-complex-from-mag-ang 1 2))) + (cons 'complex (cons 'rectangular (cons 0.68068565 6.07986688)))) + blob - /dev/null blob + 7629edb3dd491ddfb01288bbacdff297468a58b0 (mode 644) --- /dev/null +++ ex2-8.lisp @@ -0,0 +1,4 @@ +(defun sub-interval (x y) + (make-interval + (- (lower-bound x) (upper-bound y)) + (- (upper-bound x) (lower-bound y)))) blob - /dev/null blob + f5c3d074ada01a62ba625420640975e35b7e8b21 (mode 644) --- /dev/null +++ ex2-8.scm @@ -0,0 +1,30 @@ +(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)) + + +;; Exercise 2.8. Using reasoning analogous to Alyssa's, describe how the difference of two intervals may be computed. Define a corresponding subtraction procedure, called sub-interval. + +(define (sub-interval x y) + (make-interval (- (lower-bound x) (upper-bound y)) + (- (upper-bound x) (lower-bound y)))) + blob - /dev/null blob + 55f82533de4af68dba5fb302180c789ae30ca9d8 (mode 644) --- /dev/null +++ ex2-8.scm~ @@ -0,0 +1,24 @@ +(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 a b) + (cons a b)) +(define (upper-bound x) + (cdr x)) +(define (lower-bound x) + (car x)) + + blob - /dev/null blob + d4a64ea4629bd24231823149d19fb2cd1ad96c03 (mode 644) --- /dev/null +++ ex2-80.scm @@ -0,0 +1,314 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put '=zero? '(scheme-number) zero?) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5)))) + #t) +(test-case (=zero? (sub (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #t) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 3.5) + (make-scheme-number 5)))) + #f) +(test-case (=zero? (sub (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) blob - /dev/null blob + f0b488870253040ee0dce7897415ac3efbdb8b97 (mode 644) --- /dev/null +++ ex2-80.scm~ @@ -0,0 +1,272 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error "error -- procedure not found" (list op args))))) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'equ? '(rational rational) equ-rat?) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + (put 'equ? '(complex complex) equ-complex?) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) blob - /dev/null blob + 42af55dc870e4b9e1d18196b924d1aefedddcd89 (mode 644) --- /dev/null +++ ex2-81-sol.scm @@ -0,0 +1,35 @@ +(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 + e7d30742614ea8b925ce019d01c80d2c1c5e5ee2 (mode 644) --- /dev/null +++ ex2-81.scm @@ -0,0 +1,391 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +(define coercion-table (make-table)) +(define get-coercion (coercion-table 'lookup-proc)) +(define put-coercion (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put '=zero? '(scheme-number) zero?) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5)))) + #t) +(test-case (=zero? (sub (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #t) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 3.5) + (make-scheme-number 5)))) + #f) +(test-case (=zero? (sub (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + + +(define (scheme-number->complex n) + (make-complex-from-real-imag (contents n) 0)) +(put-coercion 'scheme-number 'complex scheme-number->complex) + +(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))))))) + + +;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do: + +(define (scheme-number->scheme-number n) n) +(define (complex->complex z) z) +(put-coercion 'scheme-number 'scheme-number + scheme-number->scheme-number) +(put-coercion 'complex 'complex complex->complex) + +;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation: + +(define (exp x y) (apply-generic 'exp x y)) + +;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package: + +;; following added to Scheme-number package +(put 'exp '(scheme-number scheme-number) + (lambda (x y) (tag (expt x y)))) ; using primitive expt + +;; What happens if we call exp with two complex numbers as arguments? + +;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion. + +;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is? + +;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is. + +;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type. + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (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))) + (if (equal? type1 type2) + (error "No method for these types" + (list op args)) + (let ((a1 (car args)) + (a2 (cadr args)) + (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 args)))))))) + (error "No method for these types" + (list op args)))))) + +;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.) blob - /dev/null blob + fc4f74b44773357e9d4067e2042dc4a73875680c (mode 644) --- /dev/null +++ ex2-81.scm~ @@ -0,0 +1,392 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +(define coercion-table (make-table)) +(define get-coercion (coercion-table 'lookup-proc)) +(define put-coercion (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put '=zero? '(scheme-number) zero?) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5)))) + #t) +(test-case (=zero? (sub (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #t) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 3.5) + (make-scheme-number 5)))) + #f) +(test-case (=zero? (sub (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + + +(define (scheme-number->complex n) + (make-complex-from-real-imag (contents n) 0)) +(put-coercion 'scheme-number 'complex scheme-number->complex) + +(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))))))) + + +;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do: + +(define (scheme-number->scheme-number n) n) +(define (complex->complex z) z) +(put-coercion 'scheme-number 'scheme-number + scheme-number->scheme-number) +(put-coercion 'complex 'complex complex->complex) + +;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation: + +(define (exp x y) (apply-generic 'exp x y)) + +;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package: + +;; following added to Scheme-number package +(put 'exp '(scheme-number scheme-number) + (lambda (x y) (tag (expt x y)))) ; using primitive expt + +;; What happens if we call exp with two complex numbers as arguments? + +;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion. + +;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is? + +;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is. + +;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type. + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (and (= (length args) 2) + (let* ((type1 (car type-tags)) + (type2 (cadr type-tags)) + (a1 (car args)) + (a2 (cadr args)) + (t1->t2 (get-coercion type1 type2)) + (t2->t1 (get-coercion type2 type1))) + (cond ((eq? type1 type2) (error "No method for these types" + (list op args))) + ;; probably should do some data abstraction instead + ;; of this ugly hack + (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 args))))) + (error "No method for these types" + (list op args)))))) + +;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.) blob - /dev/null blob + 123fd26292123822a5a01001f733d3cbd406d8ff (mode 644) --- /dev/null +++ ex2-82-sol.scm @@ -0,0 +1,34 @@ +(define (apply-generic op . args) + (define (can-coerce-into? types target-type) + (andmap (lambda (type) + (or (equal? type target-type) + (get-coercion type target-type))) + types)) + (define (find-coercion-target types) + (ormap + (lambda (target-type) + (if (can-coerce-into? types target-type) + target-type + #f)) + types)) + (define (coerce-all args target-type) + (map (lambda (arg) + (let ((arg-type (type-tag arg))) + (if (equal? arg-type target-type) + arg + ((get-coercion arg-type target-type) arg)))) + args)) + (define (no-method type-tags) + (error "No method for these types" + (list op type-tags))) + (let ((type-tags (map type-tag args))) + (let ((proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (let ((target-type (find-coercion-target type-tags))) + (if target-type + (apply + apply-generic + (append (list op) + (coerce-all args target-type))) + (no-method type-tags))))))) blob - /dev/null blob + 1ac80f5ec4498367bdc9c764d9a5b6fa77493973 (mode 644) --- /dev/null +++ ex2-82-sol.scm~ @@ -0,0 +1,3 @@ +(define (apply-generic op . args) + (define (can-coerce-into? types target-type) + (andmap blob - /dev/null blob + 60943f347e76458c432c8faf66119b530f7936a1 (mode 644) --- /dev/null +++ ex2-82.scm @@ -0,0 +1,382 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +(define coercion-table (make-table)) +(define get-coercion (coercion-table 'lookup-proc)) +(define put-coercion (coercion-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put '=zero? '(scheme-number) zero?) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5)))) + #t) +(test-case (=zero? (sub (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #t) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 3.5) + (make-scheme-number 5)))) + #f) +(test-case (=zero? (sub (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + +(define (scheme-number->complex n) + (make-complex-from-real-imag (contents n) 0)) +(put-coercion 'scheme-number 'complex scheme-number->complex) + +(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 + (display "test") + (error "No method for these types" + (list op type-tags)))))) + (error "No method for these types" + (list op type-tags))))))) + + +(test-case (add (make-scheme-number 5) + (make-complex-from-real-imag 3 2)) + '(complex rectangular 8 . 2)) +(test-case (add (make-complex-from-mag-ang 5 0.927295218) + (make-scheme-number 2)) + '(complex rectangular 5 . 4)) + +;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (let* ((all-coercions ;; 2d-list of coercion procedures + (map (lambda (to-tag) + (map (lambda (from-tag) + (if (equal? from-tag to-tag) + #t + (get-coercion from-tag to-tag))) + type-tags)) + type-tags)) + (valid-coercions + (filter (lambda (coercions) + (fold-left and #t coercions)) + all-coercions))) + ;; #t if same type or if coercion procedure exists + (if (null? valid-coercions) + (error "No method for these types" + (list op type-tags)) + (apply apply-generic + (cons op + (map (lambda (coerce arg) + (if (equal? coerce 'same-tag) + arg + (coerce arg))) + (car valid-coercions) + args)))))))) + ;; use the first to-type that all arguments can be coerced to + +;; It might be the case that a mixed-type operation would work where trying to force everything to the same type might not. For example, a contrived operation might work for data types '(float complex int) if we coerce float to complex to get '(complex complex int) but may not work with '(complex complex complex) or '(int int int). + +;; or maybe a supertype might work. Say we want to add '(imaginary real), then we might want to promote both to complex then add blob - /dev/null blob + e7d30742614ea8b925ce019d01c80d2c1c5e5ee2 (mode 644) --- /dev/null +++ ex2-82.scm~ @@ -0,0 +1,391 @@ +;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. + +(define (attach-tag type-tag contents) + (if (eq? type-tag 'scheme-number) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((number? datum) datum) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +(define coercion-table (make-table)) +(define get-coercion (coercion-table 'lookup-proc)) +(define put-coercion (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) + +(define (install-scheme-number-package) + (define (tag x) (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(scheme-number scheme-number) =) + (put '=zero? '(scheme-number) zero?) + (put 'make 'scheme-number + (lambda (n) (tag n))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-scheme-number-package) +(install-rational-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (div (make-scheme-number 80) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5))) + #f) +(test-case (equ? (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) + #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 4) + (make-scheme-number 5)))) + #t) +(test-case (=zero? (sub (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #t) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) +(test-case (=zero? (sub (div (make-scheme-number 81) + (mul (make-scheme-number 2) + (make-scheme-number 4.5))) + (add (make-scheme-number 3.5) + (make-scheme-number 5)))) + #f) +(test-case (=zero? (sub (div (make-rational 4 3) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4))))) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + + +(define (scheme-number->complex n) + (make-complex-from-real-imag (contents n) 0)) +(put-coercion 'scheme-number 'complex scheme-number->complex) + +(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))))))) + + +;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do: + +(define (scheme-number->scheme-number n) n) +(define (complex->complex z) z) +(put-coercion 'scheme-number 'scheme-number + scheme-number->scheme-number) +(put-coercion 'complex 'complex complex->complex) + +;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation: + +(define (exp x y) (apply-generic 'exp x y)) + +;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package: + +;; following added to Scheme-number package +(put 'exp '(scheme-number scheme-number) + (lambda (x y) (tag (expt x y)))) ; using primitive expt + +;; What happens if we call exp with two complex numbers as arguments? + +;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion. + +;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is? + +;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is. + +;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type. + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (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))) + (if (equal? type1 type2) + (error "No method for these types" + (list op args)) + (let ((a1 (car args)) + (a2 (cadr args)) + (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 args)))))))) + (error "No method for these types" + (list op args)))))) + +;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.) blob - /dev/null blob + 578832b2d3e974384c65d17b9fcf615695433895 (mode 644) --- /dev/null +++ ex2-82b-sol.scm @@ -0,0 +1,23 @@ +(define (apply-generic op . args) + (define (try-convert x new-type) + (let ((converter (get-coercion (type-tag x) new-type))) + (if converter + (converter x) + x))) + (define (apply-generic-1 op args type-list) + (if (null? type-list) + (error "No method for these types" + (list op (map type-tag args))) + (let ((new-args (map (lambda (x) + (try-convert x (car type-list))) + args))) + (let ((new-type-tags (map type-tag new-args))) + (let ((proc (get op new-type-tags))) + (if proc + (apply proc (map contents new-args)) + (apply-generic-1 op args (cdr type-list)))))))) + (let ((type-tags (map type-tag args))) + (let ((proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (apply-generic-1 op args type-tags))))) blob - /dev/null blob + 2aa8180dc1e814aa40a21540065f90f84b851094 (mode 644) --- /dev/null +++ ex2-83-sol.scm @@ -0,0 +1,301 @@ +(define (coerce-to target-type remaining-args result) + (if (null? remaining-args) + result + (let* ((arg (car remaining-args)) + (original-type (type-tag arg))) + (if (eq? original-type target-type) + (coerce-to target-type + (cdr remaining-args) + (append result (list arg))) + (let ((original->target (get-coercion (type-tag arg) target-type))) + (if original->target + (coerce-to target-type + (cdr remaining-args) + (append result (list (original->target arg)))) + #f)))))) +(define (put-coercion source-type target-type proc) + (put 'coercion (list source-type target-type) proc)) +(define (get-coercion source-type target-type) + (get 'coercion (list source-type target-type))) + +(define (apply-generic-iter coercion-types) + (if (null? coercion-types) + (error "No method for these types, and could not coerce" + (list op (map type-tag args))) + (let ((coerced-args (coerce-to (car coercion-types) args '()))) + (if coerced-args + (let ((proc (get op (map type-tag coerced-args)))) + (if proc + (apply proc (map contents coerced-args)) + (apply-generic-iter (cdr coercion-types)))) + (apply-generic-iter (cdr coercion-types)))))) +(define (uniquify l) + (if (null? l) + '() + (let ((head (car l)) + (tail (cdr l))) + (if (memq head tail) + (uniquify tail) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (let ((unique-types (uniquify type-tags))) + (if (> (length unique-types) 1) + (apply-generic-iter unique-types) + (else (error "No method for this type" + (list op type-tags)))))))) + + +(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 (integer->rational n) + (make-rational n 1)) +(put 'raise '(integer) + (lambda (i) (integer->rational i))) +(define (rational->real r) + (make-real + (exact->inexact (/ (numer r) (denom r))))) +(put 'raise '(rational) + (lambda (r) (rational->real r))) +(define (real->complex r) + (make-complex-from-real-imag r 0)) +(put 'raise '(real) + (lambda (r) (real->complex r))) +(define (raise x) + (apply-generic 'raise x)) + +(define (raise x) (apply-generic 'raise x)) +(put 'raise '(scheme-number) + (lambda (x) + (if (exact-integer? x) + (make-rational x 1) + (make-complex-from-real-imag x 0)))) +(put 'raise '(rational) + (lambda (r) + (make-scheme-number (exact->inexact (/ (numer r) (denom r)))))) + +(define (install-integer-package) + (define (tag x) + (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (make-rational x y))) + (put 'equ '(integer integer) =) + (put '=zero? '(integer) + (lambda (x) (= 0 x))) + (put 'make 'integer + (lambda (x) (if (integer? x) + (tag x) + (error "non-integer value" x)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) + +(define (install-real-package) + (define (tag x) + (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) + (lambda (x) (= 0 x))) + (put 'make 'real + (lambda (x) (if (real? x) + (tag x) + (error "non-real value" x)))) + 'done) + +(define (make-real n) + ((get 'make 'real) n)) + +(define (install-rational-package) + (define (make-rat n d) + (if (and (integer? n) (integer? d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))) + (error "non-integer numerator or denominator" + (list n d)))) + 'done) + +(define (install-rectangular-package) + (define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons x y) + (error "non-real real or imaginary value" (list x y)))) + (define (make-from-mag-ang r a) + (if (and (real? r) (real? a)) + (cons (* r (cos a)) (* r (sin a))) + (error "non-real magnitude or angle" (list r a)))) + + 'done) + +(define (install-polar-package) + (define (make-from-mag-ang r a) + (if (and (in-tower? r) (in-tower? a)) + (cons r a) + (error "non-real magnitude or angle" (list r a)))) + (define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons (sqrt (+ (square x) (square y))) + (atan y x)) + (error "non-real real or imaginary value" (list x y)))) + 'done) + +(define (integer->rational i) (make-rational i 1)) +(define (rational->real r) (make-real (/ (numer r) (denom r)))) +(define (real->complex r) (make-complex-from-real-imag r 0)) +(define (raise x) (apply-generic 'raise x)) + +(define tower-of-types '(integer rational real complex)) +(define (raise x) + (define (apply-raise types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list x tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise (cdr types))))) + (apply-raise tower-of-types)) + +(define (install-integer-package) + (define (tag x) + (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (make-rational x y))) + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) =zero?) + (put 'make 'integer + (lambda (x) (if (integer? x) + (tag x) + (error "non-integer value" x)))) + 'done) +(define (make-integer n) + ((get 'make 'integer) n)) + +(define (install-real-package) + (define (tag x) + (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) + (lambda (x) (= 0 x))) + (put 'make 'real + (lambda (x) (if (real? x) + (tag x) + (error "non-real value" x)))) + +(define (make-real n) + ((get 'make 'real) n)) + +(define (install-rational-package) + (define (make-rat n d) + (if (and (integer? n) (integer? d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))) + (error "non-integer numerator or denominator" + (list n d)))) + 'done) + +(define (install-rectangular-package) + (define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons x y) + (error "non-real real or imaginary value" (list x y)))) + (define (make-from-mag-ang r a) + (if (and (real? r) (real? a)) + (cons (* r (cos a)) (* r (sin a))) + (error "non-real magnitude or angle" (list r a)))) + 'done) +(define (install-polar-package) + (define (make-from-mag-ang r a) + (if (and (in-tower? r) (in-tower? a)) + (cons r a) + (error "non-real magnitude or angle" (list r a)))) + (define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons (sqrt (+ (square x) (square y))) + (atan y x)) + (error "non-real real or imaginary value" (list x y)))) + 'done) + + +(define (integer->rational i) (make-rational i 1)) +(define (rational->real r) (make-real (/ (numer r) (denom r)))) +(define (real->complex r) (make-complex-from-real-imag r 0)) +(define (raise x) (apply-generic 'raise x)) + +(define tower-of-types '(integer rational real complex)) +(define (raise x) + (define (apply-raise types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list x tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise (cdr types))))) + (apply-raise tower-of-types)) + +(define (integer->rational i) (make-rational i 1)) +(put-coercion 'integer 'rational integer->rational) +'done +(define (rational->real r) (make-real (/ (numer r) (denom r)))) +(put-coercion 'rational 'real rational->real) +'done +(define (real->complex r) (make-complex-from-real-imag r 0)) +(put-coercion 'real 'complex real->complex) +'done + + +(raise (make-integer 2)) +(raise (make-rational 3 4)) +(raise ( blob - /dev/null blob + dbd0d3c99f5548636c6d2c218b7da0276988949e (mode 644) --- /dev/null +++ ex2-83-sol.scm~ @@ -0,0 +1,190 @@ +(define (coerce-to target-type remaining-args result) + (if (null? remaining-args) + result + (let* ((arg (car remaining-args)) + (original-type (type-tag arg))) + (if (eq? original-type target-type) + (coerce-to target-type + (cdr remaining-args) + (append result (list arg))) + (let ((original->target (get-coercion (type-tag arg) target-type))) + (if original->target + (coerce-to target-type + (cdr remaining-args) + (append result (list (original->target arg)))) + #f)))))) +(define (put-coercion source-type target-type proc) + (put 'coercion (list source-type target-type) proc)) +(define (get-coercion source-type target-type) + (get 'coercion (list source-type target-type))) + +(define (apply-generic-iter coercion-types) + (if (null? coercion-types) + (error "No method for these types, and could not coerce" + (list op (map type-tag args))) + (let ((coerced-args (coerce-to (car coercion-types) args '()))) + (if coerced-args + (let ((proc (get op (map type-tag coerced-args)))) + (if proc + (apply proc (map contents coerced-args)) + (apply-generic-iter (cdr coercion-types)))) + (apply-generic-iter (cdr coercion-types)))))) +(define (uniquify l) + (if (null? l) + '() + (let ((head (car l)) + (tail (cdr l))) + (if (memq head tail) + (uniquify tail) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (let ((unique-types (uniquify type-tags))) + (if (> (length unique-types) 1) + (apply-generic-iter unique-types) + (else (error "No method for this type" + (list op type-tags)))))))) + + +(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 (integer->rational n) + (make-rational n 1)) +(put 'raise '(integer) + (lambda (i) (integer->rational i))) +(define (rational->real r) + (make-real + (exact->inexact (/ (numer r) (denom r))))) +(put 'raise '(rational) + (lambda (r) (rational->real r))) +(define (real->complex r) + (make-complex-from-real-imag r 0)) +(put 'raise '(real) + (lambda (r) (real->complex r))) +(define (raise x) + (apply-generic 'raise x)) + +(define (raise x) (apply-generic 'raise x)) +(put 'raise '(scheme-number) + (lambda (x) + (if (exact-integer? x) + (make-rational x 1) + (make-complex-from-real-imag x 0)))) +(put 'raise '(rational) + (lambda (r) + (make-scheme-number (exact->inexact (/ (numer r) (denom r)))))) + +(define (install-integer-package) + (define (tag x) + (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (make-rational x y))) + (put 'equ '(integer integer) =) + (put '=zero? '(integer) + (lambda (x) (= 0 x))) + (put 'make 'integer + (lambda (x) (if (integer? x) + (tag x) + (error "non-integer value" x)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) + +(define (install-real-package) + (define (tag x) + (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) + (lambda (x) (= 0 x))) + (put 'make 'real + (lambda (x) (if (real? x) + (tag x) + (error "non-real value" x)))) + 'done) + +(define (make-real n) + ((get 'make 'real) n)) + +(define (install-rational-package) + (define (make-rat n d) + (if (and (integer? n) (integer? d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))) + (error "non-integer numerator or denominator" + (list n d)))) + 'done) + +(define (install-rectangular-package) + (define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons x y) + (error "non-real real or imaginary value" (list x y)))) + (define (make-from-mag-ang r a) + (if (and (real? r) (real? a)) + (cons (* r (cos a)) (* r (sin a))) + (error "non-real magnitude or angle" (list r a)))) + + 'done) + +(define (install-polar-package) + (define (make-from-mag-ang r a) + (if (and (in-tower? r) (in-tower? a)) + (cons r a) + (error "non-real magnitude or angle" (list r a)))) + (define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons (sqrt (+ (square x) (square y))) + (atan y x)) + (error "non-real real or imaginary value" (list x y)))) + 'done) + +(define (integer->rational i) (make-rational i 1)) +(define (rational->real r) (make-real (/ (numer r) (denom r)))) +(define (real->complex r) (make-complex-from-real-imag r 0)) +(define (raise x) (apply-generic 'raise x)) + +(define tower-of-types '(integer rational real complex)) +(define (raise x) + (define (apply-raise types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list x tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise (cdr types))))) + (apply-raise tower-of-types)) + blob - /dev/null blob + 40c830477454c983250b19e2e7187b83ecf0f186 (mode 644) --- /dev/null +++ ex2-83.scm @@ -0,0 +1,393 @@ +;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex). + +;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex + +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +(define coercion-table (make-table)) +(define get-coercion (coercion-table 'lookup-proc)) +(define put-coercion (coercion-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +(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))))))) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) + + + + blob - /dev/null blob + cef090df6e8ff1b1d051a7a051bc3d6aa5d03e8c (mode 644) --- /dev/null +++ ex2-83.scm~ @@ -0,0 +1,407 @@ +;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex). + +;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex + +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((integer? datum) 'integer) + ((number? datum) 'real) + ((pair? datum) (car datum)) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((integer? datum) datum) + ((number? datum) (exact->inexact datum)) + ((pair? datum) (cdr datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +(define coercion-table (make-table)) +(define get-coercion (coercion-table 'lookup-proc)) +(define put-coercion (coercion-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (integer? n) + (tag n) + (error "Not an integer" n)))) + (put 'raise 'integer + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise 'rational + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (integer? n) + (tag (exact->inexact n)) + (tag n)))) +(put 'raise 'real (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) + + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'integer) ;; automatically drops +(test-case (make-real 1.66667) 1.66667) +;; (test-case (make-real (/ 5 3)) 1.66667) fails + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +;; (test-case (=zero? (sub (div (make-rational 4 3) +;; (make-rational 1 3)) +;; (sub (make-rational 9 1) +;; (mul (make-rational 4 1) +;; (make-rational 3 4))))) +;; #f) +;; (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) +;; (make-complex-from-real-imag -5 -3)) +;; '(complex rectangular -2 . 1))) +;; #f) + +;; (define (scheme-number->complex n) +;; (make-complex-from-real-imag (contents n) 0)) +;; (put-coercion 'scheme-number 'complex scheme-number->complex) + +(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))))))) + + +;; (test-case (add (make-scheme-number 5) +;; (make-complex-from-real-imag 3 2)) +;; '(complex rectangular 8 . 2)) +;; (test-case (add (make-complex-from-mag-ang 5 0.927295218) +;; (make-scheme-number 2)) +;; '(complex rectangular 5 . 4)) + + +(define (raise x) (apply-generic 'raise x)) + blob - /dev/null blob + 286164bf9dddfba9a32887c7035dd28e299c1853 (mode 644) --- /dev/null +++ ex2-84-sol.scm @@ -0,0 +1,133 @@ +(define (find-highest-type l) + (define (filter-type t f) + (cond ((null? f) '()) + ((eq? (car f) t) (filter-type t (cdr f))) + (else (cons (car f) (filter-type t (cdr f)))))) + (define (find-highest highest remaining-tower remaining-list) + (cond ((null? remaining-list) highest) + ((null? remaining-tower) + (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE" + remaining-list)) + (else (find-highest (car remaining-tower) + (cdr remaining-tower) + (filter-type (car remaining-tower) remaining-list))))) + (find-highest #f tower-of-types l)) + +(find-highest-type '(integer real rational real)) +(find-highest-type '(rational rational rational)) +(find-highest-type '(complex real rational integer)) +(find-highest-type '()) +(find-highest-type '(integer wibble real wobble complex)) + +(define (raise-to type value) + (cond ((eq? type (type-tag value)) value) + ((memq type tower-of-types) (raise-to type (raise value))) + (else (error "Cannot raise to non-tower type -- RAISE-TO" + (list type tower-of-types))))) +(raise-to 'real (make-integer 4)) +(raise-to 'complex (make-rational 3 4)) +(raise-to 'real (make-real 3.14159)) +(raise-to 'wibble (make-integer 42)) + +(define (raise-all-to type values) + (if (null? values) + '() + (cons (raise-to-type (car values)) (raise-all-to type (cdr values))))) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (> (length args) 1) + (let* ((highest-type (find-highest-type type-tags)) + (mapped-args (raise-all-to highest-type args)) + (mapped-types (map type-tag mapped-args)) + (mapped-proc (get op mapped-types))) + (if mapped-proc + (apply mapped-proc (map contents mapped-args)) + (error + "No method for these types -- APPLY-GENERIC" + (list op type-tags)))))))) +(put 'addd '(integer integer integer) + (lambda (x y z) (tag (+ x y z)))) +(define (addd x y z) + (make-rat (+ (* (numer x) (denom y) (denom z)) + (* (denom x) (numer y) (denom z)) + (* (denom x) (denom y) (numer z))) + (* (denom x) (denom y) (denom z)))) +(put 'addd '(rational rational rational) + (lambda (x y z) (tag (addd x y z)))) +(put 'add '(real real real) + (lambda (x y z) (tag (+ x y z)))) +(addd (make-real 3.14159) (make-rational 3 4) (make-complex-from-real-imag 1 7)) + +(define (raise x) (apply-generic 'raise x)) +(put 'raise '(scheme-number) + (lambda (x) + (if (exact-integer? x) + (make-rational x 1) + (make-complex-from-real-imag x 0)))) +(put 'raise '(rational) + (lambda (r) + (make-scheme-number (exact->inexact (/ (numer r) (denom r)))))) + +(define (tower-level x) + (let ((typex (type-tag x))) + (cond ((eq? typex 'rational) 1) + ((eq? typex 'complex) 3) + (else + (let ((y (contents x))) + (if (exact-integer? y) + 0 + 2)))))) +(define (raise-to level x) + (if (= level (tower-level x)) + x + (raise-to level (raise x)))) + +(define (apply-generic op . args) + (let ((typetags (map type-tag args))) + (let ((proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let* ((a1 (car args)) + (a2 (cadr args)) + (level1 (tower-level a1)) + (level2 (tower-level a2))) + (cond ((< level1 level2) + (apply-generic op (raise-to level2 a1) a2)) + ((< level2 level1) + (apply-generic op a1 (raise-to level1 a2))) + (else + (error "No method for these types" + (list op type-tags))))) + (error "No method for these types" + (lsit op type-tags))))))) + +(define (apply-generic-r op . args) + (define (no-method type-tags) + (error "No method for these types" + (list op type-tags))) + (define (raise-into s t) + (let ((s-type (type-tag s)) + (t-type (type-tag t))) + (cond ((equal? s-type t-type) s) + ((get 'raise (list s-type)) + (raise-into ((get 'raise (list s-type)) (contents s)) t)) + (t #f)))) + (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 ((o1 (car args)) + (o2 (cadr args))) + (cond + ((raise-into o1 o2) + (apply-generic-r op (raise-into o1 o2) o2)) + ((raise-into o2 o1) + (apply-generic-r op o2 (raise-into o2 o1))) + (t (no-method type-tags)))) + (no-method type-tags)))))) blob - /dev/null blob + 52f2735a0097040b10efffe684ea5facfd190c91 (mode 644) --- /dev/null +++ ex2-84-sol.scm~ @@ -0,0 +1,3 @@ +(define (find-highest-type l) + (define (filter-type t f) + (cond ((null? f) blob - /dev/null blob + 8edc8350eaaf52ff24fa960a8c982faff9893c20 (mode 644) --- /dev/null +++ ex2-84.scm @@ -0,0 +1,459 @@ +;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex). + +;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex + +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +;; (define coercion-table (make-table)) +;; (define get-coercion (coercion-table 'lookup-proc)) +;; (define put-coercion (coercion-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + + + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; (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))))))) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; (cons arg1 arg2) +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) + +;; (test-case (raise-to-second-type (make-integer 5) +;; (make-complex-from-real-imag 4 6)) +;; '((complex rectangular 5 . 0) . (complex rectangular 4 . 6))) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3) +;; (make-complex-from-real-imag 2 3)) +;; '((complex polar 4 . 3) . (complex rectangular 2 . 3))) +;; (test-case (raise-to-second-type (make-rational 5 3) +;; (make-integer 2)) +;; #f) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3) +;; (make-rational 2 6)) +;; #f) +;; (test-case (raise-to-second-type (make-rational 4 2) +;; (make-real 4.5)) +;; '(2. . 4.5)) + +;; (define (apply-generic op . args) +;; ;; return arg1 raised to same type as arg2, #f if not possible +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; (cons arg1 arg2) +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) +;; (let* ((type-tags (map type-tag args)) +;; (proc (get op type-tags))) +;; (if proc +;; (apply proc (map contents args)) +;; (if (= (length args) 2) +;; (let ((a1 (car args)) +;; (a2 (cadr args))) +;; (if (eq? (type-tag a1) (type-tag a2)) +;; (error "No method for these common types" (list op type-tags)) +;; (let ((raised-pair (or (raise-to-second-type a1 a2) +;; (raise-to-second-type a2 a1)))) +;; (if raised-pair +;; (let ((raised1 (car raised-pair)) +;; (raised2 (cdr raised-pair))) +;; (apply-generic op raised1 raised2)) +;; (error "No common supertype" +;; (list op type-tags)))))) ;; error messages may not be accurate +;; (error "No method for these (≠2) types" +;; (list op type-tags))))) ;; error messages may not be accurate + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-rational 8 1)) +(test-case (div (make-integer 2) (make-real 5)) + 0.4) +(test-case (mul (make-complex-from-real-imag 3 4) + (make-integer 2)) + ...) + blob - /dev/null blob + 8edc8350eaaf52ff24fa960a8c982faff9893c20 (mode 644) --- /dev/null +++ ex2-84.scm~ @@ -0,0 +1,459 @@ +;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex). + +;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex + +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +;; (define coercion-table (make-table)) +;; (define get-coercion (coercion-table 'lookup-proc)) +;; (define put-coercion (coercion-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + + + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; (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))))))) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; (cons arg1 arg2) +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) + +;; (test-case (raise-to-second-type (make-integer 5) +;; (make-complex-from-real-imag 4 6)) +;; '((complex rectangular 5 . 0) . (complex rectangular 4 . 6))) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3) +;; (make-complex-from-real-imag 2 3)) +;; '((complex polar 4 . 3) . (complex rectangular 2 . 3))) +;; (test-case (raise-to-second-type (make-rational 5 3) +;; (make-integer 2)) +;; #f) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3) +;; (make-rational 2 6)) +;; #f) +;; (test-case (raise-to-second-type (make-rational 4 2) +;; (make-real 4.5)) +;; '(2. . 4.5)) + +;; (define (apply-generic op . args) +;; ;; return arg1 raised to same type as arg2, #f if not possible +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; (cons arg1 arg2) +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) +;; (let* ((type-tags (map type-tag args)) +;; (proc (get op type-tags))) +;; (if proc +;; (apply proc (map contents args)) +;; (if (= (length args) 2) +;; (let ((a1 (car args)) +;; (a2 (cadr args))) +;; (if (eq? (type-tag a1) (type-tag a2)) +;; (error "No method for these common types" (list op type-tags)) +;; (let ((raised-pair (or (raise-to-second-type a1 a2) +;; (raise-to-second-type a2 a1)))) +;; (if raised-pair +;; (let ((raised1 (car raised-pair)) +;; (raised2 (cdr raised-pair))) +;; (apply-generic op raised1 raised2)) +;; (error "No common supertype" +;; (list op type-tags)))))) ;; error messages may not be accurate +;; (error "No method for these (≠2) types" +;; (list op type-tags))))) ;; error messages may not be accurate + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-rational 8 1)) +(test-case (div (make-integer 2) (make-real 5)) + 0.4) +(test-case (mul (make-complex-from-real-imag 3 4) + (make-integer 2)) + ...) + blob - /dev/null blob + 2285530eed2a714a0c0dd7c41898d399fe6a9e92 (mode 644) --- /dev/null +++ ex2-84b.scm @@ -0,0 +1,449 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; arg1 +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) + +;; (test-case (raise-to-second-type (make-integer 5) +;; (make-complex-from-real-imag 4 6)) +;; '(complex rectangular 5. . 0)) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3) +;; (make-complex-from-real-imag 2 3)) +;; '(complex polar 4 . 3)) ;; should there be a decimal point after 4 and 3? +;; (test-case (raise-to-second-type (make-rational 5 3) +;; (make-integer 2)) +;; #f) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3) +;; (make-rational 2 6)) +;; #f) +;; (test-case (raise-to-second-type (make-rational 4 2) +;; (make-real 4.5)) +;; 2.) + +;; not going to call apply-generic recursively so we can get more informative error messages +;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages. + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these common types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 + (let ((proc (get op (list (type-tag raised1) (type-tag a2))))) + (if proc + (apply-generic proc raised1 a2) + (list "No procedure, even after raising first argument" + (list op type-tags))))) + (raised2 + (let ((proc (get op (list a1 (type-tag raised2))))) + (if proc + (apply-generic proc a1 raised2) + (list "No procedure, even after raising second argument" + (list op type-tags))))) + (else (list "No common supertype" (list op type-tags))))))))))) + + + +;; (test-case (add (make-integer 4) '(nonsense-type . 3)) +;; '("No common supertype" (add (integer nonsense-type)))) +;; (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) +;; '("No procedure, even after raising first argument" (dummy (integer real)))) +;; (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) +;; '("No procedure, even after raising second argument" (dummy (real integer)))) + + +;; (test-case (add (make-integer 5) (make-rational 3 1)) +;; (make-rational 8 1)) +;; (test-case (div (make-integer 2) (make-real 5)) +;; 0.4) +;; (test-case (mul (make-complex-from-real-imag 3 4) +;; (make-integer 2)) +;; ...) + + +;; begin previous tests +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) +;; end previous tests + blob - /dev/null blob + 4de56baf7b84065ffc2b7eb2f502656f718f4d2f (mode 644) --- /dev/null +++ ex2-84b.scm~ @@ -0,0 +1,462 @@ +;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex). + +;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex + +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) +;; (define coercion-table (make-table)) +;; (define get-coercion (coercion-table 'lookup-proc)) +;; (define put-coercion (coercion-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + + + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; (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))))))) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; (cons arg1 arg2) +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) + +;; (test-case (raise-to-second-type (make-integer 5) +;; (make-complex-from-real-imag 4 6)) +;; '((complex rectangular 5 . 0) . (complex rectangular 4 . 6))) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3) +;; (make-complex-from-real-imag 2 3)) +;; '((complex polar 4 . 3) . (complex rectangular 2 . 3))) +;; (test-case (raise-to-second-type (make-rational 5 3) +;; (make-integer 2)) +;; #f) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3) +;; (make-rational 2 6)) +;; #f) +;; (test-case (raise-to-second-type (make-rational 4 2) +;; (make-real 4.5)) +;; '(2. . 4.5)) + +;; not going to call apply-generic recursively so we can get more informative error messages +;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages. + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + (cons arg1 arg2) + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (error "No method for these common types" (list op type-tags)) + (let ((raised-pair (or (raise-to-second-type a1 a2) + (raise-to-second-type a2 a1)))) + (if raised-pair + (let ((raised1 (car raised-pair)) + (raised2 (cdr raised-pair))) + (apply-generic op raised1 raised2)) + (error "No common supertype" + (list op type-tags)))))) ;; error messages may not be accurate + (error "No method for these (≠2) types" + (list op type-tags))))) ;; error messages may not be accurate + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-rational 8 1)) +(test-case (div (make-integer 2) (make-real 5)) + 0.4) +(test-case (mul (make-complex-from-real-imag 3 4) + (make-integer 2)) + ...) + blob - /dev/null blob + c379d110ae817db8bb0f70581b026e16b489ffcd (mode 644) --- /dev/null +++ ex2-84c.scm @@ -0,0 +1,425 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +;; not going to call apply-generic recursively so we can get more informative error messages +;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages. + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these common types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 + (let ((proc (get op (list (type-tag raised1) (type-tag a2))))) + (if proc + (apply-generic proc raised1 a2) + (list "No procedure, even after raising first argument" + (list op type-tags))))) + (raised2 + (let ((proc (get op (list a1 (type-tag raised2))))) + (if proc + (apply-generic proc a1 raised2) + (list "No procedure, even after raising second argument" + (list op type-tags))))) + (else (list "No common supertype" (list op type-tags))))))))))) + + + +(test-case (add (make-integer 4) '(nonsense-type . 3)) + '("No common supertype" (add (integer nonsense-type)))) +(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) + '("No procedure, even after raising first argument" (dummy (integer real)))) +(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) + '("No procedure, even after raising second argument" (dummy (real integer)))) + + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-rational 8 1)) +(test-case (div (make-integer 2) (make-real 5)) + 0.4) +(test-case (mul (make-complex-from-real-imag 3 4) + (make-integer 2)) + ...) + + +;; begin previous tests +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) +;; end previous tests + blob - /dev/null blob + 2285530eed2a714a0c0dd7c41898d399fe6a9e92 (mode 644) --- /dev/null +++ ex2-84c.scm~ @@ -0,0 +1,449 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +;; (define (raise-to-second-type arg1 arg2) +;; (if (eq? (type-tag arg1) (type-tag arg2)) +;; arg1 +;; (let ((raise-proc (get 'raise (list (type-tag arg1))))) +;; (if raise-proc +;; (raise-to-second-type (raise-proc (contents arg1)) arg2) +;; #f)))) + +;; (test-case (raise-to-second-type (make-integer 5) +;; (make-complex-from-real-imag 4 6)) +;; '(complex rectangular 5. . 0)) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3) +;; (make-complex-from-real-imag 2 3)) +;; '(complex polar 4 . 3)) ;; should there be a decimal point after 4 and 3? +;; (test-case (raise-to-second-type (make-rational 5 3) +;; (make-integer 2)) +;; #f) +;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3) +;; (make-rational 2 6)) +;; #f) +;; (test-case (raise-to-second-type (make-rational 4 2) +;; (make-real 4.5)) +;; 2.) + +;; not going to call apply-generic recursively so we can get more informative error messages +;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages. + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these common types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 + (let ((proc (get op (list (type-tag raised1) (type-tag a2))))) + (if proc + (apply-generic proc raised1 a2) + (list "No procedure, even after raising first argument" + (list op type-tags))))) + (raised2 + (let ((proc (get op (list a1 (type-tag raised2))))) + (if proc + (apply-generic proc a1 raised2) + (list "No procedure, even after raising second argument" + (list op type-tags))))) + (else (list "No common supertype" (list op type-tags))))))))))) + + + +;; (test-case (add (make-integer 4) '(nonsense-type . 3)) +;; '("No common supertype" (add (integer nonsense-type)))) +;; (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) +;; '("No procedure, even after raising first argument" (dummy (integer real)))) +;; (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) +;; '("No procedure, even after raising second argument" (dummy (real integer)))) + + +;; (test-case (add (make-integer 5) (make-rational 3 1)) +;; (make-rational 8 1)) +;; (test-case (div (make-integer 2) (make-real 5)) +;; 0.4) +;; (test-case (mul (make-complex-from-real-imag 3 4) +;; (make-integer 2)) +;; ...) + + +;; begin previous tests +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) +;; end previous tests + blob - /dev/null blob + 3b4e5d043946a4d08e1569d397f1f0314d32cf4b (mode 644) --- /dev/null +++ ex2-84d.scm @@ -0,0 +1,409 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these (raised) types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 (apply-generic op raised1 a2)) + (raised2 (apply-generic op a1 raised2)) + (else (list "No common supertype" (list op type-tags))))))))))) + +(test-case (add (make-integer 4) '(nonsense-type . 3)) + '("No common supertype" (add (integer nonsense-type)))) +(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) + '("No method for these (raised) types" (dummy (real real)))) +(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) + '("No method for these (raised) types" (dummy (real real)))) + + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-rational 8 1)) +(test-case (div (make-integer 2) (make-real 5)) + 0.4) +(test-case (div (make-real 5) (make-integer 2)) + 2.5) + +(test-case (mul (div (make-complex-from-mag-ang 3 2) + (make-integer 3)) + (add (make-real 2.4) + (make-rational 4 3))) + '(complex polar 3.733333333334 . 2.)) + +;; begin previous tests +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) +;; end previous tests + blob - /dev/null blob + 676c8ebd49ab87c2cb21b0f8b6fe424a1c3468f6 (mode 644) --- /dev/null +++ ex2-84d.scm~ @@ -0,0 +1,411 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + + 'done) + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + 'done) + +(define (install-polynomial-package) + (define (tag x) (attach-tag 'polynomial x)) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) +(install-polynomial-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these (raised) types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 (apply-generic op raised1 a2)) + (raised2 (apply-generic op a1 raised2)) + (else (list "No common supertype" (list op type-tags))))))))))) + +(test-case (add (make-integer 4) '(nonsense-type . 3)) + '("No common supertype" (add (integer nonsense-type)))) +(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) + '("No method for these (raised) types" (dummy (real real)))) +(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) + '("No method for these (raised) types" (dummy (real real)))) + + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-rational 8 1)) +(test-case (div (make-integer 2) (make-real 5)) + 0.4) +(test-case (mul (div (make-complex-from-mag-ang 3 2) + (make-integer 3)) + (add (make-real 2.4) + (make-rational 4 3))) + '(complex polar 3.733333333334 . 2.)) + +;; begin previous tests +(test-case (equ? (add (make-integer 3) (make-integer 4)) + (sub (make-integer 12) (make-integer 5))) #t) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3))) #t) +(test-case (equ? (add (make-integer 3) (make-integer 3)) + (sub (make-integer 12) (make-integer 5))) #f) +(test-case (equ? (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 2))) #f) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 3)))) #t) +(test-case (=zero? (sub (div (make-integer 24) (make-integer 4)) + (mul (make-integer 2) (make-integer 4)))) #f) +(test-case (make-integer 5) 5) +(test-case (type-tag (make-integer 5)) 'integer) +(test-case (type-tag (make-real 5)) 'real) +(test-case (make-real 1.66667) 1.66667) +(test-case (make-real (/ 5 3)) 1.66667) +(test-case (type-tag (make-real (/ 5 3))) 'real) + +(test-case (div (make-integer 3) (make-integer 4)) 0) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6))))) #t) +(test-case (=zero? (sub (make-rational 4 1) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 5))))) #f) +(test-case (equ? (add (make-rational 7 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 2 6)))) #t) +(test-case (equ? (add (make-rational 3 2) + (make-rational 2 4)) + (div (add (make-rational 1 2) + (make-rational 3 2)) + (mul (make-rational 3 2) + (make-rational 1 6)))) #f) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 4)))) #t) +(test-case (equ? (div (make-rational 4 2) + (make-rational 1 3)) + (sub (make-rational 9 1) + (mul (make-rational 4 1) + (make-rational 3 5)))) #f) +(test-case (equ? (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #t) +(test-case (equ? (add (make-complex-from-real-imag 3 4.5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1)) + #f) +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #t) + +(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5) + (make-complex-from-real-imag -5 -3)) + '(complex rectangular -2 . 1))) + #f) + + +(test-case (raise (make-integer 5)) '(rational 5 . 1)) +(test-case (raise (raise (make-integer 5))) 5.) +(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0)) + +(test-case (raise (make-rational 5 3)) 1.666667) +(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0)) +;; end previous tests + blob - /dev/null blob + 9eb021685643b263ceefdc7a1e976f63d0f2e707 (mode 644) --- /dev/null +++ ex2-85-sol.scm @@ -0,0 +1,423 @@ +(define (install-rational-package) + (define (rational->integer r) + (make-integer (quotient (numer r) (denom r)))) + (put-coercion 'rational 'integer rational->integer) + 'done) +(define (install-real-package) + (define (real->rational r) + (make-rational (inexact->exact (numerator r)) + (inexact->exact (denominator r)))) + (put-coercion 'real 'rational real->rational) + 'done) +(define (install-complex-package) + (define (complex->real z) + (make-real (complex-real-part z))) + (put-coercion 'complex 'real complex->real) + 'done) + +(define (apply-raise x types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise x (cdr types))))) +(define (raise x) + (apply-raise x tower-of-types)) +(define (project x) + (apply-raise x (reverse tower-of-types))) +(define (project x) + (define (apply-project types) + (cond ((eq? (type-tag x) (car types)) x) + ((or (null? types) (null? (cdr types))) + (error "type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (cadr types)) + (let ((projector (get-coercion (type-tag x) (car types)))) + (if projector + (projector (contents x)) + (error "No coercion procedure found for types" + (list (car types) (type-tag x)))))) + (else (apply-project (cdr types))))) + (apply-project tower-of-types)) + + +(define (install-rational-package) + (define (rational->integer r) + (make-integer (round (/ (numer r) (denom r))))) + (put-coercion 'rational 'integer rational->integer) + 'done) + +(define (install-real-package) + (define (real->rational r) + (make-rational (inexact->exact (numerator r)) + (inexact->exact (denominator r)))) + (put-coercion 'real 'rational real->rational) + 'done) + +(define (install-complex-package) + (define (complex->real z) + (make-real (complex-real-part z))) + (put-coercion 'complex 'real complex->real) + 'done) + +(define (apply-raise x types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedures found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise x (cdr types))))) + +(define (raise x) + (apply-raise x tower-of-types)) +(define (project x) + (apply-raise x (reverse tower-of-types))) + +(define (project x) + (define (apply-project types) + (cond ((eq? (type-tag x) (car types)) x) + ((or (null? types) (null? (cdr types))) + (error "type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + +(define (make-rat n d) + (if (and (integer? n) (integer? d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))) + (error "non-integer numerator of denominator" + (list n d)))) + +(define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons x y) + (error "non-real real or imaginary value" (list x y)))) + +(define (make-from-mag-ang r a) + (if (and (real? r) (real? a)) + (cons (* r (cos a)) (* r (sin a))) + (error "non-real magnitude or angle" (list r a)))) + +(define (make-from-mag-ang r a) + (if (and (in-tower? r) (in-tower? a)) + (cons r a) + (error "non-real magnitude or angle" (list r a)))) +(define (make-from-real-imag x y) + (if (and (in-tower? x) (in-tower? y)) + (cons (sqrt (+ (square x) (square y))) + (atan y x)) + (error "non-real real or imaginary value" (list x y)))) + +(define (integer->rational i) (make-rational i 1)) +(define (rational->real r) (make-real (/ (numer r) (denom r)))) +(define (real->complex r) (make-complex-from-real-imag r 0)) +(define (raise x) (apply-geeric 'raise x)) + +(define (tower-of-types '(integer rational real complex)) +(define (raise x) + (define (apply-raise types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list x tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types)))))) + (else (apply-raise (cdr types)))))) + (apply-raise tower-of-types)) +(put-coercion 'integer 'rational integer->rational) +(put-coercion 'rational 'real rational->real) +(put-coercion 'real 'complex real->complex) + +(define (find-highest-type l) + (define (filter-type t f) + (cond ((null? f) '()) + ((eq? (car f) t) (filter-type t (cdr f))) + (else (cons (car f) (filter-type t (cdr f)))))) + (define (find-highest highest remaining-tower remaining-list) + (cond ((null? remaining-list) highest) + ((null? remaining-tower) + (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE" + remaining-list)) + (else (find-highest (car remaining-tower) + (cdr remaining-tower) + (filter-type (car remaining-tower) remaining-list))))) + (find-highest #f tower-of-types l)) + +(find-highest-type '(integer real ratinoal real)) +(find-highest-type '(rational rational rational)) +(find-highest-type '(complex real rational integer)) +(find-highest-type '()) +(find-highest-type '(integer wibble real wobble complex)) +(define (raise-to type value) + (cond ((eq? type (type-tag value)) value) + ((memq type tower-of-types) (raise-to type (raise value))) + (else (error "Cannot raise to non-tower type -- RAISE-TO" + (list type tower-of-types))))) +(raise-to 'real (make-integer 4) +(raise-to 'complex (make-rational 3 4)) +(raise-to 'real (make-real 3.14159)) +(raise-to 'wibble (make-integer 42)) +(define (raise-all-to type values) + (if (null? values) + '() + (cons (raise-to type (car values)) (raise-all-to type (cdr values))))) +(raise-all-to 'real (list (make-integer 42) (make-real 3.14159) (make-rational 3 4))) +(raise-all-to 'complex '()) +(raise-all-to 'wibble (list (make-integer 123))) + +(define (apply-generic op . args) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (> (length args) 1) + (let* ((highest-type (find-highest-type type-tags)) + (mapped-args (raise-all-to highest-type args)) + (mapped-types (map type-tag mapped-args)) + (mapped-proc (get op mapped-types))) + (if mapped-proc + (apply mapped-proc (map contents mapped-args)) + (error "No method for these types -- APPLY-GENERIC" + (list op type-tags)))))))) + +(define (install-integer-package) + (put 'addd '(integer integer integer) + (lambda (x y z) (tag (+ x y z))))) + +(put 'addd '(rational rational rational) + (lambda (x y z) (tag (addd x y z)))) +(put 'addd '(real real real) + (lambda (x y z) (tag (+ x y z)))) + +(define (rational->integer r) (make-integer (round (/ (numer r) (denom r))))) +(put-coercion 'rational 'integer rational->integer) +(define (real->rational r) (make-rational (inexact->exact (numerator r)) + (inexact->exact (denominator r)))) +(put-coercion 'real 'rational real->rational) + +(define (complex->real z) (make-real (complex-real-part z))) +(put-coercion 'complex 'real complex->real) + +(define (apply-raise x types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise x (cdr types))))) + +(define (raise x) + (apply-raise x tower-of-types)) +(define (project x) + (apply-raise x (reverse tower-of-types))) + +(define (project x) + (define (apply-project types) + (cond ((eq? (type-tag x) (car types)) x) + ((or (null? types) (null? (cdr types))) + (error "type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (cadr types)) + (let ((projector (get-coercion (type-tag x) (car types)))) + (if projector + (projector (contents x)) + (error "No coercion procedure found for types" + (list (car types) (type-tag x)))))) + (else (apply-project (cdr types))))) + (apply-project tower-of-types)) +(project (make-real 3.5)) +(project (Make-rational 7 3)) +(raise (project (make-real 3.5))) +(raise (project (make-rational 7 3))) +(define (drop x) + (let* ((dropped (project x)) + (raised (raise dropped))) + (if (and (not (eq? (type-tag x) (type-tag dropped))) + (equ? x raised)) + (drop dropped) + x))) + +(define (apply-generic op . args) + (define (find-and-apply-op) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (> (length args) 1) + (let* ((highest-type (find-highest-type type-tags)) + (mapped-args (raise-all-to highest-type args)) + (mapped-types (map type-tag mapped-args)) + (mapped-proc (get op mapped-types))) + (if mapped-proc + (apply mapped-proc (map contents mapped-args)) + (error + "No method for these types -- APPLY-GENERIC" + (list op type-tags)))))))) + (let ((result (find-and-apply-op))) + (if (and (pair? result) + (memq (type-tag result) tower-of-types)) + (drop result) + result))) + +(define (apply-raise x types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise x (cdr types))))) +(define (raise x) + (apply-raise x tower-of-types)) +(define (project x) + (apply-raise x (reverse tower-of-types))) +(define (project x) + (define (apply-project types) + (cond ((eq? (type-tag x) (car types)) x) + ((or (null? types) (null? (cdr types))) + (error "type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (cadr types)) + (let ((projector (get-coercion (type-tag x) (car types)))) + (if projector + (projector (contents x)) + (error "No coercion procedure found for types" + (list (car types) (type-tag x)))))) + (else (apply-project (cdr types))))) + (apply-project tower-of-types)) + +(define (drop x) + (let* ((dropped (project x)) + (raised (raise dropped))) + (if (and (not (eq? (type-tag x) (type-tag dropped))) + (equ? x raised)) + (drop dropped) + x))) + +(define (apply-generic op . args) + (define (find-and-apply-op) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (if (> (length args) 1) + (let* ((highest-type (find-highest-type type-tags)) + (mapped-args (raise-all-to highest-type args)) + (mapped-types (map type-tag mapped-args)) + (mapped-proc (get op mapped-types))) + (if mapped-proc + (apply-mapped-proc (map contents mapped-args)) + (error "No method for these types -- APPLY-GENERIC" + (list op type-tags)))))))) + (let ((result (find-and-apply-op))) + (if (and (pair? result) + (memq (type-tag result) tower-of-types)) + (drop result) + result))) + +(define (integer->rational n) + (make-rational n 1)) +(put 'raise '(integer) + (lambda (i) (integer->rational i))) +(define (rational->real r) + (make-real + (exact->inexact + (/ (numer r) (denom r))))) +(put 'raise '(rational) + (lambda (r) (rational->real r))) +(define (real->complex r) + (make-complex-from-real-imag r 0)) +(put 'raise '(real) + (lambda (r) (real->complex r))) +(define (raise x) + (apply-generic 'raise x)) + +(define (apply-generic-r op . args) + (define (no-method type-tags) + (error "No method for these types" + (list op type-tags))) + (define (raise-into s t) + (let ((s-type (type-tag s)) + (t-type (type-tag t))) + (cond + ((equal? s-type t-type) s) + ((get 'raise (list s-type)) + (raise-into ((get 'raise (list s-type)) (contents s)) t)) + (t #f)))) + (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 ((o1 (car args)) + (o2 (cadr args))) + (cond ((raise-into o1 o2) + (apply-generic-r op (raise-into o1 o2) o2)) + ((raise-into o2 o1) + (apply-generic-r op o1 (raise-into o2 o1))) + (t (no-method type-tags)))) + (no-method type-tags))))) + +(put 'project '(rational) + (lambda (r) + (make-scheme-number + (floor (/ (numer r) (denom r)))))) +(put 'project '(real) + (lambda (r) + (let ((scheme-rat + (rationalize + (inexact->exact r) 1/100))) + (make-rational (numerator scheme-rat) + (denominator scheme-rat))))) +(put 'project '(complex) + (lambda (c) (make-real (real-part c)))) + +(define (drop num) + (let ((project-proc + (get 'project (list (type-tag num))))) + (if project-proc + (let ((dropped (project-proc (contents num)))) + (if (equ? num (raise dropped)) + (drop dropped) + num)) + num))) +(define (apply-generic-r op . args) + (define (no-method type-tags) + (error "No method for these types" + (list op type-tags))) + (define (raise-into s t) + "Tries to raise s into the type of t. On success, + returns the raised s. Otherwise, returns #f" + (let ((s-type (type-tag s)) + (t-type (type-tag t))) + (cond ((equal? s-type t-type) s) + ((get 'raise (list s-type)) + (raise-into ((get 'raise (list s-type)) blob - /dev/null blob + b0d98ad225e5eaa81d918bb6b6242c72266117e3 (mode 644) --- /dev/null +++ ex2-85-sol.scm~ @@ -0,0 +1,94 @@ +(define (install-rational-package) + (define (rational->integer r) + (make-integer (quotient (numer r) (denom r)))) + (put-coercion 'rational 'integer rational->integer) + 'done) +(define (install-real-package) + (define (real->rational r) + (make-rational (inexact->exact (numerator r)) + (inexact->exact (denominator r)))) + (put-coercion 'real 'rational real->rational) + 'done) +(define (install-complex-package) + (define (complex->real z) + (make-real (complex-real-part z))) + (put-coercion 'complex 'real complex->real) + 'done) + +(define (apply-raise x types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedure found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise x (cdr types))))) +(define (raise x) + (apply-raise x tower-of-types)) +(define (project x) + (apply-raise x (reverse tower-of-types))) +(define (project x) + (define (apply-project types) + (cond ((eq? (type-tag x) (car types)) x) + ((or (null? types) (null? (cdr types))) + (error "type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (cadr types)) + (let ((projector (get-coercion (type-tag x) (car types)))) + (if projector + (projector (contents x)) + (error "No coercion procedure found for types" + (list (car types) (type-tag x)))))) + (else (apply-project (cdr types))))) + (apply-project tower-of-types)) + + +(define (install-rational-package) + (define (rational->integer r) + (make-integer (round (/ (numer r) (denom r))))) + (put-coercion 'rational 'integer rational->integer) + 'done) + +(define (install-real-package) + (define (real->rational r) + (make-rational (inexact->exact (numerator r)) + (inexact->exact (denominator r)))) + (put-coercion 'real 'rational real->rational) + 'done) + +(define (install-complex-package) + (define (complex->real z) + (make-real (complex-real-part z))) + (put-coercion 'complex 'real complex->real) + 'done) + +(define (apply-raise x types) + (cond ((null? types) + (error "Type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) + ((eq? (type-tag x) (car types)) + (if (null? (cdr types)) + x + (let ((raiser (get-coercion (type-tag x) (cadr types)))) + (if raiser + (raiser (contents x)) + (error "No coercion procedures found for types" + (list (type-tag x) (cadr types))))))) + (else (apply-raise x (cdr types))))) + +(define (raise x) + (apply-raise x tower-of-types)) +(define (project x) + (apply-raise x (reverse tower-of-types))) + +(define (project x) + (define (apply-project types) + (cond ((eq? (type-tag x) (car types)) x) + ((or (null? types) (null? (cdr types))) + (error "type not found in the tower-of-types" + (list (type-tag x) tower-of-types))) blob - /dev/null blob + d9ca5c7b503f33102ebca67eec162748e5350e11 (mode 644) --- /dev/null +++ ex2-85.scm @@ -0,0 +1,366 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) +(define (project x) (apply-generic 'project x)) + + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + (put 'project '(integer) + (lambda (x) #f)) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + (put 'project '(rational) + (lambda (x) (make-integer (quotient (numer x) (denom x))))) + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + (put 'project '(real) + (lambda (x) (make-rational (inexact->exact (numerator x)) + (inexact->exact (denominator x))))) + 'done) + + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + (put 'project '(complex) + (lambda (z) (make-real (real-part z)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.85. This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible. + +;; Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered: + +;; Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers. + +(define (drop x) + (let ((projected-x (project x))) + (if (and projected-x + (equ? x (raise projected-x))) + (drop projected-x) + x))) + +(test-case (drop (make-complex-from-mag-ang 5 0)) + 5) +(test-case (drop (make-rational 3 5)) + '(rational 3 . 5)) +(test-case (drop (make-complex-from-real-imag 5/3 0)) + '(rational 5 . 3)) +(test-case (drop (make-complex-from-mag-ang (sqrt 5) 0)) + 2.23606797749979) + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (drop (apply proc (map contents args))) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these (raised) types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 (apply-generic op raised1 a2)) + (raised2 (apply-generic op a1 raised2)) + (else (list "No common supertype" (list op type-tags))))))))))) + + + +(test-case (add (make-integer 4) '(nonsense-type . 3)) + '("No common supertype" (add (integer nonsense-type)))) +(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) + '("No method for these (raised) types" (dummy (real real)))) +(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) + '("No method for these (raised) types" (dummy (real real)))) + + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-integer 8)) +(test-case (div (make-integer 2) (make-real 5)) + (make-rational 2 5)) +(test-case (div (make-real 5) (make-integer 2)) + (make-rationa 1 2)) +(test-case (mul (div (make-complex-from-mag-ang 3 2) + (make-integer 3)) + (add (make-real 2.4) + (make-rational 4 3))) + '(complex polar 3.733333333334 . 2.)) + + +;; Of course, we should note that not all installed procedures return a tagged value. After all, we're using equ? as part of drop. So we should only apply drop to the result if we've got a tagged type. We can test that by checking to see if the result is a pair? whose car is in the tower-of-types. + +;; what happens when we are at the lowest rung in the tower of types? if we project then raise, do we end up with the lowest type or the second type? does this result in an infinite loop? + +;; use (rationalize (inexact->exact r) 1/100) to get 1/3 to rationalize properly blob - /dev/null blob + cdd461cfa7175a02b180e6a8b3479b8cfcaa62e7 (mode 644) --- /dev/null +++ ex2-85.scm~ @@ -0,0 +1,359 @@ +(define (attach-tag type-tag contents) + (if (or (eq? type-tag 'integer) + (eq? type-tag 'real)) + contents + (cons type-tag contents))) +(define (type-tag datum) + (cond ((pair? datum) (car datum)) + ((exact? datum) 'integer) + ((number? datum) 'real) + ((error "error -- invalid datum" datum)))) +(define (contents datum) + (cond ((pair? datum) (cdr datum)) + ((exact? datum) datum) + ((number? datum) (exact->inexact datum)) + ((error "error -- invalid datum" datum)))) + +(define (make-table) + (define (assoc key records) + (cond ((null? records) false) + ((equal? key (caar records)) (car records)) + (else (assoc key (cdr records))))) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +(define operation-table (make-table)) +(define get (operation-table 'lookup-proc)) +(define put (operation-table 'insert-proc!)) + +(define (add x y) (apply-generic 'add x y)) +(define (sub x y) (apply-generic 'sub x y)) +(define (mul x y) (apply-generic 'mul x y)) +(define (div x y) (apply-generic 'div x y)) +(define (equ? x y) (apply-generic 'equ? x y)) +(define (=zero? x) (apply-generic '=zero? x)) +(define (raise x) (apply-generic 'raise x)) +(define (project x) (apply-generic 'project x)) + + +(define (install-integer-package) + (define (tag x) (attach-tag 'integer x)) + (put 'add '(integer integer) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(integer integer) + (lambda (x y) (tag (- x y)))) + (put 'mul '(integer integer) + (lambda (x y) (tag (* x y)))) + (put 'div '(integer integer) + (lambda (x y) (tag (quotient x y)))) + ;; (if (integer? (/ x y)) + ;; (tag (/ x y)) + ;; (div (raise (tag x)) + ;; (raise (tag y)))))) + ;; ;; we avoided calling make-rational to avoid dependencies + (put 'equ? '(integer integer) =) + (put '=zero? '(integer) zero?) + (put 'make 'integer + (lambda (n) + (if (exact? n) + (tag n) + (error "Not an exact integer" n)))) + (put 'raise '(integer) + (lambda (x) (make-rational x 1))) + (put 'project '(integer) + (lambda (x) #f)) + 'done) + +(define (install-rational-package) + (define (gcd a b) + (if (= b 0) + a + (gcd b (remainder a b)))) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (if (not (and (integer? n) (integer? d))) + (error "Both numerator and denominator must be integers" + (list n d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))))) + (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 (equ-rat? x y) + (and (= (numer x) (numer y)) + (= (denom x) (denom y)))) + (define (=zero-rat? x) (= (numer x) 0)) + (define (tag x) (attach-tag 'rational x)) + (put 'add '(rational rational) + (lambda (x y) (tag (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tag (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tag (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tag (div-rat x y)))) + (put 'equ? '(rational rational) equ-rat?) + (put '=zero? '(rational) =zero-rat?) + (put 'make 'rational + (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) + (lambda (x) (make-real (/ (numer x) (denom x))))) + (put 'project '(rational) + (lambda (x) (make-integer (quotient (numer x) (denom x))))) + 'done) + +(define (install-real-package) + (define (tag x) (attach-tag 'real x)) + (put 'add '(real real) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(real real) + (lambda (x y) (tag (- x y)))) + (put 'mul '(real real) + (lambda (x y) (tag (* x y)))) + (put 'div '(real real) + (lambda (x y) (tag (/ x y)))) + (put 'equ? '(real real) =) + (put '=zero? '(real) zero?) + (put 'make 'real + (lambda (n) + (if (rational? n) + (tag (exact->inexact n)) + (tag n)))) + (put 'raise '(real) + (lambda (x) (make-complex-from-real-imag x 0))) + (put 'project '(real) + (lambda (x) (make-rational (inexact->exact (numerator x)) + (inexact->exact (denominator x))))) + 'done) + + +(define (install-complex-package) + (define (make-from-real-imag x y) + ((get 'make-from-real-imag 'rectangular) x y)) + (define (make-from-mag-ang r a) + ((get 'make-from-mag-ang 'polar) r a)) + + (define (real-part z) (apply-generic 'real-part z)) + (define (imag-part z) (apply-generic 'imag-part z)) + (define (magnitude z) (apply-generic 'magnitude z)) + (define (angle z) (apply-generic 'angle z)) + + ;; rectangular and polar representations... + + (define (install-complex-rectangular) + (define (make-from-real-imag-rectangular x y) + (cons x y)) + (define (make-from-mag-ang-rectangular r a) + (cons (* r (cos a)) (* r (sin a)))) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) (atan (imag-part z) (real-part z))) + (define (tag x) (attach-tag 'rectangular x)) + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-real-imag 'rectangular + (lambda (x y) (tag (make-from-real-imag-rectangular x y)))) + (put 'make-from-mag-ang 'rectangular + (lambda (r a) (tag (make-from-mag-ang-rectangular r a)))) + 'done) + (define (install-complex-polar) + (define (make-from-real-imag-polar x y) + (cons (sqrt (+ (square x) (square y))) + (atan y x))) + (define (make-from-mag-ang-polar r a) + (cons r a)) + (define (real-part z) (* (magnitude z) (cos (angle z)))) + (define (imag-part z) (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag x) (attach-tag 'polar x)) + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-real-imag 'polar + (lambda (x y) (tag (make-from-real-imag-polar x y)))) + (put 'make-from-mag-ang 'polar + (lambda (r a) (tag (make-from-mag-ang-polar r a)))) + 'done) + (install-complex-rectangular) + (install-complex-polar) + ;; end rectangular and polar representations + + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + (define (equ-complex? z1 z2) + (or (and (= (real-part z1) (real-part z2)) + (= (imag-part z1) (imag-part z2))) ;; in case of rounding error + (and (= (magnitude z1) (magnitude z2)) + (= (angle z1) (angle z2))))) + (define (=zero-complex? z) + (and (= (real-part z) 0) + (= (imag-part z) 0))) + + (define (tag x) (attach-tag 'complex x)) + (put 'add '(complex complex) + (lambda (z1 z2) (tag (add-complex z1 z2)))) + (put 'sub '(complex complex) + (lambda (z1 z2) (tag (sub-complex z1 z2)))) + (put 'mul '(complex complex) + (lambda (z1 z2) (tag (mul-complex z1 z2)))) + (put 'div '(complex complex) + (lambda (z1 z2) (tag (div-complex z1 z2)))) + (put 'equ? '(complex complex) equ-complex?) + (put '=zero? '(complex) =zero-complex?) + (put 'make-from-real-imag 'complex + (lambda (x y) (tag (make-from-real-imag x y)))) + (put 'make-from-mag-ang 'complex + (lambda (r a) (tag (make-from-mag-ang r a)))) + (put 'project '(complex) + (lambda (z) (make-real (real-part z)))) + 'done) + +(define (make-integer n) + ((get 'make 'integer) n)) +(define (make-rational n d) + ((get 'make 'rational) n d)) +(define (make-real n) + ((get 'make 'real) n)) +(define (make-complex-from-real-imag x y) + ((get 'make-from-real-imag 'complex) x y)) +(define (make-complex-from-mag-ang r a) + ((get 'make-from-mag-ang 'complex) r a)) + +;; install number packages + +(install-integer-package) +(install-rational-package) +(install-real-package) +(install-complex-package) + +(define (test-case actual expected) + (newline) + (display "Actual: ") + (display actual) + (newline) + (display "Expected: ") + (display expected) + (newline)) + +;; Exercise 2.85. This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible. + +;; Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered: + +;; Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers. + +(define (drop x) + (let ((projected-x (project x))) + (if (and projected-x + (equ? x (raise projected-x))) + (drop projected-x) + x))) + +(test-case (drop (make-complex-from-mag-ang 5 0)) + 5) +(test-case (drop (make-rational 3 5)) + '(rational 3 . 5)) +(test-case (drop (make-complex-from-real-imag 5/3 0)) + '(rational 5 . 3)) +(test-case (drop (make-complex-from-mag-ang (sqrt 5) 0)) + 2.23606797749979) + +(define (apply-generic op . args) + ;; return arg1 raised to same type as arg2, #f if not possible + (define (raise-to-second-type arg1 arg2) + (if (eq? (type-tag arg1) (type-tag arg2)) + arg1 + (let ((raise-proc (get 'raise (list (type-tag arg1))))) + (if raise-proc + (raise-to-second-type (raise-proc (contents arg1)) arg2) + #f)))) + (let* ((type-tags (map type-tag args)) + (proc (get op type-tags))) + (if proc + (drop (apply proc (map contents args))) + (if (= (length args) 2) + (let ((a1 (car args)) + (a2 (cadr args))) + (if (eq? (type-tag a1) (type-tag a2)) + (list "No method for these (raised) types" (list op type-tags)) + (let ((raised1 (raise-to-second-type a1 a2)) + (raised2 (raise-to-second-type a2 a1))) + (cond (raised1 (apply-generic op raised1 a2)) + (raised2 (apply-generic op a1 raised2)) + (else (list "No common supertype" (list op type-tags))))))))))) + + + +(test-case (add (make-integer 4) '(nonsense-type . 3)) + '("No common supertype" (add (integer nonsense-type)))) +(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.)) + '("No method for these (raised) types" (dummy (real real)))) +(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3)) + '("No method for these (raised) types" (dummy (real real)))) + + +(test-case (add (make-integer 5) (make-rational 3 1)) + (make-integer 8)) +(test-case (div (make-integer 2) (make-real 5)) + (make-rational 2 5)) +(test-case (div (make-real 5) (make-integer 2)) + (make-rationa 1 2)) +(test-case (mul (div (make-complex-from-mag-ang 3 2) + (make-integer 3)) + (add (make-real 2.4) + (make-rational 4 3))) + '(complex polar 3.733333333334 . 2.)) blob - /dev/null blob + 944f1bf941ed82b4f8b89d4841370c865ff3a39a (mode 644) --- /dev/null +++ ex2-9.scm @@ -0,0 +1,43 @@ +(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)) + (