blob: d6021b1fbdf9ce2df7ab2f2a28365f427dfca759 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
#lang racket
(require "../../shared/lists.rkt")
(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 (make-code-tree left right)
(list
left
right
(append (symbol-set left)
(symbol-set right))
(+ (weight left)
(weight right))))
(define (left-branch tree)
(car tree))
(define (right-branch tree)
(cadr tree))
(define (symbol-set tree)
(if (leaf? tree)
(list (symbol-leaf tree))
(caddr tree)))
(define (weight tree)
(if (leaf? tree)
(weight-leaf tree)
(cadddr tree)))
(define (decode bits tree)
(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 (choose-branch bit branch)
(cond ((= bit 0) (left-branch branch))
((= bit 1) (right-branch branch))
(else (error "bad bit -- CHOOSE-BRANCH" bit))))
(define (adjoin-set x mset)
(cond ((null? mset) (list x))
((< (weight x) (weight (car mset))
(cons x mset)))
(else (cons (car mset)
(adjoin-set x (cdr mset))))))
(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))))))
;; 67
(define sample-tree
(make-code-tree (make-leaf 'A 4)
(make-code-tree
(make-leaf 'B 2)
(make-code-tree
(make-leaf 'D 1)
(make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
(decode sample-message sample-tree)
;; '(A D A B B C A)
;; 68
(define (encode message tree)
(if (null? message)
'()
(append (encode-symbol (car message) tree)
(encode (cdr message) tree))))
(define (encode-symbol s tree)
(define (bits result subtree)
(cond ((and (leaf? subtree)
(equal? s (car (symbol-set subtree))))
result)
((leaf? subtree) '())
(else
(let ((left (bits
(cons 0 result)
(left-branch subtree))))
(if (null? left)
(bits (cons 1 result) (right-branch subtree))
left)))))
(reverse (bits '() tree)))
(encode (decode sample-message sample-tree) sample-tree)
|
