├── 1.2.ss ├── 2.6.ss ├── 3.1.rkt ├── 1.5.ss ├── 3.53.rkt ├── 2.27.ss ├── 2.23.ss ├── 2.32.ss ├── 2.4.ss ├── 2.7.ss ├── 3.54.rkt ├── 1.16.ss ├── 3.51.rkt ├── 3.55.rkt ├── 1.43.ss ├── 3.8.rkt ├── 2.30.ss ├── 2.31.ss ├── 1.42.ss ├── 2.1.ss ├── 2.17.ss ├── 2.18.ss ├── 3.61.rkt ├── 1.3.ss ├── 3.29.rkt ├── 1.37nc.ss ├── 3.19.rkt ├── 3.62.rkt ├── 3.64.rkt ├── 2.21.ss ├── 3.2.rkt ├── 1.32b.ss ├── 2.36.rkt ├── 1.35.ss ├── 3.50.rkt ├── 2.75.ss ├── 3.37.rkt ├── 1.31b.ss ├── 1.31a.ss ├── 2.59.ss ├── 2.66.ss ├── 3.52.rkt ├── 2.87.rkt ├── 1.11.ss ├── 3.31.txt ├── 3.59.rkt ├── 1.44.ss ├── 2.5.ss ├── 1.8.ss ├── 3.5.rkt ├── 2.61.ss ├── 1.7.ss ├── 2.12.ss ├── 3.60.rkt ├── 2.8.ss ├── 3.71.rkt ├── 1.32a.ss ├── 1.21.ss ├── 3.66.rkt ├── 3.16.rkt ├── 3.28.rkt ├── 2.78.ss ├── 1.36.ss ├── 2.60.ss ├── .gitattributes ├── 3.68.rkt ├── 2.62.ss ├── 1.23.ss ├── 2.80.ss ├── 3.67.rkt ├── 2.3.ss ├── 3.3.rkt ├── 1.28.ss ├── 1.27.ss ├── 2.2.ss ├── 2.83.rkt ├── 1.6.ss ├── 1.45.ss ├── 3.69.rkt ├── 2.79.ss ├── 2.10.ss ├── 1.40.ss ├── 3.35.rkt ├── 3.56.rkt ├── 3.7.rkt ├── 2.88.rkt ├── 3.31.rkt ├── 3.17.rkt ├── 3.70.rkt ├── 2.29.ss ├── 2.81.rkt ├── queue.rkt ├── 3.21.rkt ├── 1.33.ss ├── wire.rkt ├── 3.4.rkt ├── 3.65.rkt ├── 2.74.ss ├── 2.69.rkt ├── 3.22.rkt ├── 2.58.ss ├── 2.84.rkt ├── 2.68.rkt ├── circuit.rkt ├── 3.24.rkt ├── 1.22.ss ├── 2.67.ss ├── 2.73.ss ├── 2.89.rkt ├── 2.56.ss ├── 2.11.ss ├── stream.rkt ├── 2.57.ss ├── agenda.rkt ├── 2.70.rkt ├── 2.65.ss ├── .gitignore ├── 3.23.rkt └── 3.33.rkt /1.2.ss: -------------------------------------------------------------------------------- 1 | (/ (+ 5 4 2 | (- 2 3 | (- 3 (+ 6 (/ 4 5))))) 4 | (* 3 (- 6 2) (- 2 7))) -------------------------------------------------------------------------------- /2.6.ss: -------------------------------------------------------------------------------- 1 | (define one (lambda (f) (lambda (x) (f x)))) 2 | (define two (lambda (f) (lambda (x) (f (f x))))) -------------------------------------------------------------------------------- /3.1.rkt: -------------------------------------------------------------------------------- 1 | (define (make-accumulator n) 2 | (lambda (x) 3 | (begin (set! n (+ n x)) 4 | n))) -------------------------------------------------------------------------------- /1.5.ss: -------------------------------------------------------------------------------- 1 | (define (p) (p)) 2 | 3 | (define (test x y) 4 | (if (= x 0) 5 | 0 6 | y)) 7 | 8 | (test 0 (p)) -------------------------------------------------------------------------------- /3.53.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | ; generic the 2^n list 4 | (define s (cons-stream 1 (add-stream s s))) 5 | 6 | -------------------------------------------------------------------------------- /2.27.ss: -------------------------------------------------------------------------------- 1 | (define (deep-reverse list) 2 | (reverse (map reverse list))) 3 | 4 | (define x (list (list 1 2) (list 3 4))) 5 | -------------------------------------------------------------------------------- /2.23.ss: -------------------------------------------------------------------------------- 1 | (define (for_each proc items) 2 | (if (null? items) 3 | nil 4 | ((proc (car items)) 5 | (for_each proc (cdr items))))) -------------------------------------------------------------------------------- /2.32.ss: -------------------------------------------------------------------------------- 1 | (define (subsets s) 2 | (if (null? s) 3 | (list '()) 4 | (let ((rest (subsets (cdr s)))) 5 | (append rest (map subsets rest))))) -------------------------------------------------------------------------------- /2.4.ss: -------------------------------------------------------------------------------- 1 | (define (cons x y) 2 | (lambda (m) (m x y))) 3 | 4 | (define (car z) 5 | (z (lambda (p q) p))) 6 | 7 | (define (cdr z) 8 | (z (lambda (p q) q))) -------------------------------------------------------------------------------- /2.7.ss: -------------------------------------------------------------------------------- 1 | (define (make-interval a b) (cons a b)) 2 | 3 | (define (upper-bound i) (max (car i) (cdr i))) 4 | (define (lower-bound i) (min (car i) (cdr i))) 5 | -------------------------------------------------------------------------------- /3.54.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (mul-streams s1 s2) 4 | (stream-map * s1 s2)) 5 | 6 | (define factorials (cons-stream 1 (mul-streams integers factorials))) 7 | -------------------------------------------------------------------------------- /1.16.ss: -------------------------------------------------------------------------------- 1 | (define (_expt b n) 2 | (expt-iter b 1 n)) 3 | 4 | (define (expt-iter a b count) 5 | (if (= count 0) 6 | b 7 | (expt-iter a (* a b) (- count 1)))) 8 | 9 | -------------------------------------------------------------------------------- /3.51.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (show x) 4 | (display-line x) 5 | x) 6 | 7 | (define x (stream-map show (stream-enumerate-interval 0 10))) 8 | 9 | (stream-ref x 5) -------------------------------------------------------------------------------- /3.55.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (partial-sums stream) 4 | (cons-stream 5 | (stream-car stream) 6 | (add-streams (stream-cdr stream) (partial-sums stream)))) 7 | -------------------------------------------------------------------------------- /1.43.ss: -------------------------------------------------------------------------------- 1 | (define (repeated f n) 2 | (if (= n 1) 3 | f 4 | (compose (repeated f (- n 1)) f))) 5 | 6 | (define square 7 | (lambda (x) (* x x))) 8 | 9 | ((repeated square 2) 5) -------------------------------------------------------------------------------- /3.8.rkt: -------------------------------------------------------------------------------- 1 | (define (f x) 2 | (let ((value 0)) 3 | (cond ((= x 0) (set! value (+ value 1)) value) 4 | ((= value 1) (set! value (- value 1)) value) 5 | (else value)))) 6 | -------------------------------------------------------------------------------- /2.30.ss: -------------------------------------------------------------------------------- 1 | (define (square-tree tree) 2 | (map (lambda (sub-tree) 3 | (if (pair? sub-tree) 4 | (square-tree sub-tree) 5 | (lambda (x) (* x x)))) 6 | tree)) -------------------------------------------------------------------------------- /2.31.ss: -------------------------------------------------------------------------------- 1 | (define (tree-map proc tree) 2 | (map (lambda (sub-tree) 3 | (if (pair? sub-tree) 4 | (tree-map proc sub-tree) 5 | (proc sub-tree))) 6 | tree)) -------------------------------------------------------------------------------- /1.42.ss: -------------------------------------------------------------------------------- 1 | (define (compose f g) 2 | (lambda (x) 3 | (f (g x)))) 4 | 5 | (define square 6 | (lambda (x) (* x x))) 7 | 8 | (define inc 9 | (lambda (x) (+ x 1))) 10 | 11 | ((compose square inc) 6) -------------------------------------------------------------------------------- /2.1.ss: -------------------------------------------------------------------------------- 1 | (define (make-rat n d) 2 | (let ((g (gcd n d))) 3 | (cond ((> (/ n d) 0) (cons (/ n g) (/ d g))) 4 | ((< n 0) (cons (/ n g) (/ d g))) 5 | (else (cons (- (/ n g)) (- (/ d g))))))) -------------------------------------------------------------------------------- /2.17.ss: -------------------------------------------------------------------------------- 1 | (define (last_pair items) 2 | (if (null? items) 3 | (error "Empty list") 4 | (let ((n (length items))) 5 | (if (= n 1) 6 | items 7 | (last_pair (cdr items)))))) -------------------------------------------------------------------------------- /2.18.ss: -------------------------------------------------------------------------------- 1 | (define (reverse-list items) 2 | (define (reverse-iter items result) 3 | (if (null? items) 4 | result 5 | (reverse-iter (cdr items) (cons (car items) result)))) 6 | (reverse-iter items (list))) -------------------------------------------------------------------------------- /3.61.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | (load "3.60.rkt") 3 | 4 | (define (recip-series s) 5 | (cons-stream 1 6 | (scale-stream 7 | (mul-series (stream-cdr s) (recip-series s)) 8 | -1))) -------------------------------------------------------------------------------- /1.3.ss: -------------------------------------------------------------------------------- 1 | (define a 6) 2 | (define b 7) 3 | (define c 5) 4 | (define (sum-of-big-two a b c) 5 | (cond ((and (> a c) (> b c)) (+ a b)) 6 | ((and (> a b) (> c b)) (+ a c)) 7 | (else (+ b c)))) 8 | (sum-of-big-two a b c) -------------------------------------------------------------------------------- /3.29.rkt: -------------------------------------------------------------------------------- 1 | (define (or-gate a1 a2 output) 2 | (let ((b1 (make-wire)) 3 | (b2 (make-wire)) 4 | (out (make-wire))) 5 | (inverter a1 b1) 6 | (inverter a2 b2) 7 | (and-gate b1 b2 out) 8 | (inverter out output))) -------------------------------------------------------------------------------- /1.37nc.ss: -------------------------------------------------------------------------------- 1 | (define (cont-frac n d k) 2 | (if (= k 1) 3 | (/ (n k) (d k)) 4 | (/ (n k) (+ (d k) (cont-frac (n (- k 1)) (d (- k 1)) (- k 1)))))) 5 | 6 | (cont-frac (lambda (i) 1.0) 7 | (lambda (i) 1.0) 8 | 20) -------------------------------------------------------------------------------- /3.19.rkt: -------------------------------------------------------------------------------- 1 | (define (cycle? x) 2 | (define (iter list) 3 | (cond ((or (null? list) (not (pair? list))) #f) 4 | ((or (eq? x (cdr list)) (cycle? (car list))) #t) 5 | (else 6 | (iter (cdr list))))) 7 | (iter x)) -------------------------------------------------------------------------------- /3.62.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | (load "3.60.rkt") 3 | (load "3.61.rkt") 4 | 5 | (define (div-series s1 s2) 6 | (if (= (stream-car s2) 0) 7 | (error "CONSTANT CAN'T BE ZERO -- s2" div-series) 8 | (mul-series s1 (recip-seires s2)))) -------------------------------------------------------------------------------- /3.64.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (stream-limit s tolerance) 4 | (cond ((stream-null? s) '()) 5 | ((< (abs (- (stream-ref s 0) (stream-ref s 1))) tolerance) 6 | (stream-car s)) 7 | (else 8 | (stream-limit (stream-cdr s) tolerance)))) -------------------------------------------------------------------------------- /2.21.ss: -------------------------------------------------------------------------------- 1 | (define (square-list-1 items) 2 | (define square 3 | (lambda (x) (* x x))) 4 | (if (null? items) 5 | (list) 6 | (cons (square (car items)) (square-list-1 (cdr items))))) 7 | 8 | (define (square-list-2 items) 9 | (map (lambda (x) (* x x)) 10 | items)) -------------------------------------------------------------------------------- /3.2.rkt: -------------------------------------------------------------------------------- 1 | (define (make-monitored f) 2 | (let ((counter 0)) 3 | (lambda (x) 4 | (cond ((eq? x 'how-many-calls?) counter) 5 | ((eq? x 'reset-count) (set! counter 0)) 6 | (else 7 | (begin (set! counter (+ counter 1)) 8 | (f x))))))) -------------------------------------------------------------------------------- /1.32b.ss: -------------------------------------------------------------------------------- 1 | (define (accumulate combiner null-value term a pre b) 2 | (if (> a b) 3 | null-value 4 | (combiner (accumulate combiner null-value term a pre (pre b)) 5 | (term b)))) 6 | 7 | (define (sum-integral a b) 8 | (define (sum-term n) n) 9 | (define (sum-pre n) (- n 1)) 10 | (accumulate + 0 sum-term a sum-pre b)) -------------------------------------------------------------------------------- /2.36.rkt: -------------------------------------------------------------------------------- 1 | (define (accumulate op init seq) 2 | (if (null? seq) 3 | init 4 | (op (car seq) 5 | (accumulate op init (cdr seq))))) 6 | 7 | (define (accumulate-n op init seqs) 8 | (if (null? (car seqs)) 9 | '() 10 | (cons (accumulate op init (map car seqs)) 11 | (accumulate-n op init (map cdr seqs))))) 12 | -------------------------------------------------------------------------------- /1.35.ss: -------------------------------------------------------------------------------- 1 | (define tolerance 0.00001) 2 | 3 | (define (fixed-point f first-guess) 4 | (define (close-enough? v1 v2) 5 | (< (abs (- v1 v2)) tolerance)) 6 | (define (try guess) 7 | (let ((next (f guess))) 8 | (if (close-enough? guess next) 9 | next 10 | (try next)))) 11 | (try first-guess)) 12 | 13 | (fixed-point (lambda (x) (+ (/ 1 x) 1)) 1.0) -------------------------------------------------------------------------------- /3.50.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (stream-map proc . argstreams) 4 | (if (stream-null? (car argstreams)) 5 | the-empty-stream 6 | (cons-stream 7 | (apply proc (map stream-car argstreams)) 8 | (apply stream-map 9 | (cons proc (map stream-cdr argstreams)))))) 10 | 11 | (stream-map + (stream 1 2 3) (stream 4 5 6) (stream 7 8 9)) -------------------------------------------------------------------------------- /2.75.ss: -------------------------------------------------------------------------------- 1 | (define (make-from-mag-ang r a) 2 | (define (dispatch op) 3 | (cond ((eq? op 'real-part) (* r (cos a))) 4 | ((eq? op 'imag-part) (* r (sin a))) 5 | ((eq? op 'magnitude) r) 6 | ((eq? op 'angle) a) 7 | (else 8 | (error "Unknow op -- MAKE-FROM-MAG-ANG" op)))) 9 | dispatch) 10 | 11 | (define (apply-generic op arg) (arg op)) -------------------------------------------------------------------------------- /3.37.rkt: -------------------------------------------------------------------------------- 1 | (define (c- x y) 2 | (let ((z (make-connector))) 3 | (adder y x z) 4 | z)) 5 | 6 | (define (c* x y) 7 | (let ((z (make-connector))) 8 | (multiplier x y z) 9 | z)) 10 | 11 | (define (c/ x y) 12 | (let ((z (make-connector))) 13 | (multiplier y z x) 14 | z)) 15 | 16 | (define (cv x) 17 | (let ((z (make-connector))) 18 | (constant x z) 19 | z)) -------------------------------------------------------------------------------- /1.31b.ss: -------------------------------------------------------------------------------- 1 | (define (product term a pre b) 2 | (if (> a b) 3 | 1 4 | (* (product term a pre (pre b)) (term b)))) 5 | 6 | (define (pi-product a b) 7 | (define (pi-term n) 8 | (cond ((= n 1) (/ 2.0 3.0)) 9 | ((even? n) (/ (+ n 2) (+ n 1))) 10 | (else (/ (+ n 1) (+ n 2))))) 11 | (define (pi-pre n) 12 | (- n 1)) 13 | (* (product pi-term a pi-pre b) 4)) -------------------------------------------------------------------------------- /1.31a.ss: -------------------------------------------------------------------------------- 1 | (define (product term a next b) 2 | (if (> a b) 3 | 1 4 | (* (term a) (product term (next a) next b)))) 5 | 6 | (define (pi-product a b) 7 | (define (pi-term n) 8 | (cond ((= n 1) (/ 2.0 3.0)) 9 | ((even? n) (/ (+ n 2) (+ n 1))) 10 | (else (/ (+ n 1) (+ n 2))))) 11 | (define (pi-next n) 12 | (+ n 1)) 13 | (* (product pi-term a pi-next b) 4)) -------------------------------------------------------------------------------- /2.59.ss: -------------------------------------------------------------------------------- 1 | (define (element-of-set? x set) 2 | (cond ((null? set) #f) 3 | ((equal? x (car set)) #t) 4 | (else (element-of-set? x (cdr set))))) 5 | 6 | (define (union-set set1 set2) 7 | (cond ((null? set1) set2) 8 | ((element-of-set? (car set1) set2) 9 | (union-set (cdr set1) set2)) 10 | (else 11 | (cons (car set1) (union-set (cdr set1) set2))))) 12 | -------------------------------------------------------------------------------- /2.66.ss: -------------------------------------------------------------------------------- 1 | (define (look-up given-key set-of-records) 2 | (cond ((null? set-of-records) #f) 3 | ((= given-key (key (entry set-of-records))) 4 | (entry set-of-records)) 5 | ((< given-key (key (entry set-of-records))) 6 | (look-up given-key (left-branch set-of-records))) 7 | ((> given-key (key (entry set-of-records))) 8 | (look-up given-key (right-branch set-of-records))))) -------------------------------------------------------------------------------- /3.52.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define sum 0) 4 | 5 | (define (accum x) 6 | (set! sum (+ x sum)) 7 | sum) 8 | 9 | (define seq (stream-map accum (stream-enumerate-interval 1 20))) 10 | sum 11 | (define y (stream-filter even? seq)) 12 | sum 13 | (define z (stream-filter (lambda (x) (= (remainder x 5) 0)) 14 | seq)) 15 | sum 16 | 17 | (stream-ref y 7) 18 | 19 | (display-stream z) -------------------------------------------------------------------------------- /2.87.rkt: -------------------------------------------------------------------------------- 1 | (define (install-polynomial-package) 2 | ; ... 3 | (define (poly-zero? term) 4 | (define (iter-zero? list) 5 | (if (null? list) 6 | #t 7 | (let ((first-item (car list))) 8 | (and (=zero? (coeff first-item)) 9 | (iter-zero? (cdr list)))))) 10 | (iter-zero? (term-list term))) 11 | ; ... 12 | (put '=zero? 'polynomial poly-zero?) 13 | 'done) -------------------------------------------------------------------------------- /1.11.ss: -------------------------------------------------------------------------------- 1 | (define (f-recur n) 2 | (cond ((= n 0) 0) 3 | ((= n 1) 1) 4 | ((= n 2) 2) 5 | (else (+ (f (- n 1)) 6 | (* 2 (f (- n 2))) 7 | (* 3 (f (- n 3))))))) 8 | 9 | (define (f-itera n) 10 | (f-iter 2 1 0 n)) 11 | 12 | (define (f-iter a b c count) 13 | (if (= count 0) 14 | c 15 | (f-iter (+ (* 3 c) (* 2 b) a) 16 | a b (- count 1)))) 17 | 18 | -------------------------------------------------------------------------------- /3.31.txt: -------------------------------------------------------------------------------- 1 | (probe 'sum sum) sum 0 New-value = 0 2 | (probe 'carry carry) carry 0 New-value = 0 3 | (half-adder input-1 input-2 sum carry) ok ok 4 | (set-signal! input-1 1) done done 5 | (propagate) sum 8 New-value = 1 done done 6 | (set-signal! input-2 1) done done 7 | (propagate) carry 11 New-value = 1 carry 11 New-value = 1 8 | sum 16 New-value = 0 done 9 | done 10 | 11 | 12 | -------------------------------------------------------------------------------- /3.59.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | ; a) 4 | (define (div-streams s1 s2) 5 | (stream-map / s1 s2)) 6 | 7 | (define (integrate-series stream) 8 | (div-streams stream integers)) 9 | 10 | ; b) 11 | (define cosine-series 12 | (cons-stream 1 (scale-stream 13 | (integrate-series sine-series) 14 | -1))) 15 | 16 | (define sine-series 17 | (cons-stream 0 (integrate-series cosine-series))) -------------------------------------------------------------------------------- /1.44.ss: -------------------------------------------------------------------------------- 1 | (define dx 0.00001) 2 | 3 | (define (repeated f n) 4 | (if (= n 1) 5 | f 6 | (compose (repeated f (- n 1)) f))) 7 | 8 | (define (average x y z) 9 | (/ (+ x y z) 3)) 10 | 11 | (define (smooth f) 12 | (lambda (x) 13 | (average (f (- x dx)) 14 | (f x) 15 | (f (- x dx))))) 16 | 17 | (define (repeated-smooth f n) 18 | (repeated (smooth f) n)) 19 | 20 | ((repeated-smooth sin 10) 2.5) -------------------------------------------------------------------------------- /2.5.ss: -------------------------------------------------------------------------------- 1 | (define (fast-exp b n) 2 | (cond ((= n 0) 1) 3 | ((odd? n) (* b (fast-exp b (- n 1)))) 4 | (else (fast-exp ((lambda (x) (* x x)) b) (/ n 2))))) 5 | 6 | (define (cons a b) 7 | (define (dispatch m) 8 | (cond ((= m 0) (fast-exp 2 a)) 9 | ((= m 1) (fast-exp 3 b)) 10 | (else (error "Argument not 0 or 1 --CONS" m)))) 11 | dispatch) 12 | 13 | (define (car z) (z 0)) 14 | (define (cdr z) (z 1)) -------------------------------------------------------------------------------- /1.8.ss: -------------------------------------------------------------------------------- 1 | (define (cubic-iter guess x) 2 | (if (good-enough? guess x) 3 | guess 4 | (cubic-iter (improve guess x) x))) 5 | 6 | (define (improve guess x) 7 | (/ (+ (/ x (* guess guess)) 8 | (* 2 guess)) 9 | 3)) 10 | 11 | (define (good-enough? guess x) 12 | (< (abs (- 1 13 | (/ guess (improve guess x)))) 14 | 0.00001)) 15 | 16 | (define (cubic x) 17 | (cubic-iter 1.0 x)) 18 | 19 | (cubic 8) -------------------------------------------------------------------------------- /3.5.rkt: -------------------------------------------------------------------------------- 1 | (define random-init 1) 2 | 3 | (define rand 4 | (let ((x random-init)) 5 | (define generate 6 | (lambda () 7 | (set! x (rand-update x)) 8 | x)) 9 | (define reset 10 | (lambda (n) 11 | (set! x n))) 12 | (define (dispatch m) 13 | (cond ((eq? m 'generate) generate) 14 | ((eq? m 'reset) reset) 15 | (else (error "Unknown request -- RAND" m)))) 16 | dispatch)) 17 | 18 | 19 | -------------------------------------------------------------------------------- /2.61.ss: -------------------------------------------------------------------------------- 1 | (define (element-of-set? x set) 2 | (cond ((null? set) #f) 3 | ((= x (car set)) #t) 4 | ((< x (car set)) #f) 5 | (else (element-of-set? x (cdr set))))) 6 | 7 | (define (adjoin-set x set) 8 | (if (null? set) 9 | (list x) 10 | (let ((head (car set))) 11 | (cond ((= x head) set) 12 | ((< x head) (cons x set)) 13 | ((> x head) (cons head (adjoin-set x (cdr set)))))))) -------------------------------------------------------------------------------- /1.7.ss: -------------------------------------------------------------------------------- 1 | (define (sqrt-iter guess x) 2 | (if (good-enough? guess x) 3 | guess 4 | (sqrt-iter (improve guess x) x))) 5 | 6 | (define (good-enough? guess x) 7 | (< (abs (- 1 8 | (/ guess (improve guess x)))) 9 | 0.00001)) 10 | 11 | (define (improve guess x) 12 | (average guess (/ x guess))) 13 | 14 | (define (average x y) 15 | (/ (+ x y) 2)) 16 | 17 | (define (_sqrt x) 18 | (sqrt-iter 1.0 x)) 19 | 20 | (_sqrt 2) -------------------------------------------------------------------------------- /2.12.ss: -------------------------------------------------------------------------------- 1 | (define (make-interval a b) (cons a b)) 2 | (define (upper-bound i) (max (car i) (cdr i))) 3 | (define (lower-bound i) (min (car i) (cdr i))) 4 | 5 | (define (make-center-width c p) 6 | (make-interval (- c (* c p)) 7 | (+ c (* c p)))) 8 | (define (center i) 9 | (/ (+ (lower-bound i) (upper-bound i)) 2)) 10 | (define (width i) 11 | (/ (- (upper-bound i) (lower-bound i)) 2)) 12 | (define (percent i) 13 | (/ (width i) (center i))) -------------------------------------------------------------------------------- /3.60.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (mul-series s1 s2) 4 | (cond ((stream-null? s1) the-empty-stream) 5 | ((stream-null? s2) the-empty-stream) 6 | (else 7 | (cons-stream (* (stream-car s1) (stream-car s2)) 8 | (add-streams (scale-stream (stream-cdr s2) 9 | (stream-car s1)) 10 | (mul-series (stream-cdr s1) s2)))))) 11 | 12 | -------------------------------------------------------------------------------- /2.8.ss: -------------------------------------------------------------------------------- 1 | (define (make-interval a b) (cons a b)) 2 | 3 | (define (upper-bound i) (max (car i) (cdr i))) 4 | (define (lower-bound i) (min (car i) (cdr i))) 5 | 6 | (define (add-interval x y) 7 | (make-interval (+ (lower-bound x) (lower-bound y)) 8 | (+ (upper-bound x) (upper-bound y)))) 9 | 10 | (define (sub-interval x y) 11 | (add-interval x 12 | (make-interval (- (lower-bound y)) 13 | (- (upper-bound y))))) -------------------------------------------------------------------------------- /3.71.rkt: -------------------------------------------------------------------------------- 1 | (load "3.70.rkt") 2 | 3 | (define (cube x) (* x x x)) 4 | 5 | (define (cube-sum pair) 6 | (+ (cube (car pair)) (cube (cadr pair)))) 7 | 8 | (define cube-sum-stream 9 | (stream-map cube-sum integer-pairs)) 10 | 11 | (define ramanujan-numbers 12 | (stream-filter (lambda (pair) (= (car pair) (cadr pair))) 13 | (stream-map list 14 | cube-sum-stream 15 | (stream-cdr cube-sum-stream)))) 16 | 17 | -------------------------------------------------------------------------------- /1.32a.ss: -------------------------------------------------------------------------------- 1 | (define (accumulate combiner null-value term a next b) 2 | (if (> a b) 3 | null-value 4 | (combiner (term a) 5 | (accumulate combiner null-value term (next a) next b)))) 6 | 7 | (define (pi-product a b) 8 | (define (pi-term n) 9 | (cond ((= n 1) (/ 2.0 3.0)) 10 | ((even? n) (/ (+ n 2) (+ n 1))) 11 | (else (/ (+ n 1) (+ n 2))))) 12 | (define (pi-next n) 13 | (+ n 1)) 14 | (* (accumulate * 1 pi-term a pi-next b) 4)) -------------------------------------------------------------------------------- /1.21.ss: -------------------------------------------------------------------------------- 1 | (define (smallest-divisor n) 2 | (find-divisor n 2)) 3 | 4 | (define (square n) (* n n)) 5 | (define (divides? a b) 6 | (= (remainder b a) 0)) 7 | 8 | (define (find-divisor n test-divisor) 9 | (cond ((> (square test-divisor) n) n) 10 | ((divides? test-divisor n) test-divisor) 11 | (else (find-divisor n (+ test-divisor 1))))) 12 | 13 | (define (prime? n) 14 | (if (= n (smallest-divisor n)) 15 | n 16 | (smallest-divisor n))) 17 | 18 | (prime? 19999) -------------------------------------------------------------------------------- /3.66.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (interleave s1 s2) 4 | (if (stream-null? s1) 5 | s2 6 | (cons-stream (stream-car s1) 7 | (interleave s2 (stream-cdr s1))))) 8 | 9 | (define (pairs s t) 10 | (cons-stream 11 | (list (stream-car s) (stream-car t)) 12 | (interleave 13 | (stream-map (lambda (x) (list (stream-car s) x)) 14 | (stream-cdr t)) 15 | (pairs (stream-cdr s) (stream-cdr t))))) 16 | 17 | (define int-pairs 18 | (pairs integers integers)) -------------------------------------------------------------------------------- /3.16.rkt: -------------------------------------------------------------------------------- 1 | (define (last-pair x) 2 | (if (null? (cdr x)) 3 | x 4 | (last-pair (cdr x)))) 5 | (define (make-cycle x) 6 | (set-cdr! (last-pair x) x) 7 | x) 8 | (define (count-pairs x) 9 | (if (not (pair? x)) 10 | 0 11 | (+ (count-pairs (car x)) 12 | (count-pairs (cdr x)) 13 | 1))) 14 | 15 | (define 3-pairs (list 1 2 3)) 16 | (define 4-pairs 17 | (let ((p (cons (list 1) (list 2)))) 18 | (set-cdr! (car p) (cdr p)) 19 | p)) 20 | (define infinite-pairs (make-cycle (list 1 2 3))) -------------------------------------------------------------------------------- /3.28.rkt: -------------------------------------------------------------------------------- 1 | (define (or-gate a1 a2 output) 2 | (define (or-action-procedure) 3 | (let ((new-value (logical-or (get-signal a1) (get-signal a2)))) 4 | (after-delay or-gate-delay 5 | (lambda () 6 | (set-signal! output new-value))))) 7 | (add-action! a1 or-action-procedure) 8 | (add-action! a2 or-action-procedure) 9 | 'ok) 10 | 11 | (define (logical-or s1 s2) 12 | (cond ((or (= s1 1) (= s2 1)) 1) 13 | ((and (= s1 0) (= s2 0)) 0) 14 | (else (error "Invalid signal" s1 s2)))) -------------------------------------------------------------------------------- /2.78.ss: -------------------------------------------------------------------------------- 1 | (define (attach-tag type-tag contents) 2 | (if (number? contents) 3 | (cons 'scheme-number contents) 4 | (cons type-tag contents)) 5 | 6 | (define (type-tag datum) 7 | (cond ((number? datum) 'scheme-number) 8 | ((pair? datum) (car datum)) 9 | (else 10 | (error "Bad tagged datum -- TYPE-TAG" datum)))) 11 | 12 | (define (contents datum) 13 | (cond ((number? datum) datum) 14 | ((pair? datum) (cdr datum)) 15 | (else 16 | (error "Bad tagged datum -- CONTENTS" datum)))) 17 | 18 | -------------------------------------------------------------------------------- /1.36.ss: -------------------------------------------------------------------------------- 1 | (define tolerance 0.001) 2 | (define (average x y) (/ (+ x y) 2)) 3 | 4 | (define (fixed-point f first-guess) 5 | (define (close-enough? v1 v2) 6 | (< (abs (- v1 v2)) tolerance)) 7 | (define (try guess) 8 | (display guess) 9 | (newline) 10 | (let ((next (f guess))) 11 | (if (close-enough? guess next) 12 | next 13 | (try next)))) 14 | (try first-guess)) 15 | 16 | (fixed-point (lambda (x) (/ (log 1000) (log x))) 5.0) 17 | (newline) 18 | (fixed-point (lambda (x) (average x (/ (log 1000) (log x)))) 5.0) -------------------------------------------------------------------------------- /2.60.ss: -------------------------------------------------------------------------------- 1 | (define (element-of-set? x set) 2 | (cond ((null? set) #f) 3 | ((equal? x (car set)) #t) 4 | (else (element-of-set? x (cdr set))))) 5 | 6 | (define (adjoin-set x set) (cons x set)) 7 | 8 | (define (intersection-set set1 set2) 9 | (cond ((or (null? set1) (null? set2)) '()) 10 | ((element-of-set? (car set1) set2) 11 | (cons (car set1) 12 | (intersection-set (cdr set1) set2))) 13 | (else 14 | (intersection-set (cdr set1) set2)))) 15 | 16 | (define (union-set set1 set2) (append set1 set2)) -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | *.sln merge=union 7 | *.csproj merge=union 8 | *.vbproj merge=union 9 | *.fsproj merge=union 10 | *.dbproj merge=union 11 | 12 | # Standard to msysgit 13 | *.doc diff=astextplain 14 | *.DOC diff=astextplain 15 | *.docx diff=astextplain 16 | *.DOCX diff=astextplain 17 | *.dot diff=astextplain 18 | *.DOT diff=astextplain 19 | *.pdf diff=astextplain 20 | *.PDF diff=astextplain 21 | *.rtf diff=astextplain 22 | *.RTF diff=astextplain 23 | -------------------------------------------------------------------------------- /3.68.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (interleave s1 s2) 4 | (if (stream-null? s1) 5 | s2 6 | (cons-stream (stream-car s1) 7 | (interleave s2 (stream-cdr s1))))) 8 | 9 | (define (pairs s t) 10 | (interleave 11 | (stream-map (lambda (x) (list (stream-car s) x)) 12 | t) 13 | (pairs (stream-cdr s) (stream-cdr t)))) 14 | 15 | (define int-pairs 16 | (pairs integers integers)) 17 | 18 | ; can't return a value, and fall into unlimited recursion 19 | ; because interleave can't take a value from (pairs (stream-cdr s) (stream-cdr t)) 20 | -------------------------------------------------------------------------------- /2.62.ss: -------------------------------------------------------------------------------- 1 | (define (union-set set1 set2) 2 | (cond ((null? set1) set2) 3 | ((null? set2) set1) 4 | (else 5 | (let ((x1 (car set1)) (x2 (car set2))) 6 | (cond ((= x1 x2) 7 | (cons x1 (union-set (cdr set1) (cdr set2)))) 8 | ((< x1 x2) 9 | (cons x1 (union-set (cdr set1) set2))) 10 | ((> x1 x2) 11 | (cons x2 (union-set set1 (cdr set2))))))))) 12 | 13 | 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /1.23.ss: -------------------------------------------------------------------------------- 1 | (define (smallest-divisor n) 2 | (find-divisor n 2)) 3 | 4 | (define (square n) (* n n)) 5 | (define (divides? a b) 6 | (= (remainder b a) 0)) 7 | 8 | (define (next test-divisor) 9 | (if (= test-divisor 2) 10 | 3 11 | (+ test-divisor 2))) 12 | 13 | (define (find-divisor n test-divisor) 14 | (cond ((> (square test-divisor) n) n) 15 | ((divides? test-divisor n) test-divisor) 16 | (else (find-divisor n (next test-divisor))))) 17 | 18 | (define (prime? n) 19 | (if (= n (smallest-divisor n)) 20 | n 21 | (smallest-divisor n))) 22 | 23 | (prime? 19999) -------------------------------------------------------------------------------- /2.80.ss: -------------------------------------------------------------------------------- 1 | (define (=zeor? n) (apply-generic '=zeor? n)) 2 | 3 | ; scheme number 4 | (define (install-scheme-number-package) 5 | ; ... 6 | (define (scheme-number-zero? n) (= n 0)) 7 | ;... 8 | (put '=zero? 'scheme-number scheme-number-zero?) 9 | 'done) 10 | 11 | ; rational 12 | (define (install-rational-package) 13 | ; ... 14 | (define (rational-zero? n) (= (numer n) 0)) 15 | ;... 16 | (put '=zero? 'rational rational-zero?) 17 | 'done) 18 | 19 | ; complex 20 | (define (install-complex-package) 21 | ;... 22 | (define (complex-zero? n) (= (magnitude n) 0)) 23 | ;... 24 | (put '=zero? 'complex complex-zero?) 25 | 'done) -------------------------------------------------------------------------------- /3.67.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (interleave s1 s2) 4 | (if (stream-null? s1) 5 | s2 6 | (cons-stream (stream-car s1) 7 | (interleave s2 (stream-cdr s1))))) 8 | 9 | (define (pairs s t) 10 | (cons-stream 11 | (list (stream-car s) (stream-car t)) 12 | (interleave 13 | (interleave 14 | (stream-map (lambda (x) (list (stream-car s) x)) 15 | (stream-cdr t)) 16 | (stream-map (lambda (x) (list x (stream-car t))) 17 | (stream-cdr s))) 18 | (pairs (stream-cdr s) (stream-cdr t))))) 19 | 20 | (define int-pairs 21 | (pairs integers integers)) 22 | 23 | -------------------------------------------------------------------------------- /2.3.ss: -------------------------------------------------------------------------------- 1 | (define (make-rectangle p1 p2) 2 | (cons p1 p2)) 3 | (define (p1 r) (car r)) 4 | (define (p2 r) (cdr r)) 5 | 6 | (define (make-point x y) 7 | (cons x y)) 8 | (define (x-point p) (car p)) 9 | (define (y-point p) (cdr p)) 10 | 11 | (define (circum r) 12 | (* (+ (abs (- (x-point (p1 r)) (x-point (p2 r)))) 13 | (abs (- (y-point (p1 r)) (y-point (p2 r))))) 14 | 2)) 15 | 16 | (define (area r) 17 | (* (abs (- (x-point (p1 r)) (x-point (p2 r)))) 18 | (abs (- (y-point (p1 r)) (y-point (p2 r)))))) 19 | 20 | (define r1 21 | (make-rectangle (make-point 4 5) 22 | (make-point 8 2))) 23 | 24 | (circum r1) 25 | (area r1) -------------------------------------------------------------------------------- /3.3.rkt: -------------------------------------------------------------------------------- 1 | (define (make-account balance password) 2 | (define (withdraw amount) 3 | (if (>= balance amount) 4 | (begin (set! balance (- balance amount)) 5 | balance) 6 | "Insufficient funds")) 7 | (define (deposit amount) 8 | (set! balance (+ balance amount)) 9 | balance) 10 | (define password-fault (lambda (x) "Incorrect password")) 11 | (define (dispatch pw m) 12 | (if (eq? pw password) 13 | (cond ((eq? m 'withdraw) withdraw) 14 | ((eq? m 'deposit) deposit) 15 | (else (error "Unknown requeset -- MAKE-ACCOUNT" 16 | m))) 17 | password-fault)) 18 | dispatch) -------------------------------------------------------------------------------- /1.28.ss: -------------------------------------------------------------------------------- 1 | (define (square x) (* x x)) 2 | 3 | (define (expmod base exp m) 4 | (cond ((= (remainder (square base) m) 1) 0) 5 | ((= exp 0) 1) 6 | ((even? exp) 7 | (remainder (square (expmod base (/ exp 2) m)) 8 | m)) 9 | (else 10 | (remainder (* base (expmod base (- exp 1) m)) 11 | m)))) 12 | 13 | (define (miller-rabin-test n) 14 | (define (try-it a) 15 | (= (expmod a (- n 1) n) (remainder 1 n))) 16 | (try-it (+ 1 (random (- n 1))))) 17 | 18 | (define (prime? n times) 19 | (cond ((= times 0) true) 20 | ((miller-rabin-test n) (prime? n (- times 1))) 21 | (else false))) 22 | 23 | (prime? 6601 100) -------------------------------------------------------------------------------- /1.27.ss: -------------------------------------------------------------------------------- 1 | (define (square x) (* x x)) 2 | 3 | (define (expmod base exp m) 4 | (cond ((= exp 0) 1) 5 | ((even? exp) 6 | (remainder (square (expmod base (/ exp 2) m)) 7 | m)) 8 | (else 9 | (remainder (* base (expmod base (- exp 1) m)) 10 | m)))) 11 | 12 | (define (fermat-test n) 13 | (define (try-it a) 14 | (= (expmod a n n) a)) 15 | (try-it (+ 1 (random (- n 1))))) 16 | 17 | (define (fast-prime? n times) 18 | (cond ((= times 0) true) 19 | ((fermat-test n) (fast-prime? n (- times 1))) 20 | (else false))) 21 | 22 | (define (check-carmichael n times) 23 | (fast-prime? n times)) 24 | 25 | (check-carmichael 6601 500) -------------------------------------------------------------------------------- /2.2.ss: -------------------------------------------------------------------------------- 1 | (define (make-segment s e) 2 | (cons s e)) 3 | 4 | (define (start-segment l) (car l)) 5 | (define (end-segment l) (cdr l)) 6 | 7 | (define (make-point x y) 8 | (cons x y)) 9 | 10 | (define (x-point p) (car p)) 11 | (define (y-point p) (cdr p)) 12 | 13 | (define (mid-point l) 14 | (make-point (/ (+ (x-point (start-segment l)) (x-point (end-segment l))) 2.0) 15 | (/ (+ (y-point (start-segment l)) (y-point (end-segment l))) 2.0))) 16 | 17 | (define (print-point p) 18 | (newline) 19 | (display "(") 20 | (display (x-point p)) 21 | (display ",") 22 | (display (y-point p)) 23 | (display ")")) 24 | 25 | (print-point(mid-point (make-segment (make-point 4 5) (make-point 8 2)))) -------------------------------------------------------------------------------- /2.83.rkt: -------------------------------------------------------------------------------- 1 | (define (raise x) 2 | (if (eq? (tag x) 'complex) 3 | #f 4 | (apply-generic 'raise x))) 5 | 6 | ; integer 7 | (define (install-integer-package) 8 | ; ... 9 | (define (integer-raise x) (make-rational x 1)) 10 | ;... 11 | (put 'raise 'integer integer-raise) 12 | 'done) 13 | 14 | ; rational 15 | (define (install-rational-package) 16 | ; ... 17 | (define (rational-raise x) 18 | (make-real (/ (numer x) (denom x)))) 19 | ;... 20 | (put 'raise 'rational rational-raise) 21 | 'done) 22 | 23 | ; real 24 | (define (install-real-package) 25 | ;... 26 | (define (real-raise x) 27 | (make-complex-from-real-imag x 0)) 28 | ;... 29 | (put 'raise 'real real-raise) 30 | 'done) -------------------------------------------------------------------------------- /1.6.ss: -------------------------------------------------------------------------------- 1 | (define (sqrt-iter guess x) 2 | (if (good-enough? guess x) 3 | guess 4 | (sqrt-iter (improve guess x) 5 | x))) 6 | 7 | (define (improve guess x) 8 | (average guess (/ x guess))) 9 | 10 | (define (average x y) 11 | (/ (+ x y) 2)) 12 | 13 | (define (good-enough? guess x) 14 | (< (abs (- (square guess) x)) 0.001)) 15 | 16 | (define (square x) (* x x)) 17 | 18 | (define (new-if predicate then-clause else-clause) 19 | (cond (predicate then-clause) 20 | (else else-clause))) 21 | 22 | (define (new-sqrt-iter guess x) 23 | (new-if (good-enough? guess x) 24 | guess 25 | (sqrt-iter (improve guess x) 26 | x))) 27 | 28 | (sqrt-iter 1.0 3) 29 | (new-sqrt-iter 1.0 3) -------------------------------------------------------------------------------- /1.45.ss: -------------------------------------------------------------------------------- 1 | (define (iterative-improve check improve guess) 2 | (if (check guess) 3 | guess 4 | (iterative-improve check improve (improve guess)))) 5 | 6 | (define (_sqrt x guess) 7 | (define square 8 | (lambda (x) (* x x))) 9 | (define (average x y) 10 | (/ (+ x y) 2)) 11 | (define (good-enough? guess) 12 | (< (abs (- (square guess) x)) 0.0001)) 13 | (define (improve guess) 14 | (average guess (/ x guess))) 15 | (iterative-improve good-enough? improve guess)) 16 | 17 | (_sqrt 9 1.0) 18 | 19 | (define (fixed-point f first-guess) 20 | (define tolerance 0.00001) 21 | (define (good-enough? guess) 22 | (< (abs (- guess (f guess))) tolerance)) 23 | (iterative-improve good-enough? f first-guess)) 24 | 25 | (fixed-point cos 1.0) -------------------------------------------------------------------------------- /3.69.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | (load "3.66.rkt") 3 | 4 | (define (triples s t u) 5 | (cons-stream 6 | (list (stream-car s) (stream-car t) (stream-car u)) 7 | (interleave 8 | (stream-map (lambda (pair) (cons (stream-car s) pair)) 9 | (stream-cdr (pairs t u))) 10 | (triples (stream-cdr s) (stream-cdr t) (stream-cdr u))))) 11 | 12 | (define (pythagoras-triple? triple) 13 | (define (square x) (* x x)) 14 | (if (null? triple) 15 | #f 16 | (let ((i (car triple)) 17 | (j (cadr triple)) 18 | (k (caddr triple))) 19 | (= (+ (square i) (square j)) (square k))))) 20 | 21 | (define pythagoras-triples 22 | (stream-filter pythagoras-triple? 23 | (triples integers integers integers))) -------------------------------------------------------------------------------- /2.79.ss: -------------------------------------------------------------------------------- 1 | (define (equ? n1 n2) (apply-generic 'equ? n1 n2)) 2 | 3 | ; scheme number 4 | (define (install-scheme-number-package) 5 | ; ... 6 | (define (equ? x y) (= x y)) 7 | ;... 8 | (put 'equ? '(scheme-number scheme-number) 9 | (lambda (x y) (equ? x y))) 10 | 'done) 11 | 12 | ; rational 13 | (define (install-rational-package) 14 | ;... 15 | (define (equ? x y) (= (sub-rat x y) 0)) 16 | ;... 17 | (put 'equ? '(rational rational) 18 | (lambda (x y) (equ? x y))) 19 | 'done) 20 | 21 | ; complex 22 | (define (install-complex-package) 23 | ;... 24 | (define (equ? x y) 25 | (and (= (real-part x) (real-part y)) 26 | (= (imag-part x) (imag-part y)))) 27 | ;... 28 | (put 'equ? '(complex complex) 29 | (lambda (x y) (equ? x y))) 30 | 'done) -------------------------------------------------------------------------------- /2.10.ss: -------------------------------------------------------------------------------- 1 | (define (make-interval a b) (cons a b)) 2 | 3 | (define (upper-bound i) (max (car i) (cdr i))) 4 | (define (lower-bound i) (min (car i) (cdr i))) 5 | 6 | (define (mul-interval x y) 7 | (let ((p1 (* (lower-bound x) (lower-bound y))) 8 | (p2 (* (lower-bound x) (upper-bound y))) 9 | (p3 (* (upper-bound x) (lower-bound y))) 10 | (p4 (* (upper-bound x) (upper-bound y)))) 11 | (make-interval (min p1 p2 p3 p4) 12 | (max p1 p2 p3 p4)))) 13 | 14 | (define (div-interval x y) 15 | (if (and (< (lower-bound y) 0) (> (upper-bound y) 0)) 16 | (error "Wrong interval!" div-interval) 17 | (mul-interval x 18 | (make-interval (/ 1.0 lower-bound y) 19 | (/ 1.0 upper-bound y))))) 20 | -------------------------------------------------------------------------------- /1.40.ss: -------------------------------------------------------------------------------- 1 | (define dx 0.00001) 2 | 3 | (define (deriv g) 4 | (lambda (x) 5 | (/ (- (g (+ x dx)) (g x)) 6 | dx))) 7 | 8 | (define (newton-transform g) 9 | (lambda (x) 10 | (- x (/ (g x) ((deriv g) x))))) 11 | 12 | (define tolerance 0.00001) 13 | 14 | (define (fixed-point f first-guess) 15 | (define (close-enough? v1 v2) 16 | (< (abs (- v1 v2)) tolerance)) 17 | (define (try guess) 18 | (let ((next (f guess))) 19 | (if (close-enough? guess next) 20 | next 21 | (try next)))) 22 | (try first-guess)) 23 | 24 | (define (newton-method g guess) 25 | (fixed-point (newton-transform g) guess)) 26 | 27 | (define (cubic a b c) 28 | (lambda (x) 29 | (+ (* x x x) 30 | (* a x x) 31 | (* b x) 32 | c))) 33 | 34 | (newton-method (cubic 1 2 3) 1.0) -------------------------------------------------------------------------------- /3.35.rkt: -------------------------------------------------------------------------------- 1 | (define (square a b) 2 | (define (process-new-value) 3 | (if (has-value? b) 4 | (if (< (get-value b) 0) 5 | (error "square less than 0 -- SQUARE" process-new-value) 6 | (set-value! a (sqrt (get-value b)) me)) 7 | (if (has-value? a) 8 | (set-value! b (* (get-value a) (get-value a)) me)))) 9 | (define (process-forget-value) 10 | (forget-value! a me) 11 | (forget-value! b me) 12 | (process-new-value)) 13 | (define (me request) 14 | (cond ((eq? request 'I-have-a-value) 15 | (process-new-value)) 16 | ((eq? request 'I-lost-my-value) 17 | (process-forget-value)) 18 | (else 19 | (error "Unknown request -- SQUARE" request)))) 20 | (connect a me) 21 | (connect b me) 22 | me) 23 | 24 | -------------------------------------------------------------------------------- /3.56.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | 3 | (define (merge s1 s2) 4 | (cond ((stream-null? s1) s2) 5 | ((stream-null? s2) s1) 6 | (else 7 | (let ((s1car (stream-car s1)) 8 | (s2car (stream-car s2))) 9 | (cond ((< s1car s2car) 10 | (cons-stream s1car (merge (stream-cdr s1) s2))) 11 | ((> s1car s2car) 12 | (cons-stream s2car (merge s1 (stream-cdr s2)))) 13 | (else 14 | (cons-stream s1car (merge 15 | (stream-cdr s1) 16 | (stream-cdr s2))))))))) 17 | 18 | (define s (cons-stream 1 (merge (scale-stream s 2) 19 | (merge (scale-stream s 3) 20 | (scale-stream s 5))))) -------------------------------------------------------------------------------- /3.7.rkt: -------------------------------------------------------------------------------- 1 | (define (make-account balance password) 2 | (define (withdraw amount) 3 | (if (>= balance amount) 4 | (begin (set! balance (- balance amount)) 5 | balance) 6 | "Insufficient funds")) 7 | (define (deposit amount) 8 | (set! balance (+ balance amount)) 9 | balance) 10 | (define password-fault (lambda (x) "Incorrect password")) 11 | (define (joint new-pw) 12 | (dispatch)) 13 | (define (dispatch pw m) 14 | (if (eq? pw password) 15 | (cond ((eq? m 'withdraw) withdraw) 16 | ((eq? m 'deposit) deposit) 17 | ((eq? m 'joint) joint) 18 | (else (error "Unknown requeset -- MAKE-ACCOUNT" 19 | m))) 20 | password-fault)) 21 | dispatch) 22 | 23 | (define (make-joint account custom-pw new-pw) 24 | ((account custom-pw 'joint) new-pw)) -------------------------------------------------------------------------------- /2.88.rkt: -------------------------------------------------------------------------------- 1 | (define (negative x) (apply-generic 'negative x)) 2 | 3 | ; scheme number 4 | (define (scheme-number-negative x) (- x)) 5 | (put 'negative 'scheme-number scheme-number-negative) 6 | 7 | ; rational 8 | (define (rational-negative x) 9 | (make-rational (- (numer x)) (denom x))) 10 | (put 'negative 'rational rational-negative) 11 | 12 | ; complex 13 | (define (complex-negative x) 14 | (make-from-real-imag (- (real-part x)) 15 | (- (imag-part x)))) 16 | (put 'negative 'complex complex-negative) 17 | 18 | ; polynomial 19 | (define (nega-item x) 20 | (make-term (order x) 21 | (negative (coeff x)))) 22 | (define (poly-negative term) 23 | (make-poly (variable term) 24 | (map neag-item (term-list term)))) 25 | (define (sub-terms l1 l2) 26 | (add l1 (map neag-item l2))) 27 | (put 'negative 'polynomial poly-negative) -------------------------------------------------------------------------------- /3.31.rkt: -------------------------------------------------------------------------------- 1 | (load "wire.rkt") 2 | (load "circuit.rkt") 3 | (load "agenda.rkt") 4 | (load "queue.rkt") 5 | 6 | ;; a probe 7 | (define (probe name wire) 8 | (add-action! wire 9 | (lambda () 10 | (display name) 11 | (display " ") 12 | (display (current-time the-agenda)) 13 | (display " New-value = ") 14 | (display (get-signal wire)) 15 | (newline)))) 16 | 17 | ;; probe the wires 18 | (define the-agenda (make-agenda)) 19 | (define inverter-delay 2) 20 | (define and-gate-delay 3) 21 | (define or-gate-delay 5) 22 | 23 | (define input-1 (make-wire)) 24 | (define input-2 (make-wire)) 25 | (define sum (make-wire)) 26 | (define carry (make-wire)) 27 | 28 | (probe 'sum sum) 29 | (probe 'carry carry) 30 | (half-adder input-1 input-2 sum carry) 31 | (set-signal! input-1 1) 32 | (propagate) 33 | (set-signal! input-2 1) 34 | (propagate) -------------------------------------------------------------------------------- /3.17.rkt: -------------------------------------------------------------------------------- 1 | (define (count-pairs x) 2 | (let ((past-list '())) 3 | (define (pointer-in-list? p l) 4 | (cond ((null? l) #f) 5 | ((eq? p (car l)) #t) 6 | (else (pointer-in-list? p (cdr l))))) 7 | (define (append-cons l p-list) 8 | (set! p-list (cons (caar l) p-list)) 9 | p-list) 10 | (define (iter list past-list n) 11 | (cond ((not (pair? list)) n) 12 | ((pointer-in-list? (cdr list) past-list) n) 13 | (else 14 | (+ (iter (cdr list) (append-cons list past-list) (+ n 1)) 15 | (iter (car list) past-list 0))))) 16 | (iter x past-list 0))) 17 | 18 | (define z (cons 1 (cons (list 1 2) (list 1)))) 19 | (define p 20 | (let ((x (cons 1 (cons (list 1 2) (list 1))))) 21 | (set-cdr! (cdadr x) (cadr x)) 22 | x)) 23 | 24 | (define (pointer-in-list? p l) 25 | (cond ((null? l) #f) 26 | ((eq? p (car l)) #t) 27 | (else (pointer-in-list? p (cdr l))))) -------------------------------------------------------------------------------- /3.70.rkt: -------------------------------------------------------------------------------- 1 | (load "3.66.rkt") 2 | 3 | (define (merge-weighted s1 s2 weight) 4 | (let ((s1car (stream-car s1)) 5 | (s2car (stream-car s2)) 6 | (s1rest (stream-cdr s1)) 7 | (s2rest (stream-cdr s2))) 8 | (if (> (weight s1car) (weight s2car)) 9 | (cons-stream s2car 10 | (cons-stream s1car 11 | (merge-weighted s1rest s2rest weight))) 12 | (cons-stream s1car 13 | (cons-stream s2car 14 | (merge-weighted s1rest s2rest weight)))))) 15 | 16 | (define (weighted-pairs s1 s2 weight) 17 | (let ((strm1 (stream-map 18 | (lambda (x) (list (stream-car s1) x)) 19 | (stream-cdr s2))) 20 | (strm2 (pairs (stream-cdr s1) (stream-cdr s2)))) 21 | (cons-stream (list (stream-car s1) (stream-car s2)) 22 | (merge-weighted strm1 strm2 weight)))) 23 | 24 | (define (integer-weight pair) 25 | (+ (car pair) (cadr pair))) 26 | 27 | (define integer-pairs 28 | (weighted-pairs integers integers integer-weight)) -------------------------------------------------------------------------------- /2.29.ss: -------------------------------------------------------------------------------- 1 | ; a) 2 | (define (make-mobile left right) 3 | (list left right)) 4 | 5 | (define (make-branch length structure) 6 | (list length structure)) 7 | (define (branch-length branch) 8 | (car branch)) 9 | (define (branch-structure branch) 10 | (cdar branch)) 11 | 12 | (define (left-branch mobile) 13 | (car mobile)) 14 | (define (right-branch mobile) 15 | (cdar mobile)) 16 | 17 | (define (branch-weight branch) 18 | (if (pair? branch) 19 | (+ (branch-weight (left-branch branch)) 20 | (branch-weight (right-branch branch))) 21 | (branch-structure branch))) 22 | ; b) 23 | (define (total-weight mobile) 24 | (+ (branch-weight (left-branch mobile)) 25 | (branch-weight (right-branch mobile)))) 26 | ; c) 27 | (define (balance? mobile) 28 | (and (= (* (branch-length (left-branch mobile)) 29 | (branch-weight (left-branch mobile))) 30 | (* (branch-length (right-branch mobile)) 31 | (branch-weight (right-branch mobile)))) 32 | (map (lambda (x) 33 | (if (pair? x) 34 | (balance? x))) 35 | mobile))) 36 | -------------------------------------------------------------------------------- /2.81.rkt: -------------------------------------------------------------------------------- 1 | (define (apply-generic op . args) 2 | (let ((type-tags (map type-tag args))) 3 | (let ((proc (get op type-tags))) 4 | (if proc 5 | (apply proc (map contents args)) 6 | (if (= (length args) 2) 7 | (let ((type1 (car type-tags)) 8 | (type2 (cdr type-tags)) 9 | (a1 (car args)) 10 | (a2 (cdr args))) 11 | (if (eq? type1 type2) 12 | ((get op (type1 type1)) type1 type2) 13 | (let ((t1->t2 (get-coercion type1 type2)) 14 | (t2->t1 (get-coercion type2 type1))) 15 | (cond (t1->t2 16 | (apply-generic op (t1->t2 a1) a2)) 17 | (t1->t2 18 | (apply-generic op a1 (t2->t1 a2))) 19 | (else 20 | (error "No method for these types" 21 | (list op type-tags))))))) 22 | (error "No method for these types" 23 | (list op type-tags))))))) -------------------------------------------------------------------------------- /queue.rkt: -------------------------------------------------------------------------------- 1 | ;; queue implement 2 | (define (make-queue) (cons '() '())) 3 | 4 | (define (front-ptr queue) (car queue)) 5 | 6 | (define (rear-ptr queue) (cdr queue)) 7 | 8 | (define (set-front-ptr! queue item) (set-car! queue item)) 9 | 10 | (define (set-rear-ptr! queue item) (set-cdr! queue item)) 11 | 12 | (define (empty-queue? queue) (null? (front-ptr queue))) 13 | 14 | (define (front-queue queue) 15 | (if (empty-queue? queue) 16 | (error "FRONT called with an empty queue" queue) 17 | (car (front-ptr queue)))) 18 | 19 | (define (insert-queue! queue item) 20 | (let ((new-pair (cons item '()))) 21 | (cond ((empty-queue? queue) 22 | (set-front-ptr! queue new-pair) 23 | (set-rear-ptr! queue new-pair) 24 | queue) 25 | (else 26 | (set-cdr! (rear-ptr queue) new-pair) 27 | (set-rear-ptr! queue new-pair) 28 | queue)))) 29 | 30 | (define (delete-queue! queue) 31 | (cond ((empty-queue? queue) 32 | (error "DELETE! called with an empty queue" queue)) 33 | (else 34 | (set-front-ptr! queue (cdr (front-ptr queue))) 35 | queue))) -------------------------------------------------------------------------------- /3.21.rkt: -------------------------------------------------------------------------------- 1 | (define (make-queue) (cons '() '())) 2 | 3 | (define (front-ptr queue) (car queue)) 4 | 5 | (define (rear-ptr queue) (cdr queue)) 6 | 7 | (define (set-front-ptr! queue item) (set-car! queue item)) 8 | 9 | (define (set-rear-ptr! queue item) (set-cdr! queue item)) 10 | 11 | (define (empty-queue? queue) (null? (front-ptr queue))) 12 | 13 | (define (front-queue queue) 14 | (if (empty-queue? queue) 15 | (error "FRONT called with an empty queue" queue) 16 | (car (front-ptr queue)))) 17 | 18 | (define (insert-queue! queue item) 19 | (let ((new-pair (cons item '()))) 20 | (cond ((empty-queue? queue) 21 | (set-front-ptr! queue new-pair) 22 | (set-rear-ptr! queue new-pair) 23 | queue) 24 | (else 25 | (set-cdr! (rear-ptr queue) new-pair) 26 | (set-rear-ptr! queue new-pair) 27 | queue)))) 28 | 29 | (define (delete-queue! queue) 30 | (cond ((empty-queue? queue) 31 | (error "DELETE! called with an empty queue" queue)) 32 | (else 33 | (set-front-ptr! queue (cdr (front-ptr queue))) 34 | queue))) 35 | 36 | (define (print-queue queue) 37 | (display (front-ptr queue))) -------------------------------------------------------------------------------- /1.33.ss: -------------------------------------------------------------------------------- 1 | (define (filtered-accumulate filter combiner null-value term a next b) 2 | (cond ((> a b) null-value) 3 | ((filter a) 4 | (combiner (term a) 5 | (filtered-accumulate filter combiner 6 | null-value term (next a) next b))) 7 | (else 8 | (filtered-accumulate filter combiner 9 | null-value term (next a) next b)))) 10 | 11 | (define (smallest-divisor n) 12 | (find-divisor n 2)) 13 | 14 | (define (square n) (* n n)) 15 | (define (divides? a b) 16 | (= (remainder b a) 0)) 17 | 18 | (define (next test-divisor) 19 | (if (= test-divisor 2) 20 | 3 21 | (+ test-divisor 2))) 22 | 23 | (define (find-divisor n test-divisor) 24 | (cond ((> (square test-divisor) n) n) 25 | ((divides? test-divisor n) test-divisor) 26 | (else (find-divisor n (next test-divisor))))) 27 | 28 | (define (prime? n) 29 | (if (= n (smallest-divisor n)) 30 | n 31 | (smallest-divisor n))) 32 | 33 | (define (sum-of-prime a b) 34 | (define (sum-term n) n) 35 | (define (sum-next n) (+ n 1)) 36 | (filtered-accumulate prime? + 0 sum-term a sum-next b)) 37 | 38 | (sum-of-prime 15 100) -------------------------------------------------------------------------------- /wire.rkt: -------------------------------------------------------------------------------- 1 | ;; wire implement 2 | (define (make-wire) 3 | (let ((signal-value 0) (action-procedures '())) 4 | (define (set-my-signal! new-value) 5 | (if (not (= signal-value new-value)) 6 | (begin (set! signal-value new-value) 7 | (call-each action-procedures)) 8 | 'done)) 9 | 10 | (define (accept-action-procedure! proc) 11 | (set! action-procedures (cons proc action-procedures)) 12 | (proc)) 13 | 14 | (define (dispatch m) 15 | (cond ((eq? m 'get-signal) signal-value) 16 | ((eq? m 'set-signal!) set-my-signal!) 17 | ((eq? m 'add-action!) accept-action-procedure!) 18 | (else (error "Unknown operation -- WIRE" m)))) 19 | dispatch)) 20 | 21 | (define (call-each procedures) 22 | (if (null? procedures) 23 | 'done 24 | (begin 25 | ((car procedures)) 26 | (call-each (cdr procedures))))) 27 | 28 | (define (get-signal wire) 29 | (wire 'get-signal)) 30 | 31 | (define (set-signal! wire new-value) 32 | ((wire 'set-signal!) new-value)) 33 | 34 | (define (add-action! wire action-procedure) 35 | ((wire 'add-action!) action-procedure)) 36 | 37 | (define (after-delay delay action) 38 | (add-to-agenda! (+ delay (current-time the-agenda)) 39 | action 40 | the-agenda)) -------------------------------------------------------------------------------- /3.4.rkt: -------------------------------------------------------------------------------- 1 | (define (make-monitored f) 2 | (let ((counter 0)) 3 | (lambda (x) 4 | (cond ((eq? x 'how-many-calls?) counter) 5 | ((eq? x 'reset-count) (set! counter 0)) 6 | (else 7 | (begin (set! counter (+ counter 1)) 8 | (f x))))))) 9 | 10 | (define (make-account balance password) 11 | (define (withdraw amount) 12 | (if (>= balance amount) 13 | (begin (set! balance (- balance amount)) 14 | balance) 15 | "Insufficient funds")) 16 | (define (deposit amount) 17 | (set! balance (+ balance amount)) 18 | balance) 19 | (define (check-password pw) 20 | (if (eq? pw password) 21 | (begin (password-fault 'reset-count) 22 | #t) 23 | (if (> (password-fault 'how-many-calls?) 7) 24 | (begin (call-the-cops) #f) 25 | #f))) 26 | (define call-the-cops 27 | (lambda () (display "Policeman!!!!"))) 28 | (define password-fault 29 | (make-monitored (lambda (x) "Incorrect password"))) 30 | (define (dispatch pw m) 31 | (if (check-password pw) 32 | (cond ((eq? m 'withdraw) withdraw) 33 | ((eq? m 'deposit) deposit) 34 | (else (error "Unknown requeset -- MAKE-ACCOUNT" 35 | m))) 36 | password-fault)) 37 | dispatch) 38 | -------------------------------------------------------------------------------- /3.65.rkt: -------------------------------------------------------------------------------- 1 | (load "stream.rkt") 2 | (load "3.55.rkt") 3 | 4 | ; first sequence, never optimize 5 | (define (ln2-summands n) 6 | (cons-stream (/ 1.0 n) 7 | (stream-map - (ln2-summands (+ n 1))))) 8 | 9 | (define ln2-stream 10 | (partial-sums (ln2-summands 1))) 11 | 12 | ; second sequence, use euler transform once 13 | (define square (lambda (x) (* x x))) 14 | 15 | (define (euler-transform s) 16 | (let ((s0 (stream-ref s 0)) 17 | (s1 (stream-ref s 1)) 18 | (s2 (stream-ref s 2))) 19 | (cons-stream (- s2 (/ (square (- s2 s1)) 20 | (+ s0 (* -2 s1) s2))) 21 | (euler-transform (stream-cdr s))))) 22 | 23 | (define euler-ln2-stream 24 | (euler-transform ln2-stream)) 25 | 26 | ; third sequence, use super accelerator 27 | (define (make-tableau transform s) 28 | (cons-stream s 29 | (make-tableau transform 30 | (transform s)))) 31 | 32 | (define (accelerated-sequence transform s) 33 | (stream-map stream-car 34 | (make-tableau transform s))) 35 | 36 | (define accelerated-ln2-stream 37 | (accelerated-sequence euler-transform ln2-stream)) 38 | 39 | ; test 40 | (display-stream-n ln2-stream 8) 41 | (display-stream-n euler-ln2-stream 8) 42 | (display-stream-n accelerated-ln2-stream 8) 43 | 44 | ; first sequence convergences very slowly 45 | ; second sequence convergences faster and faster than first sequence 46 | ; third sequence convergences very very very fast -------------------------------------------------------------------------------- /2.74.ss: -------------------------------------------------------------------------------- 1 | (define (install-branch-package) 2 | (define branch-file 3 | (list 'branch ('branch name salary))) 4 | (define (make-employee name salary) 5 | (list 'branch name salary)) 6 | (define (name employee-record) (cadr employee-record)) 7 | (define (salary employee-record) (caddr employee-record)) 8 | (define (find-employee-record name) 9 | (define (find-record-iter name file) 10 | (if (null? file) 11 | (error "NO FOUND -- BRANCH" name) 12 | (let ((first-record (car file))) 13 | (if (eq? name (name first-record)) 14 | first-record 15 | (find-record-iter name (cdr file)))))) 16 | (find-record-iter name (cdr branch-file))) 17 | 18 | (put 'name '(branch) name) 19 | (put 'salary '(branch) salary) 20 | (put 'find-employee-record '(branch) find-employee-record) 21 | (put 'make-employee '(branch) 22 | (lambda (name salary) (make-employee name salary))) 23 | 'done) 24 | 25 | ; a) 26 | (define (get-record name file-name) 27 | ((get 'find-emloyee-record file-name) name)) 28 | 29 | ; b) 30 | (define (get-salary name file-name) 31 | (let ((record (get-record name file-name))) 32 | ((get 'salary file-name) record))) 33 | 34 | ; c) 35 | (define (find-employee-record name file) 36 | (let ((first-file-name (caar file))) 37 | (let ((emp-record (get name first-file-name))) 38 | (if emp-record 39 | emp-record 40 | (find-employee-record name (cdr file)))))) 41 | 42 | 43 | -------------------------------------------------------------------------------- /2.69.rkt: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) 2 | (list 'leaf symbol weight)) 3 | 4 | (define (leaf? object) (eq? (car object) 'leaf)) 5 | 6 | (define (symbol-leaf x) (cadr x)) 7 | 8 | (define (weight-leaf x) (caddr x)) 9 | 10 | (define (make-code-tree left right) 11 | (list left 12 | right 13 | (append (symbols left) (symbols right)) 14 | (+ (weight left) (weight right)))) 15 | 16 | (define (left-branch tree) (car tree)) 17 | 18 | (define (right-branch tree) (cadr tree)) 19 | 20 | (define (symbols tree) 21 | (if (leaf? tree) 22 | (list (symbol-leaf tree)) 23 | (caddr tree))) 24 | 25 | (define (weight tree) 26 | (if (leaf? tree) 27 | (weight-leaf tree) 28 | (cadddr tree))) 29 | 30 | (define (adjoin-set x set) 31 | (cond ((null? set) (list x)) 32 | ((< (weight x) (weight (car set))) (cons x set)) 33 | (else (cons (car set) 34 | (adjoin-set x (cdr set)))))) 35 | 36 | (define (make-leaf-set pairs) 37 | (if (null? pairs) 38 | '() 39 | (let ((pair (car pairs))) 40 | (adjoin-set (make-leaf (car pair) (cadr pair)) 41 | (make-leaf-set (cdr pairs)))))) 42 | 43 | (define (generate-huffman-tree pairs) 44 | (car (successive-merge (make-leaf-set pairs)))) 45 | 46 | ;; iteration 47 | (define (successive-merge pairs) 48 | (if (= (length pairs) 1) 49 | pairs 50 | (successive-merge (adjoin-set-h 51 | (make-code-tree (car pairs) (cadr pairs)) 52 | (cddr pairs))))) -------------------------------------------------------------------------------- /3.22.rkt: -------------------------------------------------------------------------------- 1 | (define (make-queue) 2 | (let ((queue (cons '() '())) 3 | (front-ptr car) 4 | (rear-ptr cdr) 5 | (set-front-ptr! set-car!) 6 | (set-rear-ptr! set-cdr!)) 7 | 8 | (define (empty-queue? queue) (null? (front-ptr queue))) 9 | 10 | (define (front-queue) 11 | (if (empty-queue? queue) 12 | (error "FRONT called with an empty queue" queue) 13 | (car (front-ptr queue)))) 14 | 15 | (define (insert-queue! item) 16 | (let ((new-pair (cons item '()))) 17 | (cond ((empty-queue? queue) 18 | (set-front-ptr! queue new-pair) 19 | (set-rear-ptr! queue new-pair) 20 | queue) 21 | (else 22 | (set-cdr! (rear-ptr queue) new-pair) 23 | (set-rear-ptr! queue new-pair) 24 | queue)))) 25 | 26 | (define (delete-queue!) 27 | (cond ((empty-queue? queue) 28 | (error "DELETE! called with an empty queue" queue)) 29 | (else 30 | (set-front-ptr! queue (cdr (front-ptr queue)) 31 | queue)))) 32 | 33 | (define (print-queue) (display (car queue))) 34 | 35 | (define (dispatch m) 36 | (cond ((eq? m 'insert-queue!) insert-queue!) 37 | ((eq? m 'delete-queue!) delete-queue!) 38 | ((eq? m 'front-queue) front-queue) 39 | ((eq? m 'print-queue) print-queue) 40 | (else (error "Unknown request -- MAKE-QUEUE" m)))) 41 | 42 | dispatch)) 43 | 44 | (define q1 (make-queue)) 45 | -------------------------------------------------------------------------------- /2.58.ss: -------------------------------------------------------------------------------- 1 | ; deriv 2 | (define (deriv exp var) 3 | (cond ((number? exp) 0) 4 | ((variable? exp) 5 | (if (same-variable? exp var) 1 0)) 6 | ((sum? exp) 7 | (make-sum (deriv (addend exp) var) 8 | (deriv (augend exp) var))) 9 | ((product? exp) 10 | (make-sum 11 | (make-product (multiplier exp) 12 | (deriv (multiplicand exp) var)) 13 | (make-product (deriv (multiplier exp) var) 14 | (multiplicand exp)))) 15 | (else 16 | (error "unkown expression type -- DERIV" exp)))) 17 | 18 | (define (variable? x) (symbol? x)) 19 | 20 | (define (same-variable? v1 v2) 21 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 22 | 23 | (define (=number? exp num) 24 | (and (number? exp) (= exp num))) 25 | 26 | ; sum 27 | (define (sum? x) 28 | (and (pair? x) (eq? (cadr x) '+))) 29 | 30 | (define (addend s) (car s)) 31 | 32 | (define (augend s) (caddr s)) 33 | 34 | (define (make-sum a1 a2) 35 | (cond ((=number? a1 0) a2) 36 | ((=number? a2 0) a1) 37 | ((and (number? a1) (number? a2)) (+ a1 a2)) 38 | (else (list a1 '+ a2)))) 39 | 40 | ; product 41 | (define (product? x) 42 | (and (pair? x) (eq? (cadr x) '*))) 43 | 44 | (define (multiplier p) (car p)) 45 | 46 | (define (multiplicand p) (caddr p)) 47 | 48 | (define (make-product m1 m2) 49 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 50 | ((=number? m1 1) m2) 51 | ((=number? m2 1) m1) 52 | ((and (number? m1) (number? m2)) (* m1 m2)) 53 | (else (list m1 '* m2)))) -------------------------------------------------------------------------------- /2.84.rkt: -------------------------------------------------------------------------------- 1 | (define (tag x) (car x)) 2 | (define level-list 3 | (list (list 'complex 4) (list 'real 3) (list 'rational 2) (list 'integer 1))) 4 | 5 | (define (get-level x l-list) 6 | (cond ((null? l-list) (error "No this type -- x" x)) 7 | ((let ((first-item (car l-list))) 8 | (eq? (tag x) (car first-item)) 9 | (cdr first-item))) 10 | (else 11 | (get-level x (cdr l-list))))) 12 | 13 | (define (compare-level x1 x2) 14 | (- (get-level x1 level-list) (get-level x2 level-list))) 15 | 16 | (define (eq-level? x1 x2) 17 | (= (compare-level x1 x2) 0)) 18 | (define (higher-level? x1 x2) 19 | (> (compare-level x1 x2) 0)) 20 | (define (lower-level? x1 x2) 21 | (< (compare-level x1 x2) 0)) 22 | 23 | (define (apply-generic op . args) 24 | (let ((type-tags (map type-tag args))) 25 | (let ((proc (get op type-tags))) 26 | (if proc 27 | (apply proc (map contents args)) 28 | (if (= (length args) 2) 29 | (let ((a1 (car args)) (a2 (cdr args)) (type1 (car args))) 30 | (cond ((eq-level? a1 a2) 31 | ((get op (type1 type1)) a1 a2)) 32 | ((higher-level? a1 a2) 33 | (apply-generic op a1 (raise a2))) 34 | ((lower-level? a1 a2) 35 | (apply-generic op (raise a1) a2))) 36 | (else 37 | (error "No method for these types" 38 | (list op type-tags)))) 39 | (error "No method for these types" 40 | (list op type-tags))))))) -------------------------------------------------------------------------------- /2.68.rkt: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) 2 | (list 'leaf symbol weight)) 3 | 4 | (define (leaf? object) (eq? (car object) 'leaf)) 5 | 6 | (define (symbol-leaf x) (cadr x)) 7 | 8 | (define (weight-leaf x) (caddr x)) 9 | 10 | (define (make-code-tree left right) 11 | (list left 12 | right 13 | (append (symbols left) (symbols right)) 14 | (+ (weight left) (weight right)))) 15 | 16 | (define (left-branch tree) (car tree)) 17 | 18 | (define (right-branch tree) (cadr tree)) 19 | 20 | (define (symbols tree) 21 | (if (leaf? tree) 22 | (list (symbol-leaf tree)) 23 | (caddr tree))) 24 | 25 | (define (weight tree) 26 | (if (leaf? tree) 27 | (weight-leaf tree) 28 | (cadddr tree))) 29 | 30 | (define (encode message tree) 31 | (if (null? message ) 32 | '() 33 | (append (encode-symbol (car message) tree) 34 | (encode (cdr message) tree)))) 35 | 36 | (define (encode-symbol symbol tree) 37 | (if (memq symbol (symbols tree)) 38 | (let ((l-b (left-branch tree)) (r-b (right-branch tree))) 39 | (if (memq symbol (symbols l-b)) 40 | (if (leaf? l-b) (list 0) (cons 0 (encode-symbol symbol l-b))) 41 | (if (leaf? r-b) (list 1) (cons 1 (encode-symbol symbol r-b))))) 42 | (error "symbol not in tree --" symbol))) 43 | 44 | (define sample-tree 45 | (make-code-tree (make-leaf 'A 4) 46 | (make-code-tree 47 | (make-leaf 'B 2) 48 | (make-code-tree (make-leaf 'D 1) 49 | (make-leaf 'C 1))))) 50 | 51 | (display (encode '(A D A B B C A) sample-tree)) -------------------------------------------------------------------------------- /circuit.rkt: -------------------------------------------------------------------------------- 1 | ;; circuit elements 2 | (define (half-adder a b s c) 3 | (let ((d (make-wire)) (e (make-wire))) 4 | (or-gate a b d) 5 | (and-gate a b c) 6 | (inverter c e) 7 | (and-gate d e s) 8 | 'ok)) 9 | 10 | (define (inverter input output) 11 | (define (invert-input) 12 | (let ((new-value (logical-not (get-signal input)))) 13 | (after-delay inverter-delay 14 | (lambda () 15 | (set-signal! output new-value))))) 16 | (add-action! input invert-input) 17 | 'ok) 18 | 19 | (define (logical-not s) 20 | (cond ((= s 0) 1) 21 | ((= s 1) 0) 22 | (else (error "Invalid signal" s)))) 23 | 24 | (define (and-gate a1 a2 output) 25 | (define (and-action-procedure) 26 | (let ((new-value 27 | (logical-and (get-signal a1) (get-signal a2)))) 28 | (after-delay and-gate-delay 29 | (lambda () 30 | (set-signal! output new-value))))) 31 | (add-action! a1 and-action-procedure) 32 | (add-action! a2 and-action-procedure) 33 | 'ok) 34 | 35 | (define (logical-and s1 s2) 36 | (if (and (= s1 1) (= s2 1)) 37 | 1 38 | 0)) 39 | 40 | (define (or-gate a1 a2 output) 41 | (define (or-action-procedure) 42 | (let ((new-value (logical-or (get-signal a1) (get-signal a2)))) 43 | (after-delay or-gate-delay 44 | (lambda () 45 | (set-signal! output new-value))))) 46 | (add-action! a1 or-action-procedure) 47 | (add-action! a2 or-action-procedure) 48 | 'ok) 49 | 50 | (define (logical-or s1 s2) 51 | (cond ((or (= s1 1) (= s2 1)) 1) 52 | ((and (= s1 0) (= s2 0)) 0) 53 | (else (error "Invalid signal" s1 s2)))) -------------------------------------------------------------------------------- /3.24.rkt: -------------------------------------------------------------------------------- 1 | (define (make-table pred) 2 | (let ((local-table (list '*table*)) 3 | (same-key? pred)) 4 | (define (assoc key records) 5 | (cond ((null? records) #f) 6 | ((same-key? key (caar records)) (car records)) 7 | (else (assoc key (cdr records))))) 8 | (define (lookup key-1 key-2) 9 | (let ((subtable (assoc key-1 (cdr local-table)))) 10 | (if subtable 11 | (let ((record (assoc key-2 (cdr subtable)))) 12 | (if record 13 | (cdr record) 14 | #f)) 15 | #f))) 16 | (define (insert! key-1 key-2 value) 17 | (let ((subtable (assoc key-1 (cdr local-table)))) 18 | (if subtable 19 | (let ((record (assoc key-2 (cdr subtable)))) 20 | (if record 21 | (set-cdr! record value) 22 | (set-cdr! subtable 23 | (cons (cons key-2 value) 24 | (cdr subtable))))) 25 | (set-cdr! local-table 26 | (cons (list key-1 (cons key-2 value)) 27 | (cdr local-table))))) 28 | 'ok) 29 | (define (dispatch m) 30 | (cond ((eq? m 'lookup-proc) lookup) 31 | ((eq? m 'insert-proc!) insert!) 32 | (else (error "Unknown operation -- TABLE" m)))) 33 | dispatch)) 34 | 35 | (define family (make-table equal?)) 36 | (define put (family 'insert-proc!)) 37 | (define get (family 'lookup-proc)) 38 | (put 'parent 'mom "long") 39 | (put 'parent 'dad "tan") 40 | (put 'cousin 'brother "dan") 41 | (put 'cousin 'sister "xin") 42 | (get 'parent 'dad) 43 | (get 'cousin 'sister) 44 | (get 'grandparent 'grandma) 45 | -------------------------------------------------------------------------------- /1.22.ss: -------------------------------------------------------------------------------- 1 | 2 | ;-------------------------------------------------------- 3 | (require (lib "19.ss" "srfi")) 4 | (display (current-time time-process)) 5 | (define (square x) (* x x)) 6 | 7 | (define (smallest-divisor n) 8 | (find-divisor n 2)) 9 | 10 | (define (find-divisor n test-divisor) 11 | (cond ((> (square test-divisor) n) n) 12 | ((divides? test-divisor n) test-divisor) 13 | (else (find-divisor n (+ test-divisor 1))))) 14 | 15 | (define (divides? a b) 16 | (= (remainder b a) 0)) 17 | 18 | (define (prime? n) 19 | (= n (smallest-divisor n))) 20 | 21 | (define (timed-prime-test n) 22 | (newline) 23 | (display n) 24 | (start-prime-test n (current-time time-process))) 25 | 26 | (define (start-prime-test n start-time) 27 | (if (prime? n) 28 | (report-prime (time-difference (current-time time-process) start-time)) 29 | #f)) ; have timed-prime-test return false 30 | 31 | (define (report-prime elapsed-time) 32 | (display " *** ") 33 | (display (current-time time-process elapsed-time)) 34 | (display "s ") 35 | (display (current-time time-process elapsed-time)) 36 | (display "ns") 37 | #t) ; have timed-prime-test return true 38 | 39 | (define (search-for-primes start count) 40 | (define checked-start (if (even? start) 41 | (+ 1 start) 42 | start)) 43 | (define (iter now count) 44 | (cond ((= 0 count) 45 | (newline) 46 | (display "***** FINISHED *****") 47 | (newline)) 48 | ((timed-prime-test now) (iter (+ 2 now) (- count 1))) 49 | (else (iter (+ 2 now) count)))) 50 | (iter checked-start count)) 51 | 52 | (search-for-primes 10000000000 3) -------------------------------------------------------------------------------- /2.67.ss: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) 2 | (list 'leaf symbol weight)) 3 | 4 | (define (leaf? object) (eq? (car object) 'leaf)) 5 | 6 | (define (symbol-leaf x) (cadr x)) 7 | 8 | (define (weight-leaf x) (caddr x)) 9 | 10 | (define (make-code-tree left right) 11 | (list left 12 | right 13 | (append (symbols left) (symbols right)) 14 | (+ (weight left) (weight right)))) 15 | 16 | (define (left-branch tree) (car tree)) 17 | 18 | (define (right-branch tree) (cadr tree)) 19 | 20 | (define (symbols tree) 21 | (if (leaf? tree) 22 | (list (symbol-leaf tree)) 23 | (caddr tree))) 24 | 25 | (define (weight tree) 26 | (if (leaf? tree) 27 | (weight-leaf tree) 28 | (cadddr tree))) 29 | 30 | (define (decode bits tree) 31 | (define (decode-1 bits current-branch) 32 | (if (null? bits) 33 | '() 34 | (let ((next-branch 35 | (choose-branch (car bits) current-branch))) 36 | (if (leaf? next-branch) 37 | (cons (symbol-leaf next-branch) 38 | (decode-1 (cdr bits) tree)) 39 | (decode-1 (cdr bits) next-branch))))) 40 | (decode-1 bits tree)) 41 | 42 | (define (choose-branch bit branch) 43 | (cond ((= bit 0) (left-branch branch)) 44 | ((= bit 1) (right-branch branch)) 45 | (else (error "bad bit -- CHOOSE-BRANCH" bit)))) 46 | 47 | (define sample-tree 48 | (make-code-tree (make-leaf 'A 4) 49 | (make-code-tree 50 | (make-leaf 'B 2) 51 | (make-code-tree (make-leaf 'D 1) 52 | (make-leaf 'C 1))))) 53 | 54 | (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) 55 | 56 | 57 | (display (decode sample-message sample-tree)) -------------------------------------------------------------------------------- /2.73.ss: -------------------------------------------------------------------------------- 1 | (define (variable? e) (symbol? e)) 2 | (define (same-variable? v1 v2) 3 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 4 | (define (=number? exp num) (and (variable? exp) (= exp num))) 5 | 6 | (define (deriv exp var) 7 | (cond ((number? exp) 0) 8 | ((variable? exp) (if (same-variable? exp var) 1 0)) 9 | (else 10 | ((get 'deriv (operator exp)) (operands exp) var)))) 11 | 12 | (define (operator exp) (car exp)) 13 | 14 | (define (operands exp) (cdr exp)) 15 | 16 | (define (install-sum-package) 17 | (define (addend e) (car e)) 18 | (define (augend e) (cadr e)) 19 | (define (make-sum a1 a2) 20 | (cond ((=number? a1 0) a2) 21 | ((=number? a2 0) a1) 22 | ((and (number? a1) (number? a2)) (+ a1 a2)) 23 | (else (list '+ a1 a2)))) 24 | (define (deriv exp var) 25 | (make-sum (deriv (addend exp) var) 26 | (deriv (augend exp) var))) 27 | 28 | (put 'deriv '(+) deriv) 29 | 'done) 30 | 31 | (define (install-product-package) 32 | (define (multiplier p) (car p)) 33 | (define (multiplicand p) (cadr p)) 34 | (define (make-product m1 m2) 35 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 36 | ((and (number? m1) (number? m2)) (* m1 m2)) 37 | ((=number? m1 1) m2) 38 | ((=number? m2 1) m1) 39 | (else (list '* m1 m2)))) 40 | (define (make-sum a1 a2) 41 | (cond ((=number? a1 0) a2) 42 | ((=number? a2 0) a1) 43 | ((and (number? a1) (number? a2)) (+ a1 a2)) 44 | (else (list '+ a1 a2)))) 45 | (define (deriv exp var) 46 | (make-sum 47 | (make-product (multiplier exp) 48 | (deriv (multiplicand exp) var)) 49 | (make-product (deriv (multiplier exp) var) 50 | (multiplicand exp)))) 51 | 52 | (put 'deriv '(*) deriv) 53 | 'done) -------------------------------------------------------------------------------- /2.89.rkt: -------------------------------------------------------------------------------- 1 | (define (install-thin-poly-package) 2 | (define (make-poly variable term-list) 3 | (cons variable term-list)) 4 | (define (variable p) (car p)) 5 | (define (term-list p) (cdr p)) 6 | (define (empty-termlist? l) (null? l)) 7 | (define (the-empty-list) '()) 8 | (define (first-term l) (car l)) 9 | (define (rest-terms l) (cdr l)) 10 | 11 | (define (add-poly p1 p2) 12 | (if (same-variable? (variable p1) (variable p2)) 13 | (make-poly (variable p1) 14 | (add-terms (term-list p1) 15 | (term-list p2))) 16 | (error "Polys not in same var -- ADD-POLY" (list p1 p2)))) 17 | (define (mul-poly p1 p2) 18 | (if (same-variable? (variable p1) (variable p2)) 19 | (make-poly (variable p1) 20 | (mul-terms (term-list p1) 21 | (term-list p2))) 22 | (error "Polys not in same var -- MUL-POLY" (list p1 p2)))) 23 | 24 | (define (add-terms l1 l2) 25 | (cond ((empty-termlist? l1) l2) 26 | ((empty-termlist? l2) l1) 27 | (else 28 | (cond ((= (length l1) (length l2)) 29 | (accumulate-n add 0 (list l1 l2))) 30 | ((> (length l1) (length l2)) 31 | (cons (car l1) (add-terms (cdr l1) l2))) 32 | ((< (length l1) (length l2)) 33 | (cons (car l2) (add-terms l1 (cdr l2)))))))) 34 | 35 | (define (mul-terms l1 l2) 36 | (if (or (empty-termlist? l1) (empty-termlist? l2)) 37 | (the-empty-list) 38 | (add-terms (mul-term-by-all-terms 39 | (first-term l1) (- (length l1) 1) l2) 40 | (mul-terms (rest-terms l1) l2)))) 41 | (define (get-result order terms) 42 | (if (= order 0) 43 | terms 44 | (get-result (- order 1) (append terms (list 0))))) 45 | (define (mul-term-by-all-terms t1 order terms) 46 | 47 | (if (empty-termlist? terms) 48 | (the-empty-list) 49 | (let ((undone-result (map (lambda (x) (mul x t1)) terms))) 50 | (get-result order undone-result)))) 51 | 52 | 'done) 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /2.56.ss: -------------------------------------------------------------------------------- 1 | ; deriv 2 | (define (deriv exp var) 3 | (cond ((number? exp) 0) 4 | ((variable? exp) 5 | (if (same-variable? exp var) 1 0)) 6 | ((sum? exp) 7 | (make-sum (deriv (addend exp) var) 8 | (deriv (augend exp) var))) 9 | ((product? exp) 10 | (make-sum 11 | (make-product (multiplier exp) 12 | (deriv (multiplicand exp) var)) 13 | (make-product (deriv (multiplier exp) var) 14 | (multiplicand exp)))) 15 | ((exponentiation? exp) 16 | (make-product (make-product (exponent exp) 17 | (make-exponentiation (base exp) (- (exponent exp) 1))) 18 | (deriv (base exp) var))) 19 | (else 20 | (error "unkown expression type -- DERIV" exp)))) 21 | 22 | (define (variable? x) (symbol? x)) 23 | 24 | (define (same-variable? v1 v2) 25 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 26 | 27 | (define (=number? exp num) 28 | (and (number? exp) (= exp num))) 29 | 30 | ; sum 31 | (define (sum? x) 32 | (and (pair? x) (eq? (car x) '+))) 33 | 34 | (define (addend s) (cadr s)) 35 | 36 | (define (augend s) (caddr s)) 37 | 38 | (define (make-sum a1 a2) 39 | (cond ((=number? a1 0) a2) 40 | ((=number? a2 0) a1) 41 | ((and (number? a1) (number? a2)) (+ a1 a2)) 42 | (else (list '+ a1 a2)))) 43 | 44 | ; product 45 | (define (product? x) 46 | (and (pair? x) (eq? (car x) '*))) 47 | 48 | (define (multiplier p) (cadr p)) 49 | 50 | (define (multiplicand p) (caddr p)) 51 | 52 | (define (make-product m1 m2) 53 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 54 | ((=number? m1 1) m2) 55 | ((=number? m2 1) m1) 56 | ((and (number? m1) (number? m2)) (* m1 m2)) 57 | (else (list '* m1 m2)))) 58 | 59 | ; exponentiation 60 | (define (exponentiation? x) 61 | (and (pair? x) (eq? (car x) '**))) 62 | 63 | (define (base e) (cadr e)) 64 | 65 | (define (exponent e) (caddr e)) 66 | 67 | (define (make-exponentiation base exp) 68 | (cond ((=number? exp 0) 1) 69 | ((=number? exp 1) base) 70 | ((and (number? base) (number? exp)) (expt base exp)) 71 | (else (list '** base exp)))) -------------------------------------------------------------------------------- /2.11.ss: -------------------------------------------------------------------------------- 1 | (define (make-interval a b) (cons a b)) 2 | 3 | (define (upper-bound i) (max (car i) (cdr i))) 4 | (define (lower-bound i) (min (car i) (cdr i))) 5 | 6 | (define (mul-interval x y) 7 | (cond ((and (> (lower-bound x) 0) (> (lower-bound y) 0)) 8 | (make-interval (* (lower-bound x) (lower-bound y)) 9 | (* (upper-bound x) (upper-bound y)))) 10 | ((and (< (lower-bound x) 0) (> (upper-bound x) 0) (> (lower-bound y) 0)) 11 | (make-interval (* (lower-bound x) (upper-bound y)) 12 | (* (upper-bound x) (upper-bound y)))) 13 | ((and (< (upper-bound x) 0) (> (lower-bound y) 0)) 14 | (make-interval (* (lower-bound x) (upper-bound y)) 15 | (* (upper-bound x) (lower-bound y)))) 16 | ((and (> (lower-bound x) 0) (< (lower-bound y) 0) (> (upper-bound y) 0)) 17 | (make-interval (* (upper-bound x) (lower-bound y)) 18 | (* (upper-bound x) (upper-bound y)))) 19 | ((and (> (lower-bound x) 0) (< (upper-bound y) 0)) 20 | (make-interval (* (upper-bound x) (lower-bound y)) 21 | (* (lower-bound x) (upper-bound y)))) 22 | ((and (< (lower-bound x) 0) (> (upper-bound x) 0) (< (lower-bound y) 0) (> (upper-bound y) 0)) 23 | (make-interval (* (min (lower-bound x) (lower-bound y)) 24 | (max (upper-bound x) (upper-bound y))) 25 | (max (* (lower-bound x) (lower-bound y)) 26 | (* (upper-bound x) (upper-bound y))))) 27 | ((and (< (upper-bound x) 0) (< (lower-bound y) 0) (> (upper-bound y) 0)) 28 | (make-interval (* (min (lower-bound x) (lower-bound y)) 29 | (upper-bound y)) 30 | (* (lower-bound x) (lower-bound y)))) 31 | ((and (< (lower-bound x) 0) (> (upper-bound x) 0) (< (upper-bound y) 0)) 32 | (make-interval (* (min (lower-bound x) (lower-bound y)) 33 | (upper-bound x)) 34 | (* (lower-bound x) (lower-bound y)))) 35 | ((and (< (upper-bound x) 0) (< (upper-bound y) 0)) 36 | (make-interval (* (upper-bound x) (upper-bound y)) 37 | (* (lower-bound x) (lower-bound y)))))) -------------------------------------------------------------------------------- /stream.rkt: -------------------------------------------------------------------------------- 1 | (define-syntax cons-stream 2 | (syntax-rules () 3 | ((cons-stream obj strm) 4 | (cons obj (delay strm))))) 5 | 6 | (define (stream-car strm) 7 | (car strm)) 8 | 9 | (define (stream-cdr strm) 10 | (force (cdr strm))) 11 | 12 | (define the-empty-stream '()) 13 | 14 | (define stream-null? null?) 15 | 16 | (define (stream-ref s n) 17 | (if (= n 0) 18 | (stream-car s) 19 | (stream-ref (stream-cdr s) (- n 1)))) 20 | 21 | (define (stream-for-each proc s) 22 | (if (stream-null? s) 23 | 'done 24 | (begin (proc (stream-car s)) 25 | (stream-for-each proc (stream-cdr s))))) 26 | 27 | (define (display-stream s) 28 | (stream-for-each display-line s)) 29 | 30 | (define (display-stream-n s n) 31 | (define (display-iter count) 32 | (display-line (stream-ref s count)) 33 | (if (< count n) 34 | (display-iter (+ count 1)) 35 | 'done)) 36 | (display-iter 0)) 37 | 38 | (define (display-line x) 39 | (display x) 40 | (newline)) 41 | 42 | (define (stream-enumerate-interval low high) 43 | (if (> low high) 44 | the-empty-stream 45 | (cons-stream 46 | low 47 | (stream-enumerate-interval (+ low 1) high)))) 48 | 49 | (define (stream-filter pred s) 50 | (cond ((stream-null? s) the-empty-stream) 51 | ((pred (stream-car s)) 52 | (cons-stream 53 | (stream-car s) 54 | (stream-filter pred (stream-cdr s)))) 55 | (else 56 | (stream-filter pred (stream-cdr s))))) 57 | 58 | (define (stream . argstreams) 59 | (if (stream-null? (stream-car argstreams)) 60 | the-empty-stream 61 | (cons-stream 62 | (stream-car argstreams) 63 | (stream (stream-cdr argstreams))))) 64 | 65 | (define (stream-map proc . argstreams) 66 | (if (stream-null? (car argstreams)) 67 | the-empty-stream 68 | (cons-stream 69 | (apply proc (map stream-car argstreams)) 70 | (apply stream-map 71 | (cons proc (map stream-cdr argstreams)))))) 72 | 73 | (define (add-streams s1 s2) 74 | (stream-map + s1 s2)) 75 | 76 | (define (scale-stream s n) 77 | (stream-map (lambda (x) (* x n)) s)) 78 | 79 | (define (integers-starting-from n) 80 | (cons-stream n (integers-starting-from (+ n 1)))) 81 | 82 | (define integers (integers-starting-from 1)) -------------------------------------------------------------------------------- /2.57.ss: -------------------------------------------------------------------------------- 1 | ; deriv 2 | (define (deriv exp var) 3 | (cond ((number? exp) 0) 4 | ((variable? exp) 5 | (if (same-variable? exp var) 1 0)) 6 | ((sum? exp) 7 | (make-sum (deriv (addend exp) var) 8 | (deriv (augend exp) var))) 9 | ((product? exp) 10 | (make-sum 11 | (make-product (multiplier exp) 12 | (deriv (multiplicand exp) var)) 13 | (make-product (deriv (multiplier exp) var) 14 | (multiplicand exp)))) 15 | ((exponentiation? exp) 16 | (make-product (make-product (exponent exp) 17 | (make-exponentiation (base exp) (- (exponent exp) 1))) 18 | (deriv (base exp) var))) 19 | (else 20 | (error "unkown expression type -- DERIV" exp)))) 21 | 22 | (define (variable? x) (symbol? x)) 23 | 24 | (define (same-variable? v1 v2) 25 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 26 | 27 | (define (=number? exp num) 28 | (and (number? exp) (= exp num))) 29 | 30 | ; sum 31 | (define (sum? x) 32 | (and (pair? x) (eq? (car x) '+))) 33 | 34 | (define (addend s) (cadr s)) 35 | 36 | (define (augend s) 37 | (let ((len (length (cddr s)))) 38 | (if (= len 1) 39 | (caddr s) 40 | (cons '+ (cddr s))))) 41 | 42 | 43 | (define (make-sum a1 a2) 44 | (cond ((=number? a1 0) a2) 45 | ((=number? a2 0) a1) 46 | ((and (number? a1) (number? a2)) (+ a1 a2)) 47 | (else (list '+ a1 a2)))) 48 | 49 | ; product 50 | (define (product? x) 51 | (and (pair? x) (eq? (car x) '*))) 52 | 53 | (define (multiplier p) (cadr p)) 54 | 55 | (define (multiplicand p) 56 | (let ((len (length (cddr p)))) 57 | (if (= len 1) 58 | (caddr p) 59 | (cons '* (cddr p))))) 60 | 61 | (define (make-product m1 m2) 62 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 63 | ((=number? m1 1) m2) 64 | ((=number? m2 1) m1) 65 | ((and (number? m1) (number? m2)) (* m1 m2)) 66 | (else (list '* m1 m2)))) 67 | 68 | ; exponentiation 69 | (define (exponentiation? x) 70 | (and (pair? x) (eq? (car x) '**))) 71 | 72 | (define (base e) (cadr e)) 73 | 74 | (define (exponent e) (caddr e)) 75 | 76 | (define (make-exponentiation base exp) 77 | (cond ((=number? exp 0) 1) 78 | ((=number? exp 1) base) 79 | ((and (number? base) (number? exp)) (expt base exp)) 80 | (else (list '** base exp)))) -------------------------------------------------------------------------------- /agenda.rkt: -------------------------------------------------------------------------------- 1 | ;; agenda implement 2 | (define (make-time-segment time queue) 3 | (cons time queue)) 4 | 5 | (define (segment-time s) (car s)) 6 | 7 | (define (segment-queue s) (cdr s)) 8 | 9 | (define (make-agenda) (list 0)) 10 | 11 | (define (current-time agenda) (car agenda)) 12 | 13 | (define (set-current-time! agenda time) 14 | (set-car! agenda time)) 15 | 16 | (define (segments agenda) (cdr agenda)) 17 | 18 | (define (set-segments! agenda segments) 19 | (set-cdr! agenda segments)) 20 | 21 | (define (first-segment agenda) (car (segments agenda))) 22 | 23 | (define (rest-segments agenda) (cdr (segments agenda))) 24 | 25 | (define (empty-agenda? agenda) 26 | (null? (segments agenda))) 27 | 28 | (define (add-to-agenda! time action agenda) 29 | (define (belongs-before? segments) 30 | (or (null? segments) 31 | (< time (segment-time (car segments))))) 32 | (define (make-new-time-segment time action) 33 | (let ((q (make-queue))) 34 | (insert-queue! q action) 35 | (make-time-segment time q))) 36 | (define (add-to-segments! segments) 37 | (if (= (segment-time (car segments)) time) 38 | (insert-queue! (segment-queue (car segments)) 39 | action) 40 | (let ((rest (cdr segments))) 41 | (if (belongs-before? rest) 42 | (set-cdr! 43 | segments 44 | (cons (make-new-time-segment time action) 45 | (cdr segments))) 46 | (add-to-segments! rest))))) 47 | (let ((segments (segments agenda))) 48 | (if (belongs-before? segments) 49 | (set-segments! 50 | agenda 51 | (cons (make-new-time-segment time action) 52 | segments)) 53 | (add-to-segments! segments)))) 54 | 55 | (define (remove-first-agenda-item! agenda) 56 | (let ((q (segment-queue (first-segment agenda)))) 57 | (delete-queue! q) 58 | (if (empty-queue? q) 59 | (set-segments! agenda (rest-segments agenda))))) 60 | 61 | (define (first-agenda-item agenda) 62 | (if (empty-agenda? agenda) 63 | (error "Agenda is empty -- FIRST-AGENDA-ITEM") 64 | (let ((first-seg (first-segment agenda))) 65 | (set-current-time! agenda (segment-time first-seg)) 66 | (front-queue (segment-queue first-seg))))) 67 | 68 | ;; a propagate 69 | (define (propagate) 70 | (if (empty-agenda? the-agenda) 71 | 'done 72 | (let ((first-item (first-agenda-item the-agenda))) 73 | (first-item) 74 | (remove-first-agenda-item! the-agenda) 75 | (propagate)))) -------------------------------------------------------------------------------- /2.70.rkt: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) 2 | (list 'leaf symbol weight)) 3 | 4 | (define (leaf? object) 5 | (eq? (car object) 'leaf)) 6 | 7 | (define (symbol-leaf x) (cadr x)) 8 | 9 | (define (weight-leaf x) (caddr x)) 10 | 11 | (define (make-code-tree left right) 12 | (list left 13 | right 14 | (append (symbols left) (symbols right)) 15 | (+ (weight left) (weight right)))) 16 | 17 | (define (left-branch tree) (car tree)) 18 | 19 | (define (right-branch tree) (cadr tree)) 20 | 21 | (define (symbols tree) 22 | (if (leaf? tree) 23 | (list (symbol-leaf tree)) 24 | (caddr tree))) 25 | 26 | (define (weight tree) 27 | (if (leaf? tree) 28 | (weight-leaf tree) 29 | (cadddr tree))) 30 | 31 | (define (encode message tree) 32 | (if (null? message) 33 | '() 34 | (append (encode-symbol (car message) tree) 35 | (encode (cdr message) tree)))) 36 | 37 | (define (encode-symbol sym tree) 38 | (if (eq? (member sym (symbols tree)) #f) 39 | (error "Symbel not in tree -- " sym) 40 | (let ((r-b (right-branch tree)) 41 | (l-b (left-branch tree))) 42 | (if (member sym (symbols l-b)) 43 | (if (leaf? l-b) (list 0) (cons 0 (encode-symbol sym l-b))) 44 | (if (leaf? r-b) (list 1) (cons 1 (encode-symbol sym r-b))))))) 45 | 46 | (define (adjoin-set x set) 47 | (cond ((null? set) (list x)) 48 | ((< (weight x) (weight (car set))) (cons x set)) 49 | (else (cons (car set) 50 | (adjoin-set x (cdr set)))))) 51 | 52 | (define (make-leaf-set pairs) 53 | (if (null? pairs) 54 | '() 55 | (let ((pair (car pairs))) 56 | (adjoin-set (make-leaf (car pair) ; symbol 57 | (cadr pair)) ; frequency 58 | (make-leaf-set (cdr pairs)))))) 59 | 60 | (define (generate-huffman-tree pairs) 61 | (car (successive-merge (make-leaf-set pairs)))) 62 | 63 | ;; iteration 64 | (define (successive-merge pairs) 65 | (if (= (length pairs) 1) 66 | pairs 67 | (successive-merge (adjoin-set 68 | (make-code-tree (car pairs) (cadr pairs)) 69 | (cddr pairs))))) 70 | 71 | (define lyric-tree 72 | (generate-huffman-tree '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YIP 9) (JOB 2) (WAH 1)))) 73 | 74 | (define lyrics '(GET A JOB 75 | SHA NA NA NA NA NA NA NA NA 76 | GET A JOB 77 | SHA NA NA NA NA NA NA NA NA 78 | WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP 79 | SHA BOOM)) 80 | 81 | (display (encode lyrics lyric-tree)) -------------------------------------------------------------------------------- /2.65.ss: -------------------------------------------------------------------------------- 1 | (define (make-tree entry left-tree right-tree) 2 | (list entry left-tree right-tree)) 3 | 4 | (define (entry tree) (car tree)) 5 | 6 | (define (left-branch tree) (cadr tree)) 7 | 8 | (define (right-branch tree) (caddr tree)) 9 | 10 | (define (union-set set1 set2) 11 | (cond ((null? set1) set2) 12 | ((null? set2) set1) 13 | (else 14 | (let ((x1 (car set1)) (x2 (car set2))) 15 | (cond ((= x1 x2) 16 | (cons x1 (union-set (cdr set1) (cdr set2)))) 17 | ((< x1 x2) 18 | (cons x1 (union-set (cdr set1) set2))) 19 | ((> x1 x2) 20 | (cons x2 (union-set set1 (cdr set2))))))))) 21 | 22 | (define (intersection-set set1 set2) 23 | (if (or (null? set1) (null? set2)) 24 | '() 25 | (let ((x1 (car set1)) (x2 (car set2))) 26 | (cond ((= x1 x2) 27 | (cons x1 28 | (intersection-set (cdr set1) (cdr set2)))) 29 | ((< x1 x2) 30 | (intersection-set (cdr set1) set2)) 31 | ((> x1 x2) 32 | (intersection-set set1 (cdr set2))))))) 33 | 34 | (define (tree->list tree) 35 | (if (null? tree) 36 | '() 37 | (append (tree->list (left-branch tree)) 38 | (cons (entry tree) 39 | (tree->list (right-branch tree)))))) 40 | 41 | (define (list->tree elements) 42 | (car (partial-tree elements (length elements)))) 43 | 44 | (define (partial-tree elts n) 45 | (if (= n 0) 46 | (cons '() elts) 47 | (let ((left-size (quotient (- n 1) 2))) 48 | (let ((left-result (partial-tree elts left-size))) 49 | (let ((left-tree (car left-result)) 50 | (non-left-elts (cdr left-result)) 51 | (right-size (- n (+ left-size 1)))) 52 | (let ((this-entry (car non-left-elts)) 53 | (right-result (partial-tree (cdr non-left-elts) right-size))) 54 | (let ((right-tree (car right-result)) 55 | (remaining-elts (cdr right-result))) 56 | (cons (make-tree this-entry left-tree right-tree) 57 | remaining-elts)))))))) 58 | 59 | ; set1 and set2 both tree 60 | (define (union-set-tree set1 set2) 61 | (let ((s1 (tree->list set1)) 62 | (s2 (tree->list set2))) 63 | (list->tree (union-set s1 s2)))) 64 | 65 | (define (intersection-set-tree set1 set2) 66 | (let ((s1 (tree->list set1)) 67 | (s2 (tree->list set2))) 68 | (list->tree (intersection-set s1 s2)))) 69 | 70 | (define (op set1 set2) 71 | (let ((s1 (tree->list set1)) 72 | (s2 (tree->list set2))) 73 | (list->tree (op s1 s2)))) -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ################# 2 | ## Eclipse 3 | ################# 4 | 5 | *.pydevproject 6 | .project 7 | .metadata 8 | bin/ 9 | tmp/ 10 | *.tmp 11 | *.bak 12 | *.swp 13 | *~.nib 14 | local.properties 15 | .classpath 16 | .settings/ 17 | .loadpath 18 | 19 | # External tool builders 20 | .externalToolBuilders/ 21 | 22 | # Locally stored "Eclipse launch configurations" 23 | *.launch 24 | 25 | # CDT-specific 26 | .cproject 27 | 28 | # PDT-specific 29 | .buildpath 30 | 31 | 32 | ################# 33 | ## Visual Studio 34 | ################# 35 | 36 | ## Ignore Visual Studio temporary files, build results, and 37 | ## files generated by popular Visual Studio add-ons. 38 | 39 | # User-specific files 40 | *.suo 41 | *.user 42 | *.sln.docstates 43 | 44 | # Build results 45 | [Dd]ebug/ 46 | [Rr]elease/ 47 | *_i.c 48 | *_p.c 49 | *.ilk 50 | *.meta 51 | *.obj 52 | *.pch 53 | *.pdb 54 | *.pgc 55 | *.pgd 56 | *.rsp 57 | *.sbr 58 | *.tlb 59 | *.tli 60 | *.tlh 61 | *.tmp 62 | *.vspscc 63 | .builds 64 | *.dotCover 65 | 66 | ## TODO: If you have NuGet Package Restore enabled, uncomment this 67 | #packages/ 68 | 69 | # Visual C++ cache files 70 | ipch/ 71 | *.aps 72 | *.ncb 73 | *.opensdf 74 | *.sdf 75 | 76 | # Visual Studio profiler 77 | *.psess 78 | *.vsp 79 | 80 | # ReSharper is a .NET coding add-in 81 | _ReSharper* 82 | 83 | # Installshield output folder 84 | [Ee]xpress 85 | 86 | # DocProject is a documentation generator add-in 87 | DocProject/buildhelp/ 88 | DocProject/Help/*.HxT 89 | DocProject/Help/*.HxC 90 | DocProject/Help/*.hhc 91 | DocProject/Help/*.hhk 92 | DocProject/Help/*.hhp 93 | DocProject/Help/Html2 94 | DocProject/Help/html 95 | 96 | # Click-Once directory 97 | publish 98 | 99 | # Others 100 | [Bb]in 101 | [Oo]bj 102 | sql 103 | TestResults 104 | *.Cache 105 | ClientBin 106 | stylecop.* 107 | ~$* 108 | *.dbmdl 109 | Generated_Code #added for RIA/Silverlight projects 110 | 111 | # Backup & report files from converting an old project file to a newer 112 | # Visual Studio version. Backup files are not needed, because we have git ;-) 113 | _UpgradeReport_Files/ 114 | Backup*/ 115 | UpgradeLog*.XML 116 | 117 | 118 | 119 | ############ 120 | ## Windows 121 | ############ 122 | 123 | # Windows image file caches 124 | Thumbs.db 125 | 126 | # Folder config file 127 | Desktop.ini 128 | 129 | 130 | ############# 131 | ## Python 132 | ############# 133 | 134 | *.py[co] 135 | 136 | # Packages 137 | *.egg 138 | *.egg-info 139 | dist 140 | build 141 | eggs 142 | parts 143 | bin 144 | var 145 | sdist 146 | develop-eggs 147 | .installed.cfg 148 | 149 | # Installer logs 150 | pip-log.txt 151 | 152 | # Unit test / coverage reports 153 | .coverage 154 | .tox 155 | 156 | #Translations 157 | *.mo 158 | 159 | #Mr Developer 160 | .mr.developer.cfg 161 | 162 | # Mac crap 163 | .DS_Store 164 | -------------------------------------------------------------------------------- /3.23.rkt: -------------------------------------------------------------------------------- 1 | ;; make deque by double list 2 | 3 | (define (make-deque) 4 | (let ((deque (cons '() '())) 5 | (front-ptr car) 6 | (rear-ptr cdr) 7 | (set-front-ptr! set-car!) 8 | (set-rear-ptr! set-cdr!)) 9 | 10 | (define (empty-deque? deque) 11 | (null? (front-ptr deque))) 12 | 13 | (define (front-deque) 14 | (if (empty-deque? deque) 15 | (error "FRONT called witn an empty deque" deque)) 16 | (car (front-ptr deque))) 17 | 18 | (define (rear-deque) 19 | (if (empty-deque? deque) 20 | (error "REAR called witn an empty deque" deque) 21 | (car (rear-ptr deque)))) 22 | 23 | (define (front-insert-deque! item) 24 | (let ((new-pair (cons item (cons '() '())))) 25 | (cond ((empty-deque? deque) 26 | (set-front-ptr! deque new-pair) 27 | (set-rear-ptr! deque new-pair) 28 | (print-deque)) 29 | (else 30 | (set-cdr! (cdr (front-ptr deque)) new-pair) 31 | (set-car! (cdr new-pair) (front-ptr deque)) 32 | (set-front-ptr! deque new-pair) 33 | (print-deque))))) 34 | 35 | (define (rear-insert-deque! item) 36 | (let ((new-pair (cons item (cons '() '())))) 37 | (cond ((empty-deque? deque) 38 | (set-front-ptr! deque new-pair) 39 | (set-rear-ptr! deque new-pair) 40 | (print-deque)) 41 | (else 42 | (set-car! (cdr (rear-ptr deque)) new-pair) 43 | (set-cdr! (cdr new-pair) (rear-ptr deque)) 44 | (set-rear-ptr! deque new-pair) 45 | (print-deque))))) 46 | 47 | (define (front-delete-deque!) 48 | (cond ((empty-deque? deque) 49 | (error "DELETE called with an empty deque" deque)) 50 | ((eq? (front-ptr deque) (rear-ptr deque)) 51 | (set-front-ptr! deque '()) 52 | (set-rear-ptr! deque '()) 53 | (print-deque)) 54 | (else 55 | (set-front-ptr! deque (cadr (front-ptr deque))) 56 | (set-cdr! (cdr (front-ptr deque)) '()) 57 | (print-deque)))) 58 | 59 | (define (rear-delete-deque!) 60 | (cond ((empty-deque? deque) 61 | (error "DELETE called with an empty deque" deque)) 62 | ((eq? (front-ptr deque) (rear-ptr deque)) 63 | (set-front-ptr! deque '()) 64 | (set-rear-ptr! deque '()) 65 | (print-deque)) 66 | (else 67 | (set-rear-ptr! deque (cddr (rear-ptr deque))) 68 | (set-car! (cdr (rear-ptr deque)) '()) 69 | (print-deque)))) 70 | 71 | (define (print-deque) 72 | (define (get-deque-iter queue-list ptr) 73 | (if (null? ptr) 74 | queue-list 75 | (get-deque-iter (append queue-list (list (car ptr))) 76 | (cadr ptr)))) 77 | (get-deque-iter '() (front-ptr deque))) 78 | 79 | (define (dispatch m) 80 | (cond ((eq? m 'rear-insert-deque!) rear-insert-deque!) 81 | ((eq? m 'front-insert-deque!) front-insert-deque!) 82 | ((eq? m 'rear-delete-deque!) rear-delete-deque!) 83 | ((eq? m 'front-delete-deque!) front-delete-deque!) 84 | ((eq? m 'front-deque) front-deque) 85 | ((eq? m 'rear-deque) rear-deque) 86 | ((eq? m 'print-deque) print-deque) 87 | (else (error "Unknown request -- MAKE-DEQUE" m)))) 88 | 89 | dispatch)) 90 | 91 | (define d1 (make-deque)) 92 | ((d1 'rear-insert-deque!) 'a) 93 | ((d1 'rear-insert-deque!) 'b) 94 | ((d1 'rear-insert-deque!) 'c) -------------------------------------------------------------------------------- /3.33.rkt: -------------------------------------------------------------------------------- 1 | ; connector implement 2 | (define (make-connector) 3 | (let ((value #f) (informant #f) (constraints '())) 4 | (define (set-my-value newval setter) 5 | (cond ((not (has-value? me)) 6 | (set! value newval) 7 | (set! informant setter) 8 | (for-each-except setter 9 | inform-about-value 10 | constraints)) 11 | ((not (= value newval)) 12 | (error "Constradiction" (list value newval))) 13 | (else 'ignored))) 14 | (define (forget-my-value retractor) 15 | (if (eq? retractor informant) 16 | (begin (set! informant #f) 17 | (for-each-except retractor 18 | inform-about-no-value 19 | constraints)) 20 | 'ignored)) 21 | (define (connect new-constraint) 22 | (if (not (memq new-constraint constraints)) 23 | (set! constraints 24 | (cons new-constraint constraints))) 25 | (if (has-value? me) 26 | (inform-about-value new-constraint)) 27 | 'done) 28 | (define (me request) 29 | (cond ((eq? request 'has-value?) 30 | (if informant #t #f)) 31 | ((eq? request 'value) value) 32 | ((eq? request 'set-value!) set-my-value) 33 | ((eq? request 'forget) forget-my-value) 34 | ((eq? request 'connect) connect) 35 | (else (error "Unknown operation -- CONNECTOR" 36 | request)))) 37 | me)) 38 | 39 | (define (has-value? connector) 40 | (connector 'has-value?)) 41 | 42 | (define (get-value connector) 43 | (connector 'value)) 44 | 45 | (define (set-value! connector new-value informant) 46 | ((connector 'set-value!) new-value informant)) 47 | 48 | (define (forget-value! connector retractor) 49 | ((connector 'forget) retractor)) 50 | 51 | (define (connect connector new-constraint) 52 | ((connector 'connect) new-constraint)) 53 | 54 | (define (for-each-except exception procedure list) 55 | (define (loop items) 56 | (cond ((null? items) 'done) 57 | ((eq? (car items) exception) (loop (cdr items))) 58 | (else (procedure (car items)) 59 | (loop (cdr items))))) 60 | (loop list)) 61 | 62 | (define (inform-about-value constraints) 63 | (constraints 'I-have-a-value)) 64 | 65 | (define (inform-about-no-value constraints) 66 | (constraints 'I-lost-my-value)) 67 | 68 | ; adder 69 | (define (adder a1 a2 sum) 70 | (define (process-new-value) 71 | (cond ((and (has-value? a1) (has-value? a2)) 72 | (set-value! sum 73 | (+ (get-value a1) (get-value a2)) 74 | me)) 75 | ((and (has-value? a1) (has-value? sum)) 76 | (set-value! a2 77 | (- (get-value sum) (get-value a1)) 78 | me)) 79 | ((and (has-value? a2) (has-value? sum)) 80 | (set-value! a1 81 | (- (get-value sum) (get-value a2)) 82 | me)))) 83 | (define (process-forget-value) 84 | (forget-value! sum me) 85 | (forget-value! a1 me) 86 | (forget-value! a2 me) 87 | (process-new-value)) 88 | (define (me request) 89 | (cond ((eq? request 'I-have-a-value) 90 | (process-new-value)) 91 | ((eq? request 'I-lost-my-value) 92 | (process-forget-value)) 93 | (else 94 | (error "Unknown request -- ADDER" request)))) 95 | (connect a1 me) 96 | (connect a2 me) 97 | (connect sum me) 98 | me) 99 | 100 | ; multiplier 101 | (define (multiplier m1 m2 product) 102 | (define (process-new-value) 103 | (cond ((and (has-value? m1) (has-value? m2)) 104 | (set-value! product 105 | (* (get-value a1) (get-value a2)) 106 | me)) 107 | ((and (has-value? m1) (has-value? product)) 108 | (set-value! m2 109 | (/ (get-value product) (get-value m1)) 110 | me)) 111 | ((and (has-value? m2) (has-value? product)) 112 | (set-value! m1 113 | (/ (get-value product) (get-value m2)) 114 | me)))) 115 | (define (process-forget-value) 116 | (forget-value! product me) 117 | (forget-value! m1 me) 118 | (forget-value! m2 me) 119 | (process-new-value)) 120 | (define (me request) 121 | (cond ((eq? request 'I-have-a-value) 122 | (process-new-value)) 123 | ((eq? request 'I-lost-my-value) 124 | (process-forget-value)) 125 | (else 126 | (error "Unknown request -- ADDER" request)))) 127 | (connect m1 me) 128 | (connect m2 me) 129 | (connect product me) 130 | me) 131 | 132 | ; constant 133 | (define (constant value connector) 134 | (define (me request) 135 | (error "Unknown request -- CONSTANT" request)) 136 | (connect connector me) 137 | (set-value! connector value me) 138 | me) 139 | 140 | ; averager 141 | (define (average a b c) 142 | (let ((u (make-connector)) 143 | (x (make-connector))) 144 | (adder a b u) 145 | (constant 2 x) 146 | (multiplier c x u))) 147 | 148 | (define a (make-connector)) 149 | (define b (make-connector)) 150 | (define c (make-connector)) 151 | (average a b c) 152 | (set-value! a 10 'tt) 153 | (set-value! b 20 'tt) 154 | (get-value c) --------------------------------------------------------------------------------