From 96a3779265c2476d25b6a5c6b616aecca3689f07 Mon Sep 17 00:00:00 2001
From: Nguyễn Gia Phong <vn.mcsinyx@gmail.com>
Date: Sat, 12 May 2018 21:44:45 +0700
Subject: Give up the part on package installation in chapter 2 of SICP

---
 sicp/chapter2.rkt | 809 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 809 insertions(+)

(limited to 'sicp/chapter2.rkt')

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))))
-- 
cgit 1.4.1