1 module Encode (CodeEvent(..), encode, maxBits) 2 where 3 4 --import GlaExts 5 6 data PrefixTrie a b = PTNil | 7 PT a b (PrefixTrie a b) (PrefixTrie a b) (PrefixTrie a b) 8 9 type CodeTable = PrefixTrie Char Int 10 11 data CodeEvent = 12 Code Int | 13 NewWordSize | 14 Clear deriving Show{-was:Text-} 15 16 data CodeState = CS 17 Int {-# STRICT #-} 18 Int {-# STRICT #-} 19 Int {-# STRICT #-} 20 Int {-# STRICT #-} 21 Int {-# STRICT #-} 22 Int {-# STRICT #-} 23 24 firstEnt = 257 :: Int 25 maxBits = 16 :: Int 26 checkGap = 10000 :: Int 27 firstCheck = 10000 :: Int 28 firstChange = (2^9) + 1 :: Int 29 30 maxmaxCode = 2^maxBits + 1 :: Int 31 32 encode :: [Int] -> String -> [CodeEvent] 33 encode = encode' (CS 3 1 firstCheck 0 firstEnt firstChange) initial_table 34 35 encode' :: CodeState -> CodeTable -> [Int] -> String -> [CodeEvent] 36 encode' _ _ _ [] = [] 37 encode' c@(CS bo ci cp ra nx cg) t sizes input 38 = if nx == cg then 39 NewWordSize : encode' (CS (bo+s) ci cp ra nx cg') t ss input 40 else 41 if nx == maxmaxCode then 42 if ci >= cp then 43 let ra' = (ci * 256) `div` bo in 44 if ra' > ra then 45 encode' (CS bo ci (ci+checkGap) ra' nx cg) t sizes input 46 else 47 Clear : 48 encode' (CS (bo+s) ci (ci+checkGap) 0 firstEnt firstChange) 49 initial_table ss input 50 else 51 let (input', n, i) = code_string_r (input, 0, 0) nx t 52 in Code n : 53 encode' (CS (bo+s) (ci+i) cp ra nx cg) t ss input' 54 else 55 (\ ((input', n, i), t') -> 56 Code n : 57 encode' (CS (bo+s) (ci+i) cp ra (nx+1) cg) t' ss input') 58 (code_string_rw (input, 0, 0) nx t) 59 where 60 (s:ss) = sizes 61 cg' = let val = ((cg - 1) * 2) + 1 in 62 if val == maxmaxCode then 0 else val 63 64 csForced (CS a b c d e f) = (a==a) && (b==b) && (c==c) && (d==d) 65 && (e==e) && (f==f) 66 67 code_string_r :: (String, Int, Int) -> Int -> CodeTable -> (String, Int, Int) 68 code_string_r s@([], _, _) _ _ 69 = s 70 code_string_r s _ PTNil 71 = s 72 code_string_r s@(c:cs, old_code, n) next_code (PT k v k_pt l r) 73 = if c == k then 74 code_string_r (cs, v, (n+1)) next_code k_pt 75 else 76 code_string_r s next_code (if c < k then l else r) 77 78 code_string_rw :: (String, Int, Int) -> Int -> CodeTable 79 -> ((String, Int, Int), CodeTable) 80 code_string_rw s@([], _, _) _ _ 81 = (s, PTNil) 82 code_string_rw s@(c:_,_,_) next_code PTNil 83 = (s, PT c next_code PTNil PTNil PTNil) 84 code_string_rw s@(c:cs, old_code, n) next_code (PT k k_code k_pt l r) 85 | c < k = (\ (s', l') -> (s', PT k k_code k_pt l' r)) 86 (code_string_rw s next_code l) 87 | c > k = (\ (s', r') -> (s', PT k k_code k_pt l r')) 88 (code_string_rw s next_code r) 89 | otherwise = (\ (s', t') -> (s', PT k k_code t' l r)) 90 (code_string_rw (cs, k_code, n+1) next_code k_pt) 91 92 initial_table :: CodeTable 93 initial_table = build_table 0 255 94 95 build_table :: Int -> Int -> CodeTable 96 build_table lo hi 97 = if lo > hi then 98 PTNil 99 else let mid = (lo + hi) `div` 2 in 100 --trace (show (lo,hi,mid)) 101 PT (toEnum mid) mid PTNil 102 (build_table lo (mid - 1)) 103 (build_table (mid + 1) hi)