diff options
| -rw-r--r-- | sicp/chapter2.rkt | 809 | ||||
| -rw-r--r-- | sicp/pict.rkt | 90 |
2 files changed, 899 insertions, 0 deletions
diff --git a/sicp/chapter2.rkt b/sicp/chapter2.rkt index 2915203..9bc6b5b 100644 --- a/sicp/chapter2.rkt +++ b/sicp/chapter2.rkt @@ -50,3 +50,812 @@ (display (y-point P)) (display ")") (newline)) + +; Exercise 2.3 +(define (square x) (* x x)) +(define mk-vec cons) ; Same x-point and y-point +(define (add-vec u v) + (mk-vec (+ (x-point u) (x-point v)) + (+ (y-point u) (y-point v)))) +(define (mul-vec u k) + (mk-vec (* (x-point u) k) (* (y-point u) k))) +(define (sub-vec u v) + (add-vec u (mul-vec v -1))) +(define (len-vec u) + (sqrt (+ (square (x-point u)) (square (y-point u))))) +(define (seg2vec d) + (sub-vec (end-segment d) (start-segment d))) +(define (length-segment d) (len-vec (seg2vec d))) +(define (mk-rect-segs segment height) + ; Let's call the rectangle ABCD and AB is the first segment. + ; Then height is signed and is negative when the angle BAD is negative. + (let* ((vector (seg2vec segment)) + (len (len-vec vector)) + (x (x-point vector)) + (y (y-point vector)) + (AD (mul-vec (mk-vec (- y) x) (/ height len))) + (A (start-segment segment)) + (D (add-vec A AD)) + (segAD (make-segment A D))) + (lambda (m) + (cond ((= m 0) len) + ((= m 1) (abs height)) + ((= m 2) segment) + ((= m 3) segAD) + (else (error "Unexpected value of argument: rect-segs" m)))))) +(define (mk-rect-points A B height) + (let* ((vector (sub-vec B A)) + (len (len-vec vector)) + (x (x-point vector)) + (y (y-point vector)) + (AD (mul-vec (mk-vec (- y) x) (/ height len))) + (D (add-vec A AD))) + (lambda (m) + (cond ((= m 0) len) + ((= m 1) (abs height)) + ((= m 2) B) + ((= m 3) A) + ((= m 4) D) + (else (error "Unexpected value of argument: rect-points" m)))))) +(define (width-rect rect) (rect 0)) +(define (height-rect rect) (rect 1)) +(define (p-rect-segs rect) + (* (+ (width-rect rect) (height-rect rect)) 2)) +(define (s-rect-segs rect) + (* (width-rect rect) (height-rect rect))) + +; Exercise 2.4 +(define (cons-procedural x y) (lambda (m) (m x y))) +(define (car-procedural z) (z (lambda (x y) x))) +(define (cdr-procedural z) (z (lambda (x y) y))) + +; Exercise 2.5 +(define (cons-arithmetic a b) (* (expt 2 a) (expt 3 b))) +(define (car-arithmetic c) + (if (= (remainder c 2) 0) + (inc (car-arithmetic (/ c 2))) + 0)) +(define (cdr-arithmetic c) + (if (= (remainder c 3) 0) + (inc (car-arithmetic (/ c 3))) + 0)) + +; Exercise 2.6 +(define zero (lambda (f) identity)) +(define (add-one n) + (lambda (f) (lambda (x) (f ((n f) x))))) +(define one (lambda (f) (lambda (x) (f x)))) +(define two (lambda (f) (lambda (x) (f (f x))))) +(define (add m n) + (lambda (f) (lambda (x) ((m f) ((n f) x))))) + +; Exercise 2.7 +(define make-interval cons) +(define upper-bound cdr) +(define lower-bound car) +(define (add-interval x y) + (make-interval (+ (lower-bound x) (lower-bound y)) + (+ (upper-bound x) (upper-bound y)))) +; Exercise 2.8 +(define (sub-interval x y) + (make-interval (- (lower-bound x) (upper-bound y)) + (- (upper-bound x) (lower-bound y)))) +(define (mul-interval x y) + (let ((xl (lower-bound x)) + (xu (upper-bound x)) + (yl (lower-bound y)) + (yu (upper-bound y))) + (let ((p1 (* xl yl)) + (p2 (* xl yu)) + (p3 (* xu yl)) + (p4 (* xu yu))) + (make-interval (min p1 p2 p3 p4) + (max p1 p2 p3 p4))))) +; Exercise 2.10 +(define (div-interval x y) + (let ((upper (upper-bound y)) + (lower (lower-bound y))) + (if (<= (* upper lower) 0) + (error "Cannot divide by an interval that spans 0") + (mul-interval x (make-interval (/ 1.0 upper) + (/ 1.0 lower)))))) +; Exercise 2.12 +(define (make-center-percent c p) + (let ((b1 (* c (- 100 p) 0.01)) + (b2 (* c (+ 100 p) 0.01))) + (make-interval (min b1 b2) (max b1 b2)))) +(define (center-interval i) + (/ (+ (lower-bound i) (upper-bound i)) 2)) +(define (percent-interval i) + (let ((u (upper-bound i)) + (l (lower-bound i))) + (/ (- u l) (+ u l) 0.01))) +(define (width-interval i) + (/ (- (upper-bound i) (lower-bound i)) 2)) +; Exercise 2.13 +(define (par1 r1 r2) + (div-interval (mul-interval r1 r2) + (add-interval r1 r2))) +(define (par2 r1 r2) + (let ((one (make-interval 1 1))) + (div-interval one + (add-interval (div-interval one r1) + (div-interval one r2))))) + +; Exercise 2.17 +(define (last-pair items) + (let ((coulder (cdr items))) + (if (null? coulder) + items + (last-pair coulder)))) + +; Exercise 2.18 +(define (reverse l) + (define (reverse-iter l r) + (if (null? l) + r + (reverse-iter (cdr l) (cons (car l) r)))) + (reverse-iter l nil)) + +; Exercise 2.19 +(define (cc amount coin-values) + (define first-denomination car) + (define except-first-denomination cdr) + (define no-more? null?) + (cond ((= amount 0) 1) + ((or (< amount 0) (no-more? coin-values)) 0) + (else (+ (cc amount + (except-first-denomination coin-values)) + (cc (- amount (first-denomination coin-values)) + coin-values))))) + +; Exercise 2.20 +(define (same-parity first . remain) + (define (same-parity-iter checker l) + (if (null? l) + nil + (let ((carl (car l)) + (coulder (same-parity-iter checker (cdr l)))) + (if (checker carl) + (cons carl coulder) + coulder)))) + (cons first (same-parity-iter (if (even? first) even? odd?) remain))) + +; Exercise 2.21 +(define (square-list-by-hand items) + (if (null? items) + nil + (cons (square (car items)) + (square-list-by-hand (cdr items))))) +(define (square-list items) (map square items)) + +; Exercise 2.23 +(define (phor-each f l) + (if (not (null? l)) + (begin (f (car l)) + (phor-each f (cdr l))))) + +; Exercise 2.25 +(define (last-of-nest l) + (cond ((not (pair? l)) l) + ((or (null? (cdr l)) (pair? (car l))) (last-of-nest (car l))) + (else (last-of-nest (cdr l))))) + +; Exercise 2.27 +(define (deep-reverse l) + (define (deep-iter l r) + (cond ((null? l) r) + ((pair? l) (deep-iter (cdr l) + (cons (deep-reverse (car l)) r))) + (else l))) + (deep-iter l nil)) + +; Exercise 2.28 +(define (fringe l) + (cond ((null? l) nil) + ((pair? l) (append (fringe (car l)) + (fringe (cdr l)))) + (else (list l)))) + +; Exercise 2.29 +(define (make-mobile left right) (list left right)) +(define (make-branch len struct) (cons len struct)) +(define left-branch car) +(define right-branch cadr) +(define branch-length car) +(define branch-structure cdr) +(define (total-weight mobile) + (if (pair? mobile) + (+ (total-weight (branch-structure (left-branch mobile))) + (total-weight (branch-structure (right-branch mobile)))) + mobile)) +(define (balanced-mobile? mobile) + (if (pair? mobile) + (let ((left (left-branch mobile)) + (right (right-branch mobile))) + (let ((left-struct (branch-structure left)) + (right-struct (branch-structure right))) + (and (= (* (total-weight left-struct) + (branch-length left)) + (* (total-weight right-struct) + (branch-length right))) + (balanced-mobile? left-struct) + (balanced-mobile? right-struct)))) + true)) + +; Exercise 2.30 +(define (square-tree-by-hand tree) + (cond ((null? tree) nil) + ((pair? tree) (cons (square-tree-by-hand (car tree)) + (square-tree-by-hand (cdr tree)))) + (else (square tree)))) +(define (square-tree tree) + (map (lambda (subtree) + (if (pair? subtree) + (square-tree subtree) + (square subtree))) + tree)) + +; Exercise 2.31 +(define (tree-map mapping tree) + (map (lambda (subtree) + (if (pair? subtree) + (tree-map mapping subtree) + (mapping subtree))) + tree)) + +; Exercise 2.32 +(define (subsets s) + (if (null? s) + (list nil) + (let ((rest (subsets (cdr s))) + (first (car s))) + (append rest + (map (lambda (subset) (cons first subset)) + rest))))) + +(define (filter predicate sequence) + (cond ((null? sequence) nil) + ((predicate (car sequence)) (cons (car sequence) + (filter predicate (cdr sequence)))) + (else (filter predicate (cdr sequence))))) +(define (accumulate op last sequence) + (if (null? sequence) + last + (op (car sequence) + (accumulate op last (cdr sequence))))) +(define (enumerate-interval low high) + (if (> low high) + nil + (cons low (enumerate-interval (inc low) high)))) +(define enumerate-tree fringe) + +; Exercise 2.33 +(define (map-accum p sequence) + (accumulate (lambda (x y) (cons (p x) y)) + nil + sequence)) +(define (append-accum seq1 seq2) + (accumulate cons seq2 seq1)) +(define (length-accum sequence) + (accumulate (lambda (current rest) (inc rest)) 0 sequence)) + +; Exercise 2.34 +(define (horner-eval x coefficient-sequence) + (accumulate (lambda (this-coeff higher-terms) + (+ this-coeff (* x higher-terms))) + 0 + coefficient-sequence)) + +; Exercise 2.35 +(define (count-leaves t) + (accumulate + 0 (map (lambda (x) (if (pair? x) (count-leaves x) 1)) t))) + +; Exercise 2.36 +(define (accumulate-n op last seqs) + (if (null? (car seqs)) + nil + (cons (accumulate op last (map car seqs)) + (accumulate-n op last (map cdr seqs))))) + +; Exercise 2.37 +(define (dot-product v w) (accumulate + 0 (map * v w))) +(define (matrix-*-vector m v) + (map (lambda (vector) (dot-product vector v)) m)) +(define (transpose m) + (accumulate-n cons nil m)) +(define (matrix-*-matrix m n) + (let ((cols (transpose n))) + (map (lambda (vec) (matrix-*-vector cols vec)) m))) + +; Exercise 2.38 +(define fold-right accumulate) +(define (fold-left op initial sequence) + (define (iter result rest) + (if (null? rest) + result + (iter (op result (car rest)) + (cdr rest)))) + (iter initial sequence)) + +; Exercise 2.39 +(define (reverse-left sequence) + (fold-left (lambda (x y) (cons y x)) nil sequence)) +(define (reverse-right sequence) + (fold-right (lambda (x y) (append y (list x))) nil sequence)) + +(define (smallest-divisor n) + (define (find-divisor test-divisor) + (cond ((> (square test-divisor) n) n) + ((= (remainder n test-divisor) 0) test-divisor) + (else (find-divisor (+ test-divisor 2))))) + (if (even? n) 2 (find-divisor 3))) +(define (prime? n) (and (> n 1) (= (smallest-divisor n) n))) +(define (prime-sum? pair) (prime? (+ (car pair) (cdr pair)))) + +(define (flatmap proc seq) (accumulate append nil (map proc seq))) +(define (make-pair-sum pair) + (let ((a (car pair)) + (d (cdr pair))) + (list a d (+ a d)))) +; Exercise 2.40 +(define (unique-pairs low high) + (flatmap (lambda (i) + (map (lambda (j) (cons i j)) + (enumerate-interval low (dec i)))) + (enumerate-interval (inc low) high))) +(define (prime-sum-pairs n) + (map make-pair-sum + (filter prime-sum? (unique-pairs 1 n)))) + +(define (remove item sequence) + (filter (lambda (x) (not (= x item))) + sequence)) +(define (permutations s) + (if (null? s) + (list nil) + (flatmap (lambda (x) + (map (lambda (p) (cons x p)) + (permutations (remove x s)))) + s))) + +; Exercise 2.41 +(define (triples-of-sum s n) + (define (unique-triples low high) + (flatmap (lambda (i) + (map (lambda (pair) (list i (car pair) (cdr pair))) + (unique-pairs low (dec i)))) + (enumerate-interval (+ low 2) high))) + (filter (lambda (triple) (= (accumulate + 0 triple) s)) + (unique-triples 1 n))) + +; Exercise 2.42 +(define (queens board-size) + (define empty-board nil) + (define (adjoin-position row col lst) + (cons (cons row col) lst)) + (define (safe? k positions) + (if (= k 1) + true + (let ((row (car (car positions))) + (rest (cdr positions))) + (accumulate (lambda (x y) (and x y)) + true + (map (lambda (v) + (let ((x (car v)) + (y (cdr v))) + (not (or (= x row) + (= (abs (/ (- x row) (- y k))) 1))))) + rest))))) + (define (queen-cols k) + (if (= k 0) + (list empty-board) + (filter (lambda (positions) (safe? k positions)) + (flatmap (lambda (rest-of-queens) + (map (lambda (new-row) + (adjoin-position new-row + k + rest-of-queens)) + (enumerate-interval 1 board-size))) + (queen-cols (- k 1)))))) + (queen-cols board-size)) + +; Exercise 2.54 +(define (equal?? a b) + (let ((pa (pair? a)) + (pb (pair? b))) + (cond ((and pa pb) (and (equal?? (car a) (car b)) + (equal?? (cdr a) (cdr b)))) + ((not (or pa pb)) (eq? a b)) + (else false)))) + +(define variable? symbol?) +(define (same-variable? v1 v2) + (and (variable? v1) (variable? v2) (eq? v1 v2))) +(define (=number? poly num) + (and (number? poly) (= poly num))) + +; Exercise 2.57 +(define (make-sum a1 a2) + (cond ((=number? a1 0) a2) + ((=number? a2 0) a1) + ((and (number? a1) (number? a2)) (+ a1 a2)) + (else (list '+ a1 a2)))) +(define (sum? x) (and (pair? x) (eq? (car x) '+))) +(define addend cadr) +(define (augend x) + (let ((dd (cddr x))) + (if (null? (cdr dd)) (car dd) (cons '* dd)))) + +(define (make-product m1 m2) + (cond ((or (=number? m1 0) (=number? m2 0)) 0) + ((=number? m1 1) m2) + ((=number? m2 1) m1) + ((and (number? m1) (number? m2)) (* m1 m2)) + (else (list '* m1 m2)))) +(define (product? x) (and (pair? x) (eq? (car x) '*))) +(define multiplier cadr) +(define (multiplicand x) + (let ((dd (cddr x))) + (if (null? (cdr dd)) (car dd) (cons '* dd)))) + +; Exercise 2.56 +(define (make-exponentiation u n) + (cond ((=number? n 0) 1) + ((=number? n 1) u) + ((and (number? u) (number? n)) (expt u n)) + (else (list '** u n)))) +(define (exponentiation? x) (and (pair? x) (eq? (car x) '**))) +(define base cadr) +(define exponent caddr) + +(define (deriv poly var) + (cond ((number? poly) 0) + ((variable? poly) (if (same-variable? poly var) 1 0)) + ((sum? poly) (make-sum (deriv (addend poly) var) + (deriv (augend poly) var))) + ((product? poly) (let ((u (multiplier poly)) + (v (multiplicand poly))) + (make-sum (make-product u (deriv v var)) + (make-product (deriv u var) v)))) + ((exponentiation? poly) + (let ((u (base poly)) + (n (exponent poly))) + (make-product (make-product n (make-exponentiation u (make-sum n -1))) + (deriv u var)))) + (else (error "unknown expression type: DERIV" poly)))) + +; Exercise 2.58 +(define (memq item x) + (cond ((null? x) false) + ((eq? (car x) item) x) + (else (memq item (cdr x))))) +(define (make-infix-sum a b) + (cond ((=number? a 0) b) + ((=number? b 0) a) + ((and (number? a) (number? b)) (+ a b)) + (else (list a '+ b)))) +(define (sum-infix? x) (memq '+ x)) +(define (addend-infix x) + (define (iter a b) + (if (eq? (car b) '+) + a + (iter (append a (list (car b))) (cdr b)))) + (if (eq? (cadr x) '+) + (car x) + (iter '() x))) +(define (augend-infix x) + (let ((b (cdr (memq '+ x)))) + (if (null? (cdr b)) (car b) b))) + +(define (make-infix-product a b) + (cond ((or (=number? a 0) (=number? b 0)) 0) + ((=number? a 1) b) + ((=number? b 1) a) + ((and (number? a) (number? b)) (* a b)) + (else (list a '* b)))) +(define (product-infix? x) + (and (not (sum-infix? x)) + (memq '* x))) +(define multiplier-infix car) +(define (multiplicand-infix x) + (let ((b (cddr x))) + (if (null? (cdr b)) (car b) b))) + +(define (deriv-infix poly var) + (cond ((number? poly) 0) + ((variable? poly) (if (same-variable? poly var) 1 0)) + ((sum-infix? poly) + (make-infix-sum (deriv-infix (addend-infix poly) var) + (deriv-infix (augend-infix poly) var))) + ((product-infix? poly) + (let ((u (multiplier-infix poly)) + (v (multiplicand-infix poly))) + (make-infix-sum (make-infix-product u (deriv-infix v var)) + (make-infix-product (deriv-infix u var) v)))) + (else (error "unknown expression type: DERIV" poly)))) + +(define (element-of-uset? x uset) + (cond ((null? uset) false) + ((equal? x (car uset)) true) + (else (element-of-uset? x (cdr uset))))) +(define (adjoin-uset x uset) + (if (element-of-uset? x uset) + uset + (cons x uset))) +(define (intersection-uset uset1 uset2) + (cond ((or (null? uset1) (null? uset2)) '()) + ((element-of-uset? (car uset1) uset2) + (cons (car uset1) (intersection-uset (cdr uset1) uset2))) + (else (intersection-uset (cdr uset1) uset2)))) +; Exercise 2.59 +(define (union-uset uset1 uset2) + (if (null? uset1) + uset2 + (union-uset (cdr uset1) (adjoin-uset (car uset1) uset2)))) + +; Exercise 2.60 +(define element-of-dset? element-of-uset?) +(define adjoin-dset cons) +(define intersection-dset intersection-uset) +(define union-dset append) + +(define (element-of-oset? x oset) + (cond ((null? oset) false) + ((= x (car oset)) true) + ((< x (car oset)) false) + (else (element-of-oset? x (cdr oset))))) +(define (intersection-oset oset1 oset2) + (if (or (null? oset1) (null? oset2)) + '() + (let ((x1 (car oset1)) + (x2 (car oset2))) + (cond ((= x1 x2) (cons x1 (intersection-oset (cdr oset1) (cdr oset2)))) + ((< x1 x2) (intersection-oset (cdr oset1) oset2)) + ((> x1 x2) (intersection-oset oset1 (cdr oset2))))))) +; Exercise 2.61 +(define (adjoin-oset x oset) + (if (null? oset) + (cons x '()) + (let ((a (car oset))) + (cond ((< x a) (cons x oset)) + ((= x a) oset) + (else (cons a (adjoin-oset x (cdr oset)))))))) +; Exercise 2.62 +(define (union-oset oset1 oset2) + (if (or (null? oset1) (null? oset2)) + '() + (let ((x1 (car oset1)) + (x2 (car oset2))) + (cond ((= x1 x2) (cons x1 (union-oset (cdr oset1) (cdr oset2)))) + ((< x1 x2) (cons x1 (union-oset (cdr oset1) oset2))) + (else (cons x2 (union-oset oset1 (cdr oset2)))))))) + +(define (make-tree entry left right) + (list entry left right)) +(define tree-entry car) +(define tree-left cadr) +(define tree-right caddr) +(define (element-of-tset? x tset) + (if (null? tset) + false + (let ((entry (tree-entry tset))) + (cond ((< x entry) (element-of-tset? x (tree-left tset))) + ((> x entry) (element-of-tset? x (tree-right tset))) + (else true))))) +(define (adjoin-tset x tset) + (if (null? tset) + (make-tree x '() '()) + (let ((entry (tree-entry tset)) + (left (tree-left tset)) + (right (tree-right tset))) + (cond ((< x entry) (make-tree entry (adjoin-tset x left) right)) + ((> x entry) (make-tree entry left (adjoin-tset x right))) + (else tset))))) + +; Exercise 2.63 +(define (tree->list tree) + (define (iter rest result) + (if (null? rest) + result + (iter (tree-left rest) + (cons (tree-entry rest) + (iter (tree-right rest) result))))) + (iter tree '())) + +; Exercise 2.64 +(define (list->tree elements) + (define (partial-tree elts size) + (if (= size 0) + (cons '() elts) + (let* ((left-size (quotient (dec size) 2)) + (right-size (- size left-size 1)) + (left-result (partial-tree elts left-size)) + (left-tree (car left-result)) + (non-left-elts (cdr left-result)) + (right-result (partial-tree (cdr non-left-elts) right-size)) + (right-tree (car right-result)) + (this-entry (car non-left-elts)) + (remaining-elts (cdr right-result))) + (cons (make-tree this-entry left-tree right-tree) + remaining-elts)))) + (car (partial-tree elements (length elements)))) + +; Exercise 2.65 +(define (union-tset tset1 tset2) + (list->tree (union-oset (tree->list tset1) + (tree->list tset2)))) +(define (intersection-tset tset1 tset2) + (list->tree (intersection-oset (tree->list tset1) + (tree->list tset2)))) + +; Exercise 2.66 +(define (lookup-tset given-key tset-of-records) + (define key identity) + (if (null? tset-of-records) + false + (let ((current-key (key (tree-entry tset-of-records)))) + (cond ((< given-key current-key) + (lookup-tset given-key (tree-left tset-of-records))) + ((> given-key current-key) + (lookup-tset given-key (tree-right tset-of-records))) + (else (tree-entry tset-of-records)))))) + +(define (make-leaf symbol weight) (list 'leaf symbol weight)) +(define (leaf? object) (eq? (car object) 'leaf)) +(define (symbol-leaf x) (cadr x)) +(define (weight-leaf x) (caddr x)) +(define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) +(define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) +(define (make-code-tree left right) + (list left + right + (append (symbols left) (symbols right)) + (+ (weight left) (weight right)))) +(define (decode bits tree) + (define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "bad bit: CHOOSE-BRANCH" bit)))) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ((next-branch (choose-branch (car bits) current-branch))) + (if (leaf? next-branch) + (cons (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) next-branch))))) + (decode-1 bits tree)) +(define (adjoin-set x set) + (cond ((null? set) (list x)) + ((< (weight x) (weight (car set))) (cons x set)) + (else (cons (car set) + (adjoin-set x (cdr set)))))) +(define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ((pair (car pairs))) + (adjoin-set (make-leaf (car pair) (cadr pair)) + (make-leaf-set (cdr pairs)))))) + +; Exercise 2.68 +(define (encode message tree) + (define (encode-symbol symbol tree) + (if (leaf? tree) + '() + (let ((left (left-branch tree)) + (right (right-branch tree))) + (cond ((element-of-uset? symbol (symbols left)) + (cons 0 (encode-symbol symbol left))) + ((element-of-uset? symbol (symbols right)) + (cons 1 (encode-symbol symbol right))) + (else (error "symbol is not in tree: ENCODE-SYMBOL" symbol)))))) + (if (null? message) + '() + (append (encode-symbol (car message) tree) + (encode (cdr message) tree)))) + +; Exercise 2.69 +(define (generate-huffman-tree pairs) + (define (successive-merge pairs) + (if (< (length pairs) 2) + (car pairs) + (successive-merge (adjoin-set (make-code-tree (car pairs) (cadr pairs)) + (cddr pairs))))) + (successive-merge (make-leaf-set pairs))) + +; Exercise 2.70 +(define lyrics + (encode '(Get a job + Sha na na na na na na na na + Get a job + Sha na na na na na na na na + Wah yip yip yip yip yip yip yip yip yip + Sha boom) + (generate-huffman-tree '((a 2) (Get 2) (Sha 3) (Wah 1) + (boom 1) (job 2) (na 16) (yip 9))))) + +; Exercise 2.71 +(define (encoded-size n) + (let* ((alphabet (enumerate-interval 0 (dec n))) + (tree (generate-huffman-tree (map (lambda (k) (list k (expt 2 k))) + alphabet)))) + (map (lambda (k) (length (encode (list k) tree))) alphabet))) + +(define attach-tag cons) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum: TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum: CONTENTS" datum))) + +(define (rectangular? z) (eq? (type-tag z) 'rectangular)) +(define (polar? z) (eq? (type-tag z) 'polar)) + +(define (real-part-rectangular z) (car z)) +(define (imag-part-rectangular z) (cdr z)) +(define (magnitude-rectangular z) + (sqrt (+ (square (real-part-rectangular z)) + (square (imag-part-rectangular z))))) +(define (angle-rectangular z) + (atan (imag-part-rectangular z) + (real-part-rectangular z))) +(define (make-from-real-imag-rectangular x y) + (attach-tag 'rectangular (cons x y))) +(define (make-from-mag-ang-rectangular r a) + (attach-tag 'rectangular + (cons (* r (cos a)) (* r (sin a))))) + +(define (real-part-polar z) + (* (magnitude-polar z) (cos (angle-polar z)))) +(define (imag-part-polar z) + (* (magnitude-polar z) (sin (angle-polar z)))) +(define (magnitude-polar z) (car z)) +(define (angle-polar z) (cdr z)) +(define (make-from-real-imag-polar x y) + (attach-tag 'polar + (cons (sqrt (+ (square x) (square y))) + (atan y x)))) +(define (make-from-mag-ang-polar r a) + (attach-tag 'polar (cons r a))) + +(define (real-part z) + (cond ((rectangular? z) (real-part-rectangular (contents z))) + ((polar? z) (real-part-polar (contents z))) + (else (error "Unknown type: REAL-PART" z)))) +(define (imag-part z) + (cond ((rectangular? z) (imag-part-rectangular (contents z))) + ((polar? z) (imag-part-polar (contents z))) + (else (error "Unknown type: IMAG-PART" z)))) +(define (magnitude z) + (cond ((rectangular? z) (magnitude-rectangular (contents z))) + ((polar? z) (magnitude-polar (contents z))) + (else (error "Unknown type: MAGNITUDE" z)))) +(define (angle z) + (cond ((rectangular? z) (angle-rectangular (contents z))) + ((polar? z) (angle-polar (contents z))) + (else (error "Unknown type: ANGLE" z)))) + +(define make-from-real-imag make-from-real-imag-rectangular) +(define make-from-mag-ang make-from-mag-ang-polar) +(define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) +(define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) +(define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) +(define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) diff --git a/sicp/pict.rkt b/sicp/pict.rkt new file mode 100644 index 0000000..ca52e4e --- /dev/null +++ b/sicp/pict.rkt @@ -0,0 +1,90 @@ +#lang sicp +(#%require sicp-pict) + +(define (flipped-pairs painter) + (let ((painter2 (beside painter (flip-vert painter)))) + (below painter2 painter2))) + +(define (right-spilt painter n) + (if (= n 0) + painter + (let ((smaller (right-spilt painter (dec n)))) + (beside painter (below smaller smaller))))) + +(define (up-split painter n) + (if (= n 0) + painter + (let ((smaller (up-split painter (dec n)))) + (below painter (beside smaller smaller))))) + +(define (corner-spilt painter n) + (if (= n 0) + painter + (let ((up (up-split painter (dec n))) + (right (right-spilt painter (dec n)))) + (let ((top-left (beside up up)) + (bottom-right (below right right)) + (corner (corner-spilt painter (dec n)))) + (beside (below painter top-left) + (below bottom-right corner)))))) + +(define (square-limit painter n) + (let ((quarter (corner-spilt painter n))) + (let ((half (beside (flip-horiz quarter) quarter))) + (below (flip-vert half) half)))) + +(define (square-of-four tl tr bl br) + (lambda (painter) + (let ((top (beside (tl painter) (tr painter))) + (bottom (beside (bl painter) (br painter)))) + (below bottom top)))) + +(define (split children-parent children) + (lambda (parent n) + (if (= n 0) + parent + (let ((child ((split children-parent children) parent (dec n)))) + (children-parent parent (children child child)))))) + +(define make-vect cons) +(define xcor-vect car) +(define ycor-vect cdr) +(define (add-vect v1 v2) + (make-vect (+ (xcor-vect v1) (xcor-vect v2)) + (+ (ycor-vect v1) (ycor-vect v2)))) +(define (sub-vect v1 v2) + (make-vect (- (xcor-vect v1) (xcor-vect v2)) + (- (ycor-vect v1) (ycor-vect v2)))) +(define (scale-vect s v) + (make-vect (* s (xcor-vect v)) + (* s (ycor-vect v)))) + +(define (make-frame origin edge1 edge2) + (cons origin (cons edge1 edge2))) +(define origin-frame car) +(define edge1-frame cadr) +(define edge2-frame cddr) + +(define (outline frame) + (segments->painter (list (make-segment (make-vect 0 0) + (make-vect 1 0)) + (make-segment (make-vect 1 0) + (make-vect 1 1)) + (make-segment (make-vect 1 1) + (make-vect 0 1)) + (make-segment (make-vect 0 1) + (make-vect 0 0))))) +(define (xxx frame) + (segments->painter (list (make-segment (make-vect 0 0) + (make-vect 1 1)) + (make-segment (make-vect 1 0) + (make-vect 0 1))))) +(define (diamond frame) + (segments->painter (list (make-segment (make-vect 0.5 0.0) + (make-vect 1.0 0.5)) + (make-segment (make-vect 1.0 0.5) + (make-vect 0.5 1.0)) + (make-segment (make-vect 0.5 1.0) + (make-vect 0.0 0.5)) + (make-segment (make-vect 0.0 0.5) + (make-vect 0.5 0.0))))) |