]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ch2_3.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ch2_3.rkt
1 #lang racket
2
3 (define (memq item x)
4   (cond ((null? x) #f)
5         ((eq? item (car x)) x)
6         (else (memq item (cdr x)))))
7
8 ;; leaf nodes
9 (define (make-leaf leaf weight)
10   (list 'leaf leaf weight))
11
12 (define (leaf? object)
13   (eq? (car object) 'leaf))
14
15 (define (symbol-leaf object)
16   (cadr object))
17
18 (define (weight-leaf object)
19   (caddr object))
20
21 ;;;; constructors and selectors
22
23 ;; tree node consists of a list which has left branch, right branch
24 ;; set of symbols in left and right and total weight
25 (define (make-code-tree left right)
26   (list left
27         right
28         (append (symbols left)
29                 (symbols right))
30         (+ (weight left)
31            (weight right))))
32
33 (define (left-branch tree) (car tree))
34
35 (define (right-branch tree) (cadr tree))
36
37 (define (symbols tree)
38   (if (leaf? tree)
39       (list (symbol-leaf tree))
40       (caddr tree)))
41
42 (define (weight tree)
43   (if (leaf? tree)
44       (weight-leaf tree)
45       (cadddr tree)))
46
47 ;; now decoding
48 (define (decode bits tree)
49   (define (decode-1 bits current-branch)
50     (if (null? bits)
51         '()
52         (let ([next-branch (choose-branch (car bits) current-branch)])
53           (if (leaf? next-branch)
54               (cons (symbol-leaf next-branch)
55                     (decode-1 (cdr bits) tree))
56               (decode-1 (cdr bits) next-branch)))))
57   (decode-1 bits tree))
58
59 (define (choose-branch bit tree)
60   (cond [(= bit 0) (left-branch tree)]
61         [(= bit 1) (right-branch tree)]
62         [else (error "Bad bit -- CHOOSE-BRANCH" bit)]))
63
64 (define (adjoin-set x set)
65   (cond [(null? set) (list x)]
66         [(< (weight x) (weight (car set))) (cons x set)]
67         [else (cons (car set)
68                     (adjoin-set x (cdr set)))]))
69
70 (define (make-leaf-set pairs)
71   (if (null? pairs)
72       '()
73       (let ([pair (car pairs)])
74         (adjoin-set (make-leaf (car pair)
75                                (cadr pair))
76                     (make-leaf-set (cdr pairs))))))
77
78 (provide make-code-tree 
79          make-leaf 
80          decode 
81          leaf? 
82          symbol-leaf 
83          left-branch 
84          right-branch 
85          symbols 
86          make-leaf-set 
87          adjoin-set)