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