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)