1(define (make-rat n d)
2  (let ((g (gcd n d)))
3    (if (< d 0)
4        (cons (/ (- n) g) (/ (- d) g))
5        (cons (/ n g) (/ d g)))))

 1(define (print-point p)
 2  (newline)
 3  (display "(")
 4  (display (x-point p))
 5  (display ",")
 6  (display (y-point p))
 7  (display ")"))
 8
 9(define make-point cons)
10
11(define x-point car)
12
13(define y-point cdr)
14
15(define (make-segement start end)
16  (cons start end))
17
18(define (start-segement segement)
19  (car segement))
20
21(define (end-segement segement)
22  (cdr segement))
23
24(define (midpoint-segement segement)
25  (make-point (/ (+ (x-point (start-segement segement)) (x-point (end-segement segement))) 2.0)
26              (/ (+ (y-point (start-segement segement)) (y-point (end-segement segement))) 2.0)))
27
28(define x (make-point 1 5))
29(define y (make-point 5 8))
30
31(define segement (make-segement x y))
32
33(print-point (midpoint-segement segement))

 1(define (abs x)
 2  (if (< x 0)
 3      (- x)
 4      x))
 5
 6(define make-rectangle make-segement)
 7
 8(define (width-rectangle rectangle)
 9  (abs (- (x-point (start-segement rectangle)) (x-point (end-segement rectangle)))))
10
11(define (height-rectangle rectangle)
12  (abs (- (y-point (start-segement rectangle)) (y-point (end-segement rectangle)))))
13
14(define (perimeter rectangle)
15  (* (+ (width-rectangle rectangle) (height-rectangle rectangle)) 2))
16
17(define (area rectangle)
18  (* (width-rectangle rectangle) (height-rectangle rectangle)))
19
20(define rec (make-rectangle x y))
21
22(perimeter rec)
23
24(area rec)

1((lambda (m) (m x y)) (lambda (p q) p))

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

 1(define (cons a b)
 2  (* (expt 2 a) (expt 3 b)))
 3
 4(define (car x)
 5  (if (= 0 (remainder x 2))
 6      (+ 1 (car (/ x 2)))
 7      0))
 8
 9(define (cdr x)
10  (if (= 0 (remainder x 3))
11      (+ 1 (cdr (/ x 3)))
12      0))

1(define (make-interval a b) (cons a b))
2
3(define (lower-bound interval) (car interval))
4
5(define (upper-bound interval) (cdr interval))

1(define (sub-interval x y)
2  (make-interval (- (lower-bound x) (upper-bound y))
3                 (- (upper-bound x) (lower-bound y))))

1(define (div-interval x y)
2  (if (< 0 (/ (upper-bound y) (lower-bound y)))
3    0
4    (mul-interval x
5                  (make-interval
6                    (/ 1.0 (upper-bound y))
7                    (/ 1.0 (lower-bound y))))))  

 1(define (make-center-width c w)
 2   (make-interval (- c w) (+ c w)))
 3
 4(define (center i)
 5   (/ (+ (lower-bound i) (upper-bound i)) 2))
 6
 7(define (width i)
 8   (/ (- (upper-bound i) (lower-bound i)) 2))
 9
10(define (make-center-percent c p)
11  (make-center-width c (* c p)))
12;center can not be zero
13(define (percent i)
14  (/ (width i) (center i)))

1(define (last-pair items)
2  (if (null? (cdr items))
3      items
4      (last-pair (cdr items))))

1(define (reverse items)
2  (if (null? items)
3      '()
4      (append (reverse (cdr items)) (list (car items)))))

 1(define (first-denomination coin-values)
 2    (car coin-values))
 3
 4(define (except-first-denomination coin-values)
 5    (cdr coin-values))
 6
 7(define (no-more? coin-values)
 8    (null? coin-values))
 9
10(define (cc amount coin-values)
11    (cond ((= amount 0)
12            1)
13          ((or (< amount 0) (no-more? coin-values))
14            0)
15          (else
16            (+ (cc amount
17                   (except-first-denomination coin-values))
18               (cc (- amount
19                      (first-denomination coin-values))
20                   coin-values)))))

1(define (same-parity first . others)
2  (define (iter items res)
3    (cond ((null? items) (reverse res))
4          ((= (remainder (car items) 2) (remainder first 2))
5           (iter (cdr items) (cons (car items) res)))
6          (else (iter (cdr items) res))))
7  (iter (cons first others) '()))

1(define (square-list items)
2    (if (null? items)
3        '()
4        (cons (square (car items))
5              (square-list (cdr items)))))
6
7(define (square-list items)
8    (map square items))

1(define (square-list items)
2    (define (iter things answer)
3        (if (null? things)
4            (reverse answer) ;modified
5            (iter (cdr things)  
6                  (cons (square (car things))
7                        answer))))
8    (iter items '()))

1(define (for-each f items)
2  (cond ((not (null? items))
3         (f (car items))
4        (for-each f (cdr items)))))

1(1 (2 (3 4)))

 1(define a (list 1 3 (list 5 7) 9))
 2
 3(car (cdr (car (cdr (cdr a)))))
 4(cadr (caddr a))
 5
 6
 7(define b (list (list 7)))
 8
 9(car (car b))
10(caar b)
11
12(define c (list 1 (list 2(list 3 (list 4(list 5(list 6 7)))))))
13(cadr (cadr (cadr (cadr (cadr (cadr c))))))

 1(define (deep-reverse items)
 2  (define (iter things answer)
 3    (cond ((null? things) answer)
 4          ((not (pair? (car things)))
 5           (iter (cdr things) (cons (car things) answer)))
 6          (else (iter (cdr things) (cons (deep-reverse (car things)) answer)))))
 7  (iter items nil))
 8
 9(define x (list (list 1 2) (list 3 4)))
10
11> (deep-reverse x)
12((4 3) (2 1))
13> (deep-reverse (list (list 1 2) (list 3 4) (list 5 6)))
14((6 5) (4 3) (2 1))

 1(define (fringe tree)
 2  (cond ((null? tree) nil)
 3        ((not (pair? tree)) (list tree))
 4        (else (append (fringe (car tree))
 5                 (fringe (cdr tree))))))
 6
 7> (fringe x)
 8(1 2 3 4)
 9> (fringe (list x x))
10(1 2 3 4 1 2 3 4)

 1(define (make-mobile left right)
 2  (list left right))
 3
 4(define (make-branch length structure)
 5  (list length structure))
 6
 7;Q(a)
 8(define (left-branch mobile)
 9  (car mobile))
10
11(define (right-branch mobile)
12  (cadr mobile))
13
14(define (branch-length branch)
15  (car branch))
16
17(define (branch-structure branch)
18  (cadr branch))
19
20;Q(b)
21(define (branch-weight branch)
22    (if (pair? (branch-structure branch));the branch's structure is a mobile
23        (total-weight (branch-structure branch))
24        (branch-structure branch)))
25
26(define (total-weight mobile)
27  (+ (branch-weight (left-branch mobile))
28     (branch-weight (right-branch mobile))))
29         
30(define mobile (make-mobile (make-branch 10 25)
31                                  (make-branch 5 20)))
32
33
34> (total-weight mobile)
3545
36;Q(c)
37(define (torque branch)
38  (* (branch-length branch)
39     (branch-weight branch)))
40
41(define (balance-branch? branch)
42  (if (pair? (branch-structure branch))
43      (balance? (branch-structure branch))
44      #t))
45  
46(define (balance? mobile)
47  (and (= (torque (left-branch mobile))
48          (torque (right-branch mobile)))
49       (balance-branch? (left-branch mobile))
50       (balance-branch? (right-branch mobile))))
51     
52  
53(define balance-mobile (make-mobile (make-branch 10 10)
54                                          (make-branch 10 10)))
55
56(define unbalance-mobile (make-mobile (make-branch 0 0)
57                                            (make-branch 10 10)))
58
59(define mobile-with-sub-mobile (make-mobile (make-branch 10 balance-mobile)
60                                                  (make-branch 10 balance-mobile)))
61
62> (balance? balance-mobile)
63#t
64> (balance? unbalance-mobile)
65#f
66> (balance? mobile-with-sub-mobile)
67#t
68
69
70;Q(d)
71;only nedd to change the selector and constructor

 1(define (square-tree tree)
 2  (cond ((null? tree) nil)
 3        ((not (pair? tree)) (square tree))
 4        (else (cons (square-tree (car tree))
 5                    (square-tree (cdr tree))))))
 6
 7(define tree (list 1
 8                   (list 2 (list 3 4) 5)
 9                   (list 6 7)))
10
11>(square-tree tree)
12(1 (4 (9 16) 25) (36 49))
13
14(define (square-tree-map tree)
15  (map (lambda (sub-tree)
16         (if (pair? sub-tree)
17             (square-tree-map sub-tree)
18             (square sub-tree)))
19       tree))
20
21>(square-tree-map tree)
22(1 (4 (9 16) 25) (36 49))

 1;Def 1
 2(define (tree-map f tree)
 3    (cond ((null? tree) nil)
 4        ((not (pair? tree)) (f tree))
 5        (else (cons (tree-map f (car tree))
 6                    (tree-map f (cdr tree))))))
 7;Def 2
 8(define (tree-map f tree)
 9    (map (lambda (sub-tree)
10             (if (pair? sub-tree)
11                 (tree-map f sub-tree) 
12                 (f sub-tree)))
13         tree))

1(define (subsets s)
2  (if (null? s)
3      (list nil)
4      (let ((rest (subsets (cdr s))))
5        (append rest (map (lambda (x) (cons (car s) x)) rest)))))

1(define (map p sequence)
2  (accumulate (lambda (x y) (cons (p x) y)) nil sequence))
3
4(define (append seq1 seq2)
5  (accumulate cons seq2 seq1))
6
7(define (length sequence)
8  (accumulate (lambda (x y) (+ 1 y)) 0 sequence))

1(define (horner-eval x coefficient-sequence)
2  (accumulate (lambda (this-coeff higher-terms)
3                (+ (* higher-terms x) this-coeff))
4              0
5              coefficient-sequence))

1(define (count-leaves t)
2  (accumulate +
3              0
4              (map (lambda (sub-tree)
5                     (if (pair? sub-tree)
6                         (count-leaves sub-tree)
7                         1)) t)))

1(define (accumulate-n op init seqs)
2  (if (null? (car seqs))
3      nil
4      (cons (accumulate op
5                        init
6                        (map (lambda (seq) (car seq)) seqs))
7            (accumulate-n op
8                          init
9                          (map (lambda (seq) (cdr seq)) seqs)))))

 1(define (dot-product v w)
 2  (accumulate + 0 (map * v w)))
 3
 4(define (matrix-*-vector m v)
 5  (map (lambda (row) (dot-product v row)) m))
 6
 7(define (transpose mat)
 8  (accumulate-n cons nil mat))
 9
10(define (matrix-*-matrix m n)
11  (let ((cols (transpose n)))
12    (map (lambda (w) (matrix-*-vector cols w)) m)))
13
14(define m1 (list (list 1 2 3 4)
15                (list 4 5 6 6)
16                (list 6 7 8 9)))
17
18(define m2 (list (list 1 2 3)
19                (list 4 5 6)
20                (list 7 8 9)))
21
22(define v (list 1 2 3 4))
23
24(matrix-*-vector m1 v)
25;Value: (30 56 80)
26
27(transpose m1)
28;Value: ((1 4 6) (2 5 7) (3 6 8) (4 6 9))
29
30(matrix-*-matrix m2 m2)
31;Value: ((30 36 42) (66 81 96) (102 126 150))

1(define (reverse sequence)
2  (fold-right (lambda (x y) (append y (list x))) nil sequence))

1(define (reverse sequence)
2  (fold-left (lambda (x y) (cons y x)) nil sequence))

1(define (unique-pairs n)
2  (flatmap (lambda (i) (map (lambda (j) (list i j))
3                            (enumerate-interval 1 (- i 1))))
4           (enumerate-interval 1 n)))
5
6
7(define (prime-sum-pairs n)
8    (map make-pair-sum
9         (filter prime-sum? (unique-pairs n))))

 1;Def 1 to generate triples
 2(define (triples n)
 3  (flatmap (lambda (i) (flatmap (lambda (j) (map (lambda (k) (list i j k))
 4                                            (enumerate-interval 1 (- j 1))))
 5                            (enumerate-interval 1 (- i 1))))
 6             (enumerate-interval 1 n)))
 7;Def 2 to generate triples, using unique-pairs in Exercise 2.40
 8(define (triples n)
 9  (flatmap (lambda (i) (map (lambda (j) (cons i j))
10                            (unique-pairs (- i 1))))
11           (enumerate-interval 1 n)))
12
13
14(define (n-triples-sum-s n s)
15  (filter (lambda (triple)(= s (+ (car triple)
16                                  (cadr triple)
17                                  (cadr (cdr triple)))))
18          (triples n)))

 1(define (queens board-size)
 2  (define (queen-cols k)
 3    (if (= 0 k)
 4        (list empty-board)
 5        (filter
 6         (lambda (positions) (safe? k positions))
 7         (flatmap
 8          (lambda (rest-of-queens)
 9            (map (lambda (new-row)
10                   (adjoin-position
11                    new-row k rest-of-queens))
12                 (enumerate-interval 1 board-size)))
13          (queen-cols (- k 1))))))
14  (queen-cols board-size))
15
16(define empty-board nil)
17
18(define (adjoin-position new-row k rest-of-queens)
19  (cons new-row rest-of-queens))
20
21(define (abs x)
22  (if (< 0 x)
23      (- x)
24      x))
25
26(define (safe? k positions)
27  (let ((row-in-kth-col (car positions)))
28    (define (iter col positions)
29      (if (= col 0)
30        #t
31        (and (iter (- col 1) (cdr positions))
32             (not (= (abs (- col k)) (abs (- (car positions) row-in-kth-col))));不在对角线
33             (not (= (car positions) row-in-kth-col));不在同一行
34             )
35        ))
36    (iter (- k 1) (cdr positions))));check k-1 cols

1(define (up-split painter n)
2  (if (= n 0)
3      painter
4      (let ((smaller (up-split painter (- n 1))))
5        (below painter (beside smaller smaller)))))

1(define (split big-combiner small-combiner)
2  (define (helper painter n)
3    (if (= n 0)
4      painter
5      (let ((smaller (helper painter (- n 1))))
6        (big-combiner painter (small-combiner smaller smaller)))))
7  helper)

 1(define (make-vect xcor ycor)
 2  (cons xcor ycor))
 3
 4(define (xcor-vect vect)
 5  (car vect))
 6
 7(define (ycor-vect vect)
 8  (cdr vect))
 9
10(define (add-vect vect1 vect2)
11  (make-vect (+ (xcor-vect vect1) (xcor-vect vect2))
12             (+ (ycor-vect vect1) (ycor-vect vect2))))
13
14(define (sub-vect vect1 vect2)
15    (make-vect (- (xcor-vect vect1) (xcor-vect vect2))
16               (- (ycor-vect vect1) (ycor-vect vect2))))
17
18(define (scale-vect s vect)
19  (make-vect (* s (xcor-vect vect))
20             (* s (ycor-vect vect))))

 1(define (make-frame origin edge1 edge2)
 2  (list origin edge1 edge2))
 3
 4(define (origin-frame frame)
 5  (car frame))
 6
 7(define (edge1-frame frame)
 8  (cadr frame))
 9
10(define (edge2-frame frame)
11  (caddr frame))

1(define (make-segement start end)
2  (cons start end))
3
4(define (start-segement segement)
5  (car segement))
6
7(define (end-segement segement)
8  (cdr segement))

 1(define left-bottom (make-vect 0 0))
 2(define left-top (make-vect 0 1))
 3(define right-bottom (make-vect 1 0))
 4(define right-top (make-vect 1 1))
 5
 6(define mid-bottom (make-vect 0 0))
 7(define mid-top (make-vect 0 1))
 8(define mid-left (make-vect 1 0))
 9(define mid-right (make-vect 1 1))
10
11;Q(a)
12
13(paint (segments->painter (list (make-segment left-bottom left-top)
14                                 (make-segment left-top right-top)
15                                 (make-segment right-top right-bottom)
16                                 (make-segment right-bottom left-bottom))))
17
18(newline)
19
20;Q(b)
21(paint (segments->painter (list (make-segment left-bottom right-top)
22                         (make-segment left-top right-bottom))))
23
24(newline)
25
26;Q(c)
27(paint (segments->painter (list (make-segment mid-left mid-top)
28                         (make-segment mid-top mid-right)
29                         (make-segment mid-right mid-bottom)
30                         (make-segment mid-bottom mid-left))))
31
32
33;Q(d)
34;把wave的各个条线表示出来，太复杂了，不画了
35;可以参考 https://sicp.readthedocs.io/en/latest/chp2/49.html

 1(define (flip-horiz painter)
 2  (transform-painter painter
 3                     (make-vect 1.0 0)
 4                     (make-vect 0 0)
 5                     (make-vect 1 1)))
 6
 7
 8(define (rotate180 painter)
 9  (transform-painter painter
10                     (make-vect 1 1)
11                     (make-vect 0 1)
12                     (make-vect 1 0)))
13
14(define (rotate270 painter)
15  (transform-painter painter
16                     (make-vect 0 1)
17                     (make-vect 0 0)
18                     (make-vect 1 1)))

 1;Def 1
 2(define (below painter1 painter2)
 3  (let ((split-point (make-vect 0 0.5)))
 4    (let ((paint-top
 5           (transform-painter
 6            painter1
 7            (make-vect 0 0)
 8            (make-vect 1 0)
 9            split-point))
10          (paint-bottom
11           (transform-painter
12            painter2
13            split-point
14            (make-vect 1 0.5)
15            (make-vect 0 1))))
16      (lambda (frame)
17        (paint-top frame)
18        (paint-bottom frame)))))
19;Def 2
20(define (below painter1 painter2)
21    (lambda (frame)
22        ((flip-horiz
23            (rotate90
24                (beside
25                    (rotate270
26                        (flip-horiz painter1))
27                    (rotate270
28                        (flip-horiz painter2)))))
29         frame)))

 1;Q(b)
 2(define (corner-split painter n)
 3    (if (= n 0)
 4        painter
 5        (let ((up (up-split painter (- n 1)))
 6              (right (right-split painter (- n 1)))
 7              (corner (corner-split painter (- n 1))))
 8            (beside (below painter up)
 9                    (below right corner)))))
10;Q(c)
11(define (square-limit painter n)
12    (let ((combine4 (square-of-four identity flip-horiz)
13                                    flip-vect rotate180))
14        (combine4 (corner-split painter n))))

 1> (list 'a 'b 'c)
 2(a b c)
 3> (list (list 'geroge))
 4((geroge))
 5> (cdr '((x1 x2) (y1 y2)))
 6((y1 y2))
 7> (cadr '((x1 x2) (y1 y2)))
 8(y1 y2)
 9> (pair? (car '(a short list)))
10#f
11> (memq 'red '((red shoes) (blue socks)))
12#f
13> (memq 'red '(red shoes blue socks))
14(red shoes blue socks)

 1(define (equal? x y)
 2    (cond ((and (symbol? x) (symbol? y))
 3            (symbol-equal? x y))
 4          ((and (list? x) (list? y))
 5            (list-equal? x y))
 6          (else #f)))
 7
 8(define (symbol-equal? x y)
 9    (eq? x y))
10
11(define (list-equal? x y)
12    (cond ((and (null? x) (null? y))
13            #t)
14          ((or (null? x) (null? y))
15            #f)
16          ((equal? (car x) (car y))
17            (equal? (cdr x) (cdr y)))
18          (else #f)))

1(car ''abracadabra)

1(car '(quote abracadabra))

 1(define (exponentiation? exp)
 2  (and (pair? exp)
 3       (eq? (car exp) '**)))
 4
 5
 6(define (base exp)
 7  (cadr exp))
 8
 9(define (exponent exp)
10  (caddr exp))
11
12(define (make-exponentiation base exponent)
13  (cond ((=number? exponent 0) 1)
14        ((=number? exponent 1) base)
15        (else (list '** base exponent))))
16
17
18(define (deriv exp var)
19  (cond ((number? exp) 0)
20        ((variable? exp) (if (same-variable? exp var) 1 0))
21        ((sum? exp) (make-sum (deriv (addend exp) var)
22                              (deriv (augend exp) var)))
23        ((product? exp) (make-sum
24                         (make-product (multiplier exp)
25                                       (deriv (multiplicand exp) var))
26                         (make-product (deriv (multiplier exp) var)
27                                       (multiplicand exp))))
28        ((exponentiation? exp) (make-product
29                                (make-product
30                                (exponent exp)
31                                 (make-exponentiation (base exp) (make-sum (exponent exp) -1)))
32                                 (deriv (base exp) var)))))

  1#lang sicp
  2(define (deriv exp var)
  3  (cond ((number? exp) 0)
  4        ((variable? exp) (if (same-variable? exp var) 1 0))
  5        ((sum? exp) (make-sum (deriv (addend exp) var)
  6                              (deriv (augend exp) var)))
  7        ((product? exp) (make-sum
  8                         (make-product (multiplier exp)
  9                                       (deriv (multiplicand exp) var))
 10                         (make-product (deriv (multiplier exp) var)
 11                                       (multiplicand exp))))
 12        ((exponentiation? exp) (make-product
 13                                (make-product
 14                                (exponent exp)
 15                                 (make-exponentiation (base exp) (make-sum (exponent exp) -1)))
 16                                 (deriv (base exp) var)))))
 17
 18
 19(define (variable? x)
 20  (symbol? x))
 21
 22(define (same-variable? v1 v2)
 23  (and (variable? v1)
 24       (variable? v2)
 25       (eq? v1 v2)))
 26
 27
 28(define (exponentiation? exp)
 29  (and (pair? exp)
 30       (eq? (car exp) '**)))
 31
 32
 33(define (base exp)
 34  (cadr exp))
 35
 36(define (exponent exp)
 37  (caddr exp))
 38
 39(define (make-exponentiation base exponent)
 40  (cond ((=number? exponent 0) 1)
 41        ((=number? exponent 1) base)
 42        (else (list '** base exponent))))
 43
 44(define (sum? x) (and (pair? x) (eq? (car x) '+)))
 45
 46(define (addend s) (cadr s))
 47
 48(define (augend s)
 49    (let ((tail-operand (cddr s)))
 50        (if (single-operand? tail-operand)
 51            (car tail-operand)
 52            (apply make-sum tail-operand))))
 53
 54
 55(define (make-sum a1 . a2)
 56    (if (single-operand? a2)
 57        (let ((a2 (car a2)))
 58            (cond ((=number? a1 0)
 59                    a2)
 60                  ((=number? a2 0)
 61                    a1)
 62                  ((and (number? a1) (number? a2))
 63                    (+ a1 a2))
 64                  (else
 65                    (list '+ a1 a2))))
 66        (cons '+ (cons a1 a2))))
 67
 68
 69(define (single-operand? x) (= 1 (length x)))
 70
 71(define (=number? exp num)
 72  (and (number? exp) (= exp num)))
 73
 74(define (make-product m1 . m2)
 75    (if (single-operand? m2)
 76        (let ((m2 (car m2)))
 77            (cond ((or (=number? m1 0) (=number? m2 0))
 78                    0)
 79                  ((=number? m1 1)
 80                    m2)
 81                  ((=number? m2 1)
 82                    m1)
 83                  ((and (number? m1) (number? m2))
 84                    (* m1 m2))
 85                  (else
 86                    (list '* m1 m2))))
 87        (cons '* (cons m1 m2))))
 88
 89(define (product? x)
 90    (and (pair? x)
 91         (eq? (car x) '*)))
 92
 93(define (multiplier p)
 94    (cadr p))
 95
 96(define (multiplicand p)
 97    (let ((tail-operand (cddr p)))
 98        (if (single-operand? tail-operand)
 99            (car tail-operand)
100            (apply make-product tail-operand))))
101
102
103(deriv '(* x y (+ x 3)) 'x)

 1(define (sum? x)
 2  (and (pair? x) (eq? (cadr x) '+)))
 3
 4(define (addend s) (car s))
 5
 6(define (augend s) (caddr s))
 7
 8(define (make-sum a1 a2)
 9  (cond ((=number? a1 0) a2)
10        ((=number? a2 0) a1)
11        ((and (number? a1) (number? a2))
12         (+ a1 a2))
13        (else
14         (list a1 '+ a2))))
15
16(define (make-product m1 m2)
17  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
18        ((=number? m1 1) m2)
19        ((=number? m2 1) m1)
20        ((and (number? m1) (number? m2)) (* m1 m2))
21        (else (list m1 '* m2))))
22
23(define (product? x)
24    (and (pair? x)
25         (eq? (cadr x) '*)))
26
27(define (multiplier p) (car p))
28
29(define (multiplicand p) (caddr p))

1(define (union-set set1 set2)
2  (cond ((null? set1) set2)
3        ((null? set2) set1)
4        ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
5        (else (cons (car set1) (union-set (cdr set1) set2)))))

 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)
 7  (cons x set))
 8
 9(define (union-set set1 set2)
10  (append set1 set2))
11
12(define (intersection-set set1 set2)
13  (cond ((or (null? set1) (null? set2)) '())
14        ((element-of-set? (car set1) set2) (cons (car set1) (intersection-set (cdr set1) set2)))
15        (else (intersection-set (cdr set1) set2))))

1(define (adjoin-set x set)
2  (cond ((null? set) (list x))
3        ((= x (car set)) set)
4        ((< x (car set)) (cons x set))
5        ((> x (car set)) (cons (car set) (adjoin-set x (cdr set))))))

 1(define (union-set set1 set2)
 2  (cond ((null? set1) set2)
 3        ((null? set2) set1)
 4        ((let ((x1 (car set1))
 5               (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                 ((< x2 x1)
11                  (cons x2 (union-set set1 (cdr set2)))))))))

1(define (look-up given-key tree)
2  (cond
3    ((null? tree) #f)
4    ((= given-key (car tree)) #t)
5    ((> given-key (car tree))
6      (look-up given-key (right-branch tree)))
7    (else
8      (look-up given-key (left-branch tree)))))

 1(define sample-tree (make-code-tree (make-leaf 'A 4)
 2                  (make-code-tree
 3                   (make-leaf 'B 2)
 4                   (make-code-tree
 5                    (make-leaf 'D 1)
 6                    (make-leaf 'C 1)))))
 7
 8
 9(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
10
11(decode sample-message sample-tree)
12;Value: (A D A B B C A)

 1(define (encode message tree)
 2  (if (null? message)
 3      '()
 4      (append (encode-symbol (car message) tree)
 5              (encode (cdr message) tree))))
 6
 7
 8(define (exist? symbol symbols)
 9      (if (null? symbols)
10          #f
11          (or (eq? symbol (car symbols))
12              (exist? symbol (cdr symbols)))))
13
14
15(define (encode-symbol symbol tree)
16  (cond ((null? tree) (error "bad symbol :ENCODE-SYMBOL" symbol))
17        ((leaf? tree) nil)
18        (else (cond ((exist? symbol (symbols (left-branch tree)))
19                     (cons 0 (encode-symbol symbol (left-branch tree))))
20                    ((exist? symbol (symbols (right-branch tree)))
21                     (cons 1 (encode-symbol symbol (right-branch tree))))
22                    (else (error "bad symbol :ENCODE-SYMBOL" symbol))))))
23        
24              
25(encode '(A D A B B C A) sample-tree)
26;Value: (0 1 1 0 0 1 0 1 0 1 1 1 0)

 1(define (generate-huffman-tree pairs)
 2  (successive-merge (make-leaf-set pairs)))
 3
 4(define (successive-merge set)
 5  (if (= 1 (length set))
 6      (car set)
 7      (successive-merge (adjoin-set (make-code-tree (car set)
 8                                                    (cadr set))
 9                                    (cddr set)))))
10
11(define test-tree (generate-huffman-tree (list (cons 'A 4)
12                                               (cons 'B 2)
13                                               (cons 'C 1)
14                                               (cons 'D 1))))
15
16(decode (encode '(A D A B B C A) test-tree) test-tree)
17;Value: (A D A B B C A)