Remove deprecated _scc_ (#8170)
[nofib.git] / real / compress / Lzw2.hs
1 -- Lzw2.hs looks like an earlier version of Lzw.hs
2
3 module Main (main){-export list added by partain-} where {
4
5 -- partain: with "ghc -cpp -DSLEAZY_UNBOXING", you get (guess what)?
6 -- without it, you get the code as originally written.
7 --
8 -- Things done here:
9 -- * The obvious unboxing (e.g., Int ==> Int#).
10 -- * use quot/rem, not div/mod
11 -- * inline PrefixElement type into PrefixTree.PT constructor
12 -- * cvt final clause of 3-way comparison to "otherwise"
13 -- * use shifts, not quot/rem (not necessary: C compiler converts
14 -- them just fine)
15 --
16 -- Obviously, more egregious hacking could be done:
17 -- * replace Tuple/List types that mention Ints with specialised
18 -- variants
19
20 #define FAST_INT Int#
21 #define ILIT(x) (x#)
22 #define IBOX(x) (I# (x))
23 #define _ADD_ `plusInt#`
24 #define _SUB_ `minusInt#`
25 #define _MUL_ `timesInt#`
26 #define _DIV_ `divInt#`
27 #define _QUOT_ `quotInt#`
28 #define _REM_ `remInt#`
29 #define _NEG_ negateInt#
30 #define _EQ_ `eqInt#`
31 #define _LT_ `ltInt#`
32 #define _LE_ `leInt#`
33 #define _GE_ `geInt#`
34 #define _GT_ `gtInt#`
35 #define _CHR_ chr#
36
37 #define FAST_BOOL Int#
38 #define _TRUE_ 1#
39 #define _FALSE_ 0#
40 #define _IS_TRUE_(x) ((x) `eqInt#` 1#)
41
42 #define FAST_CHAR Char#
43 #define CBOX(x) (C# (x))
44
45 data FAST_TRIPLE = TRIP [Char] Int# PrefixTree;
46 #define _TRIP_(a,b,c) (TRIP (a) (b) (c))
47
48 #define PrefixElement FAST_CHAR FAST_INT PrefixTree
49 #define _PTE_(a,b,c) (a) (b) (c)
50
51 -- end of partain
52
53 data PrefixTree = PTNil | PT PrefixElement PrefixTree PrefixTree;
54
55 create_code_table = create_code_table2 ILIT(0) ILIT(256);
56
57 create_code_table2 :: FAST_INT -> FAST_INT -> PrefixTree;
58 create_code_table2 first_code ILIT(0) = PTNil;
59 create_code_table2 first_code ILIT(1)
60 = PT _PTE_((_CHR_ first_code), first_code, PTNil) PTNil PTNil;
61 create_code_table2 first_code n_codes
62 = PT _PTE_((_CHR_ m_code), m_code, PTNil) left right
63 where {
64 left = create_code_table2 first_code (m_code _SUB_ first_code);
65 right = create_code_table2 m_code2 ((first_code _ADD_ n_codes) _SUB_ m_code2);
66 m_code = (first_code _ADD_ (first_code _ADD_ n_codes _SUB_ ILIT(1))) _QUOT_ ILIT(2);
67 m_code2 = m_code _ADD_ ILIT(1);
68 };
69
70 lzw_code_file :: [Char] -> PrefixTree -> FAST_INT -> [Int];
71 lzw_code_file [] code_table next_code = [];
72 lzw_code_file input code_table next_code
73 = -- partain: case-ified lazy where
74 case (code_string ILIT(0) next_code input code_table) of {
75 _TRIP_(input2,n,code_table2) ->
76 IBOX(n) : lzw_code_file input2 code_table2 (next_code _ADD_ ILIT(1))
77 };
78
79 code_string :: FAST_INT -> FAST_INT -> [Char] -> PrefixTree -> FAST_TRIPLE;
80
81 code_string old_code next_code input@(CBOX(c) : input2) (PT k v t {-p@(PTE k v t)-} l r)
82 | CBOX(c) < CBOX(k) = {-# SCC "cs1" #-} (f1 r1 {-p-} k v t r)
83 | CBOX(c) > CBOX(k) = {-# SCC "cs2" #-} (f2 r2 {-p-} k v t l)
84 | otherwise {- CBOX(c) == CBOX(k) -} = {-# SCC "cs3" #-} (f3 r3 k v l r)
85 where {
86 r1 = code_string old_code next_code input l;
87 r2 = code_string old_code next_code input r;
88 r3 = code_string v next_code input2 t;
89
90 f1 _TRIP_(input_l,nl,l2) k v t r = _TRIP_(input_l,nl,PT k v t l2 r);
91 f2 _TRIP_(input_r,nr,r2) k v t l = _TRIP_(input_r,nr,PT k v t l r2);
92 f3 _TRIP_(input2,n,t2) k v l r = _TRIP_(input2, n, PT _PTE_(k, v, t2) l r);
93 };
94
95 code_string old_code next_code input@(CBOX(c) : input_file2) PTNil
96 = if (next_code _GE_ ILIT(4096))
97 then {-# SCC "cs4" #-} _TRIP_(input, old_code, PTNil)
98 else {-# SCC "cs5" #-} _TRIP_(input, old_code, PT _PTE_(c, next_code, PTNil) PTNil PTNil);
99
100 code_string old_code next_code [] code_table = {-# SCC "cs6" #-} _TRIP_([], old_code, PTNil);
101
102 integer_list_to_char_list (IBOX(n) : l)
103 = CBOX(_CHR_ (n _QUOT_ ILIT(16))) : integer_list_to_char_list2 l n;
104 integer_list_to_char_list [] = [];
105
106 integer_list_to_char_list2 (IBOX(c) : l) n
107 = CBOX(_CHR_ ((n _MUL_ ILIT(16)) _ADD_ ((c _QUOT_ ILIT(256)) _REM_ ILIT(16))))
108 : CBOX(_CHR_ c)
109 : integer_list_to_char_list l;
110 integer_list_to_char_list2 [] n = CBOX(_CHR_ (n _MUL_ ILIT(16))) : [];
111
112 main :: IO ();
113 main = getContents >>= \input_string -> main2 input_string;
114
115 main2 :: String -> IO ();
116 main2 input_string
117 = putStr output_list
118 where {
119 output_list = integer_list_to_char_list code_list;
120 code_list = lzw_code_file input_string create_code_table ILIT(256);
121 };
122
123 }