1 (load "common")
2 (defun make-leaf (symbol weight)
3   (list 'leaf sym weight))
4 (defun leaf? (obj)
5   (eq (car obj) 'leaf))
6 (defun symbol-leaf (x)
7   (cadr x))
8 (defun weight-leaf (x)
9   (caddr x))
10 (defun make-code-tree (left right)
11   (list left
12 	right
13 	(append (symbols left) (symbols right))
14 	(+ (weight left) (weight right))))
15 (defun left-branch (tree)
16   (car tree))
17 (defun right-branch (tree)
18   (cadr tree))
19 (defun symbols (tree)
20   (if (leaf? tree)
21       (list (symbol-leaf tree))
22       (caddr tree)))
23 (defun weight (tree)
24   (if (leaf? tree)
25       (weight-leaf tree)
26       (cadddr tree)))
27 (defun adjoin-set (x set)
28   "Add a new element _x_ into a set of elements, sorted by weight"
29   (cond ((null set) (list x))
30 	((< (weight x) (weight (car set)))
31 	 (cons x set))
32 	(t (cons (car set)
33 		 (adjoin-set x (cdr set))))))
34 (defun make-leaf-set (pairs)
35   (if (null pairs)
36       '()
37       (let ((pair (car pairs)))
38 	(adjoin-set (make-leaf (car pair)
39 			       (cadr pair))
40 		    (make-leaf-set (cdr pairs))))))
41 (defun decode (bits tree)
42   (labels ((decode-1 (bits branch)
43 	     (if (null bits)
44 		 '()
45 		 (let ((next-branch (choose-branch (car bits) branch)))
46 		   (if (leaf? next-branch)
47 		       (cons (symbol-leaf next-branch)
48 			     (decode-1 (cdr bits) tree))
49 		       (decode-1 (cdr bits) next-branch))))))
50     (decode-1 bits tree)))
51 (defun choose-branch (bit branch)
52   (cond ((= bit 0) (left-branch branch))
53 	((= bit 1) (right-branch branch))
54 	(t (error "bad bit -- CHOOSE-BRANCH ~A" bit))))
55 
56 (defvar sample-tree
57   (make-code-tree
58    (make-leaf 'A 4)
59    (make-code-tree
60     (make-leaf 'B 2)
61     (make-code-tree
62      (make-leaf 'D 1)
63      (make-leaf 'C 2)))))
64 (defvar sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
65 
66 (defun encode-symbol (sym tree)
67   (labels ((tree-walk (sym node encoding)
68 	     (if (leaf? node)
69 		 encoding
70 		 (cond
71 		   ((element-of-set? sym (symbols (left-branch node)))
72 		    (tree-walk sym (left-branch node) (cons 0 encoding)))
73 		   ((element-of-set? sym (symbols (right-branch node)))
74 		    (tree-walk sym (right-branch node) (cons 1 encoding)))
75 		   (t (error "Symbol not in tree -- ~A" sym))))))
76     (reverse (tree-walk sym tree '()))))