[project @ 1996-07-25 21:02:03 by partain]
[nofib.git] / real / compress / Lzw.hs
1 module Main (main){-export list added by partain-} where {
2
3 -- partain: with "ghc -cpp -DSLEAZY_UNBOXING", you get (guess what)?
4 -- without it, you get the code as originally written.
5 --
6 -- Things done here:
7 -- * The obvious unboxing (e.g., Int ==> Int#).
8 -- * use quot/rem, not div/mod
9 -- * inline PrefixElement type into PrefixTree.PT constructor
10 -- * cvt final clause of 3-way comparison to "otherwise"
11 -- * use shifts, not quot/rem (not necessary: C compiler converts
12 -- them just fine)
13 --
14 -- Obviously, more egregious hacking could be done:
15 -- * replace Tuple/List types that mention Ints with specialised
16 -- variants
17
18 #if defined(__GLASGOW_HASKELL__) && defined(SLEAZY_UNBOXING)
19 #define FAST_INT Int#
20 #define ILIT(x) (x#)
21 #define IBOX(x) (I# (x))
22 #define _ADD_ `plusInt#`
23 #define _SUB_ `minusInt#`
24 #define _MUL_ `timesInt#`
25 #define _DIV_ `divInt#`
26 #define _QUOT_ `quotInt#`
27 #define _REM_ `remInt#`
28 #define _NEG_ negateInt#
29 #define _EQ_ `eqInt#`
30 #define _LT_ `ltInt#`
31 #define _LE_ `leInt#`
32 #define _GE_ `geInt#`
33 #define _GT_ `gtInt#`
34 #define _CHR_ chr#
35
36 #define FAST_BOOL Int#
37 #define _TRUE_ 1#
38 #define _FALSE_ 0#
39 #define _IS_TRUE_(x) ((x) `eqInt#` 1#)
40
41 #define FAST_CHAR Char#
42 #define CBOX(x) (C# (x))
43
44 data FAST_TRIPLE = TRIP [Char] Int# PrefixTree;
45 #define _TRIP_(a,b,c) (TRIP (a) (b) (c))
46
47 #define PrefixElement FAST_CHAR FAST_INT PrefixTree
48 #define _PTE_(a,b,c) (a) (b) (c)
49
50 #else {- ! __GLASGOW_HASKELL__ -}
51
52 #define FAST_INT Int
53 #define ILIT(x) (x)
54 #define IBOX(x) (x)
55 #define _ADD_ +
56 #define _SUB_ -
57 #define _MUL_ *
58 #define _DIV_ `div`
59 #define _QUOT_ `quot`
60 #define _REM_ `rem`
61 #define _NEG_ -
62 #define _EQ_ ==
63 #define _LT_ <
64 #define _LE_ <=
65 #define _GE_ >=
66 #define _GT_ >
67 #define _CHR_ toEnum
68
69 #define FAST_BOOL Bool
70 #define _TRUE_ True
71 #define _FALSE_ False
72 #define _IS_TRUE_(x) (x)
73
74 #define FAST_CHAR Char
75 #define CBOX(x) (x)
76
77 type FAST_TRIPLE = ([Char], Int, PrefixTree);
78 #define _TRIP_(a,b,c) ((a), (b), (c))
79
80 data PrefixElement = PTE FAST_CHAR FAST_INT PrefixTree;
81 #define _PTE_(a,b,c) (PTE (a) (b) (c))
82
83 #endif {- ! __GLASGOW_HASKELL__ -}
84
85 -- end of partain
86
87 data PrefixTree = PTNil | PT PrefixElement PrefixTree PrefixTree;
88
89 --create_code_table :: PrefixTree; -- partain: sig
90
91 create_code_table = create_code_table2 ILIT(0) ILIT(256);
92
93 create_code_table2 :: FAST_INT -> FAST_INT -> PrefixTree;
94 create_code_table2 first_code ILIT(0) = PTNil;
95 create_code_table2 first_code ILIT(1)
96 = PT _PTE_((_CHR_ first_code), first_code, PTNil) PTNil PTNil;
97 create_code_table2 first_code n_codes
98 = PT _PTE_((_CHR_ m_code), m_code, PTNil) left right
99 where {
100 left = create_code_table2 first_code (m_code _SUB_ first_code);
101 right = create_code_table2 m_code2 ((first_code _ADD_ n_codes) _SUB_ m_code2);
102 m_code = (first_code _ADD_ (first_code _ADD_ n_codes _SUB_ ILIT(1))) _QUOT_ ILIT(2);
103 m_code2 = m_code _ADD_ ILIT(1);
104 };
105
106 lzw_code_file :: [Char] -> PrefixTree -> FAST_INT -> [Int];
107 lzw_code_file [] code_table next_code = [];
108 lzw_code_file input code_table next_code
109 = -- partain: case-ified lazy where
110 case (code_string input ILIT(0) next_code code_table) of {
111 _TRIP_(input2,n,code_table2) ->
112 IBOX(n) : lzw_code_file input2 code_table2 (next_code _ADD_ ILIT(1))
113 };
114
115 code_string :: [Char] -> FAST_INT -> FAST_INT -> PrefixTree -> FAST_TRIPLE;
116
117 #if defined(__GLASGOW_HASKELL__) && defined(SLEAZY_UNBOXING)
118 code_string input@(CBOX(c) : input2) old_code next_code (PT k v t {-p@(PTE k v t)-} l r)
119 | CBOX(c) < CBOX(k) = f1 r1 {-p-} k v t r
120 | CBOX(c) > CBOX(k) = f2 r2 {-p-} k v t l
121 | otherwise {- CBOX(c) == CBOX(k) -} = f3 r3 k v l r
122 #else
123 code_string input@(CBOX(c) : input2) old_code next_code (PT p@(PTE k v t) l r)
124 | CBOX(c) < CBOX(k) = f1 r1 p r
125 | CBOX(c) > CBOX(k) = f2 r2 p l
126 | otherwise {- CBOX(c) == CBOX(k) -} = f3 r3 k v l r
127 #endif
128 where {
129 r1 = code_string input old_code next_code l;
130 r2 = code_string input old_code next_code r;
131 r3 = code_string input2 v next_code t;
132
133 #if defined(__GLASGOW_HASKELL__) && defined(SLEAZY_UNBOXING)
134 f1 _TRIP_(input_l,nl,l2) k v t r = _TRIP_(input_l,nl,PT k v t l2 r);
135 f2 _TRIP_(input_r,nr,r2) k v t l = _TRIP_(input_r,nr,PT k v t l r2);
136 #else
137 f1 _TRIP_(input_l,nl,l2) p r = _TRIP_(input_l,nl,PT p l2 r);
138 f2 _TRIP_(input_r,nr,r2) p l = _TRIP_(input_r,nr,PT p l r2);
139 #endif
140 f3 _TRIP_(input2,n,t2) k v l r = _TRIP_(input2, n, PT _PTE_(k, v, t2) l r);
141 };
142
143 --code_string input@(c : input2) old_code next_code (PT p@(PTE k v t) l r)
144 -- | c < k = (input_l,nl,PT p l' r)
145 -- | c > k = (input_r,nr,PT p l r')
146 -- | c == k = (input',n,PT (PTE k v t') l r)
147 -- where {
148 -- (input_l,nl,l') = code_string input old_code next_code l;
149 -- (input_r,nr,r') = code_string input old_code next_code r;
150 -- (input',n,t') = code_string input2 v next_code t;
151 -- };
152
153 code_string input@(CBOX(c) : input_file2) old_code next_code PTNil
154 = if (next_code _GE_ ILIT(4096))
155 then _TRIP_(input, old_code, PTNil)
156 else _TRIP_(input, old_code, PT _PTE_(c, next_code, PTNil) PTNil PTNil);
157
158 code_string [] old_code next_code code_table = _TRIP_([], old_code, PTNil);
159
160 integer_list_to_char_list (IBOX(n) : l)
161 = CBOX(_CHR_ (n _QUOT_ ILIT(16))) : integer_list_to_char_list2 l n;
162 integer_list_to_char_list [] = [];
163
164 integer_list_to_char_list2 (IBOX(c) : l) n
165 = CBOX(_CHR_ ((n _MUL_ ILIT(16)) _ADD_ ((c _QUOT_ ILIT(256)) _REM_ ILIT(16))))
166 : CBOX(_CHR_ c)
167 : integer_list_to_char_list l;
168 integer_list_to_char_list2 [] n = CBOX(_CHR_ (n _MUL_ ILIT(16))) : [];
169
170 main :: IO ();
171 main = getContents >>= \ input_string -> main2 input_string;
172
173 main2 :: String -> IO ();
174 main2 input_string
175 = putStr output_list
176 where {
177 output_list = integer_list_to_char_list code_list;
178 code_list = lzw_code_file input_string create_code_table ILIT(256);
179 };
180
181 }