[project @ 1996-07-25 21:02:03 by partain]
[nofib.git] / real / compress / Encode.hs
1 {-
2 - Encode Mk 2, using a prefix table for the codes
3 -
4 - Paul Sanders, Systems Research, British Telecom Laboratories 1992
5 -
6 -}
7
8 module Encode (encode) where
9
10 import Defaults
11 import PTTrees
12
13 -- for convenience we make the code table type explicit
14
15 type CodeTable = PrefixTree Char Int
16
17 {- encode sets up the arguments for the real function.
18 -}
19
20 encode :: String -> [Int]
21 encode input
22 = encode' input first_code initial_table
23
24 {- encode' loops through the input string assembling the codes produced
25 - by code_string.
26 - The first character is treated specially in that it is not added to the
27 - table; its code is simply its ascii value
28 -}
29
30 -- implicit selections with IMPLICIT DW
31
32 --#define IMPLICIT
33
34 -- explicit selections with EXPLICIT DW
35
36 #define EXPLICIT
37
38 --encode' :: String -> Int -> CodeTable -> [Int]
39 encode' [] _ _
40 = []
41 encode' input v t
42 = case (code_string input 0 v t) of { (input', n, t') ->
43 n : encode' input' (v + 1) t'
44 }
45 {- ???
46 encode' input v t
47 = n : encode' input' (v + 1) t'
48 where (input', n, t') = code_string input 0 v t
49 -}
50
51 {- code_string parses enough of the input string to produce one code and
52 - returns the remaining input, the code and a new code table.
53 -
54 - The first character is taken and its place found in the code table. The
55 - extension code table found for this character is then used as the lookup
56 - table for the next character.
57 -
58 - If a character is not found in the current table then output the code
59 - of the character associated with the current table and add the current
60 - character to the current table and assign it the next new code value.
61 -}
62
63
64 #ifdef IMPLICIT
65 code_string :: String -> Int -> Int -> CodeTable -> (String, Int, CodeTable)
66 code_string [] old_code _ _
67 = ([], old_code, PTNil)
68 code_string i@(c:cs) old_code next_code PTNil -- found max string, add suffix
69 = if next_code >= max_entries
70 then (i, old_code, PTNil)
71 else (i, old_code, PT (PTE c next_code PTNil) PTNil PTNil)
72 code_string i@(c:cs) old_code next_code (PT (PTE k v t) l r)
73 | c < k = (csl, nl, PT (PTE k v t) l' r)
74 | c > k = (csr, nr, PT (PTE k v t) l r')
75 | c == k = (cs', n, PT (PTE k v t') l r)
76 where (csl, nl, l') = code_string i old_code next_code l
77 (csr, nr, r') = code_string i old_code next_code r
78 (cs', n, t') = code_string cs v next_code t
79 #endif
80
81 #ifdef EXPLICIT
82 {- ???
83 code_string :: String -> Int -> Int -> CodeTable -> (String, Int, CodeTable)
84 code_string [] old_code _ _
85 = ([], old_code, PTNil)
86 code_string ca@(c:_) old_code next_code PTNil = -- found max string, add suffix
87 if next_code >= max_entries then
88 (ca, old_code, PTNil)
89 else
90 (ca, old_code, PT (PTE c next_code PTNil) PTNil PTNil)
91 -}
92 {- partain:ORIG:
93 code_string ca@(c:_) old_code next_code (PT p@(PTE k _ _) l r)
94 | c < k = f1 result1 p r
95 where result1 = code_string ca old_code next_code l
96
97 code_string ca@(c:_) old_code next_code (PT p@(PTE k _ _) l r)
98 | c > k = f2 result2 p l
99 where result2 = code_string ca old_code next_code r
100
101 code_string (_:cs) old_code next_code (PT (PTE k v t) l r)
102 | otherwise = f3 result3 k v l r
103 where result3 = code_string cs v next_code t
104
105 f1 (csl,nl,l') p r = (csl, nl, PT p l' r)
106 f2 (csr,nr,r') p l = (csr, nr, PT p l r')
107 f3 (cs',n,t') k v l r = (cs', n, PT (PTE k v t') l r)
108 -}
109
110 {- ???
111 code_string ca@(c:cs) old_code next_code (PT p@(PTE k v t) l r)
112 | c < k = f1 result1 p r
113 | c > k = f2 result2 p l
114 | otherwise = f3 result3 k v l r
115 where
116 result1 = code_string ca old_code next_code l
117 result2 = code_string ca old_code next_code r
118 result3 = code_string cs v next_code t
119
120 f1 (csl,nl,l') p r = (csl, nl, PT p l' r)
121 f2 (csr,nr,r') p l = (csr, nr, PT p l r')
122 f3 (cs',n,t') k v l r = (cs', n, PT (PTE k v t') l r)
123 -}
124
125 #define CBOX(c) (c)
126 #define _PTE_(a,b,c) (PTE (a) (b) (c))
127 #define _TRIP_(a,b,c) (a,b,c)
128 #define ILIT(i) (i)
129 #define _GE_ >=
130
131 code_string input@(CBOX(c) : input2) old_code next_code (PT p@(PTE k v t) l r)
132 | CBOX(c) < CBOX(k) = {-_scc_ "cs1"-} (f1 r1 p r)
133 | CBOX(c) > CBOX(k) = {-_scc_ "cs2"-} (f2 r2 p l)
134 | otherwise {- CBOX(c) == CBOX(k) -} = {-_scc_ "cs3"-} (f3 r3 k v l r)
135 where {
136 r1 = code_string input old_code next_code l;
137 r2 = code_string input old_code next_code r;
138 r3 = code_string input2 v next_code t;
139
140 f1 _TRIP_(input_l,nl,l2) p r = _TRIP_(input_l,nl,PT p l2 r);
141 f2 _TRIP_(input_r,nr,r2) p l = _TRIP_(input_r,nr,PT p l r2);
142 f3 _TRIP_(input2,n,t2) k v l r = _TRIP_(input2, n, PT _PTE_(k, v, t2) l r);
143 }
144
145 code_string input@(CBOX(c) : input_file2) old_code next_code PTNil
146 = if (next_code _GE_ ILIT(4096))
147 then {- _scc_ "cs4"-} _TRIP_(input, old_code, PTNil)
148 else {- _scc_ "cs5"-} _TRIP_(input, old_code, PT _PTE_(c, next_code, PTNil) PTNil PTNil)
149
150 code_string [] old_code next_code code_table = {-_scc_ "cs6"-} _TRIP_([], old_code, PTNil)
151
152 #endif
153
154 {- We want the inital table to be balanced, but this is expensive to compute
155 - as a rebalance is needed evert two inserts (yuk!). So we do the ordinary
156 - infix-order binary tree insert but give the keys in such an order as to
157 - give a balanced tree.
158 -
159 - (I would have defined the tree by hand but the constant was too big
160 - for hc-0.41)
161 -}
162
163 initial_table :: CodeTable
164 initial_table
165 = foldr tab_insert PTNil balanced_list
166
167 tab_insert n = insert (toEnum n) n
168
169 balanced_list
170 = [128,64,32,16,8,4,2,1,0,3,6,5,7,12,10,9,11,14,13,15,24,20,18,17,19,22,
171 21,23,28,26,25,27,30,29,31,48,40,36,34,33,35,38,37,39,44,42,41,43,46,
172 45,47,56,52,50,49,51,54,53,55,60,58,57,59,62,61,63,96,80,72,68,66,65]
173 ++ bal_list2 ++ bal_list3 ++ bal_list4 ++ bal_list5
174
175 bal_list2
176 = [67,70,69,71,76,74,73,75,78,77,79,88,84,82,81,83,86,85,87,92,90,89,91,
177 94,93,95,112,104,100,98,97,99,102,101,103,108,106,105,107,110,109,111,
178 120,116,114,113,115,118,117,119,124,122,121,123,126,125,127,192,160]
179
180 bal_list3
181 = [144,136,132,130,129,131,134,133,135,140,138,137,139,142,141,143,152,
182 148,146,145,147,150,149,151,156,154,153,155,158,157,159,176,168,164,
183 162,161,163,166,165,167,172,170,169,171,174,173,175,184,180,178,177]
184
185 bal_list4
186 = [179,182,181,183,188,186,185,187,190,189,191,224,208,200,196,194,193,
187 195,198,197,199,204,202,201,203,206,205,207,216,212,210,209,211,214,
188 213,215,220,218,217,219,222,221,223,240,232,228,226,225,227,230,229,
189 231,236,234,233,235,238,237,239,248,244,242,241,243,246,245,247,252]
190 bal_list5
191 = [250,249,251,254,253,255]
192