{-# LANGUAGE Safe #-}
-- arch-tag: Inflate implementation for Haskell

{-
Inflate implementation for Haskell

Copyright 2004 Ian Lynagh <igloo@earth.li>
Licence: 3 clause BSD.

\section{Inflate}

This module provides a Haskell implementation of the inflate function,
as described by RFC 1951.

-}

{- |
   Module     : Data.Compression.Inflate
   Copyright  : Copyright (C) 2004 Ian Lynagh
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Inflate algorithm implementation

Copyright (C) 2004 Ian Lynagh
-}

module Data.Compression.Inflate (inflate_string,
                                     inflate_string_remainder,
                                     inflate, Output, Bit,
                                    bits_to_word32) where

import safe Control.Monad ( ap, unless )
import safe Data.Array ( Array, array, (!), (//) )
import qualified Data.Char
import           Data.List
  ( mapAccumL, genericDrop, genericReplicate, genericSplitAt, genericTake
  , sort )
import safe Data.Maybe ()

import safe Data.Bits ( Bits(testBit) )
import safe Data.Word ( Word8, Word32 )

inflate_string :: String -> String
inflate_string :: String -> String
inflate_string = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
inflate_string_remainder
--    map (Data.Char.chr . fromIntegral) $ fst $ inflate $ map Data.Char.ord s

-- | Returns (Data, Remainder)
inflate_string_remainder :: String -> (String, String)
inflate_string_remainder :: String -> (String, String)
inflate_string_remainder String
s =
    let res :: (Output, [Bit])
res = [Int] -> (Output, [Bit])
inflate forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
Data.Char.ord String
s
        convw32l :: [a] -> String
convw32l [a]
l = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
Data.Char.chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [a]
l
        output :: String
output = forall {a}. Integral a => [a] -> String
convw32l forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (Output, [Bit])
res
        b2w32 :: [Bit] -> Output
b2w32 [] = []
        b2w32 [Bit]
b = let ([Bit]
this, [Bit]
next) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Bit]
b
                      in
                      [Bit] -> Word32
bits_to_word32 [Bit]
this forall a. a -> [a] -> [a]
: [Bit] -> Output
b2w32 [Bit]
next
        remainder :: String
remainder = forall {a}. Integral a => [a] -> String
convw32l forall a b. (a -> b) -> a -> b
$ [Bit] -> Output
b2w32 forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (Output, [Bit])
res
        in
        (String
output, String
remainder)

{-
\section{Types}

Type synonyms are your friend.

-}
type Output = [Word32] -- The final output

type Code = Word32     -- A generic code
type Dist = Code       -- A distance code
type LitLen = Code     -- A literal/length code
type Length = Word32   -- Number of bits needed to identify a code

type Table = InfM Code -- A Huffman table
type Tables = (Table, Table) -- lit/len and dist Huffman tables

{-

The \verb!Bit! datatype is used for the input. We can show values and
convert from the input we are given and to \verb!Word32!s which we us to
represent most values.

-}
newtype Bit = Bit Bool
    deriving Bit -> Bit -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bit -> Bit -> Bool
$c/= :: Bit -> Bit -> Bool
== :: Bit -> Bit -> Bool
$c== :: Bit -> Bit -> Bool
Eq
instance Show Bit where
    show :: Bit -> String
show = (\Char
x -> [Char
x]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bit -> Char
show_b
    showList :: [Bit] -> String -> String
showList [Bit]
bs = String -> String -> String
showString forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Bit -> Char
show_b [Bit]
bs forall a. [a] -> [a] -> [a]
++ String
"'"

show_b :: Bit -> Char
show_b :: Bit -> Char
show_b (Bit Bool
True)  = Char
'1'
show_b (Bit Bool
False) = Char
'0'

int_to_bits :: Int -> [Bit]
int_to_bits :: Int -> [Bit]
int_to_bits = Word8 -> [Bit]
word8_to_bits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

word8_to_bits :: Word8 -> [Bit]
word8_to_bits :: Word8 -> [Bit]
word8_to_bits Word8
n = forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Bool -> Bit
Bit (forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
i)) [Int
0..Int
7]

bits_to_word32 :: [Bit] -> Word32
bits_to_word32 :: [Bit] -> Word32
bits_to_word32 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Bit Bool
b) Word32
i -> Word32
2 forall a. Num a => a -> a -> a
* Word32
i forall a. Num a => a -> a -> a
+ (if Bool
b then Word32
1 else Word32
0)) Word32
0

{-

\section{Monad}

offset is rarely used, so make it strict to avoid building huge closures.

-}
data State = State { State -> [Bit]
bits    :: [Bit],                  -- remaining input bits
                     State -> Word32
offset  :: !Word32,              -- num bits consumed mod 8
                     State -> Array Word32 Word32
history :: Array Word32 Word32, -- last 32768 output words
                     State -> Word32
loc     :: Word32                   -- where in history we are
                   }
data InfM a = InfM (State -> (a, State))

instance Monad InfM where
 -- (>>=)  :: InfM a -> (a -> InfM b) -> InfM b
    InfM State -> (a, State)
v >>= :: forall a b. InfM a -> (a -> InfM b) -> InfM b
>>= a -> InfM b
f = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s -> let (a
x, State
s') = State -> (a, State)
v State
s
                                    InfM State -> (b, State)
y = a -> InfM b
f a
x
                                in State -> (b, State)
y State
s'
 -- return :: a -> InfM a
    return :: forall a. a -> InfM a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Applicative InfM where
    pure :: forall a. a -> InfM a
pure a
x = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s -> (a
x, State
s)
    <*> :: forall a b. InfM (a -> b) -> InfM a -> InfM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor InfM where
    fmap :: forall a b. (a -> b) -> InfM a -> InfM b
fmap a -> b
f (InfM State -> (a, State)
g) = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s ->
        case State -> (a, State)
g State
s of ~(a
a, State
s') -> (a -> b
f a
a, State
s')

set_bits :: [Bit] -> InfM ()
set_bits :: [Bit] -> InfM ()
set_bits [Bit]
bs = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const ((), [Bit] -> Word32 -> Array Word32 Word32 -> Word32 -> State
State [Bit]
bs Word32
0 (forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Word32
0, Word32
32767) []) Word32
0)

{-
no_bits :: InfM Bool
no_bits = InfM $ \s -> (null (bits s), s)
-}

align_8_bits :: InfM ()
align_8_bits :: InfM ()
align_8_bits
 = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s -> ((), State
s { bits :: [Bit]
bits = forall i a. Integral i => i -> [a] -> [a]
genericDrop ((Word32
8 forall a. Num a => a -> a -> a
- State -> Word32
offset State
s) forall a. Integral a => a -> a -> a
`mod` Word32
8) (State -> [Bit]
bits State
s),
                         offset :: Word32
offset = Word32
0 })

get_bits :: Word32 -> InfM [Bit]
get_bits :: Word32 -> InfM [Bit]
get_bits Word32
n = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s -> case forall {a} {a}. (Eq a, Num a) => a -> [a] -> ([a], [a])
need Word32
n (State -> [Bit]
bits State
s) of
                              ([Bit]
ys, [Bit]
zs) ->
                                  ([Bit]
ys, State
s { bits :: [Bit]
bits = [Bit]
zs,
                                           offset :: Word32
offset = (Word32
n forall a. Num a => a -> a -> a
+ State -> Word32
offset State
s) forall a. Integral a => a -> a -> a
`mod` Word32
8 } )
    where need :: a -> [a] -> ([a], [a])
need a
0 [a]
xs     = ([], [a]
xs)
          need a
_ []     = forall a. HasCallStack => String -> a
error String
"get_bits: Don't have enough!"
          need a
i (a
x:[a]
xs) = let ([a]
ys, [a]
zs) = a -> [a] -> ([a], [a])
need (a
iforall a. Num a => a -> a -> a
-a
1) [a]
xs in (a
xforall a. a -> [a] -> [a]
:[a]
ys, [a]
zs)

extract_InfM :: InfM a -> (a, [Bit])
extract_InfM :: forall a. InfM a -> (a, [Bit])
extract_InfM (InfM State -> (a, State)
f) = let (a
x, State
s) = State -> (a, State)
f forall a. HasCallStack => a
undefined in (a
x, State -> [Bit]
bits State
s)

output_w32 :: Word32 -> InfM ()
output_w32 :: Word32 -> InfM ()
output_w32 Word32
w = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s -> let l :: Word32
l = State -> Word32
loc State
s
                            in ((), State
s { history :: Array Word32 Word32
history = State -> Array Word32 Word32
history State
s forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Word32
l, Word32
w)],
                                        loc :: Word32
loc = Word32
l forall a. Num a => a -> a -> a
+ Word32
1 })

repeat_w32s :: Word32 -> Word32 -> InfM [Word32]
repeat_w32s :: Word32 -> Word32 -> InfM Output
repeat_w32s Word32
len Word32
dist
 = forall a. (State -> (a, State)) -> InfM a
InfM forall a b. (a -> b) -> a -> b
$ \State
s -> let l :: Word32
l = State -> Word32
loc State
s
                    h :: Array Word32 Word32
h = State -> Array Word32 Word32
history State
s
                    new :: Output
new = forall a b. (a -> b) -> [a] -> [b]
map (Array Word32 Word32
hforall i e. Ix i => Array i e -> i -> e
!) forall a b. (a -> b) -> a -> b
$ forall i a. Integral i => i -> [a] -> [a]
genericTake Word32
dist ([(Word32
l forall a. Num a => a -> a -> a
- Word32
dist) forall a. Integral a => a -> a -> a
`mod` Word32
32768..Word32
32767] forall a. [a] -> [a] -> [a]
++ [Word32
0..])
                    new_bit :: Output
new_bit = forall i a. Integral i => i -> [a] -> [a]
genericTake Word32
len (forall a. [a] -> [a]
cycle Output
new)
                    h' :: Array Word32 Word32
h' = Array Word32 Word32
h forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Integral a => a -> a -> a
`mod` Word32
32768) [Word32
l..]) Output
new_bit
                in (Output
new_bit, State
s { history :: Array Word32 Word32
history = Array Word32 Word32
h', loc :: Word32
loc = (Word32
l forall a. Num a => a -> a -> a
+ Word32
len) forall a. Integral a => a -> a -> a
`mod` Word32
32768 })

-----------------------------------

get_word32s :: Word32 -> Word32 -> InfM [Word32]
get_word32s :: Word32 -> Word32 -> InfM Output
get_word32s Word32
_ Word32
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
get_word32s Word32
b Word32
n = do Word32
w <- Word32 -> InfM Word32
get_w32 Word32
b
                     Output
ws <- Word32 -> Word32 -> InfM Output
get_word32s Word32
b (Word32
nforall a. Num a => a -> a -> a
-Word32
1)
                     forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
wforall a. a -> [a] -> [a]
:Output
ws)

get_w32 :: Word32 -> InfM Word32
get_w32 :: Word32 -> InfM Word32
get_w32 Word32
i = do [Bit]
bs <- Word32 -> InfM [Bit]
get_bits Word32
i
               forall (m :: * -> *) a. Monad m => a -> m a
return ([Bit] -> Word32
bits_to_word32 [Bit]
bs)

get_bit :: InfM Bit
get_bit :: InfM Bit
get_bit = do [Bit]
res <- Word32 -> InfM [Bit]
get_bits Word32
1
             case [Bit]
res of
                 [Bit
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bit
x
                 [Bit]
_   -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"get_bit: expected exactly one bit"

{-
\section{Inflate itself}

The hardcore stuff!

-}
inflate :: [Int] -> (Output, [Bit])
inflate :: [Int] -> (Output, [Bit])
inflate [Int]
is = forall a. InfM a -> (a, [Bit])
extract_InfM forall a b. (a -> b) -> a -> b
$ do [Bit] -> InfM ()
set_bits forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Bit]
int_to_bits [Int]
is
                               Output
x <- Bool -> InfM Output
inflate_blocks Bool
False
                               InfM ()
align_8_bits
                               forall (m :: * -> *) a. Monad m => a -> m a
return Output
x

-- Bool is true if we have seen the "last" block
inflate_blocks :: Bool -> InfM Output
inflate_blocks :: Bool -> InfM Output
inflate_blocks Bool
True = forall (m :: * -> *) a. Monad m => a -> m a
return []
inflate_blocks Bool
False
     = do [Bit]
res <- Word32 -> InfM [Bit]
get_bits Word32
3
          case [Bit]
res of
              [Bit Bool
is_last, Bit Bool
t1, Bit Bool
t2] ->
                  case (Bool
t1, Bool
t2) of
                      (Bool
False, Bool
False) ->
                          do InfM ()
align_8_bits
                             Word32
len <- Word32 -> InfM Word32
get_w32 Word32
16
                             Word32
nlen <- Word32 -> InfM Word32
get_w32 Word32
16
                             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
len forall a. Num a => a -> a -> a
+ Word32
nlen forall a. Eq a => a -> a -> Bool
== Word32
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int) forall a. Num a => a -> a -> a
- Word32
1)
                                forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"inflate_blocks: Mismatched lengths"
                             Output
ws <- Word32 -> Word32 -> InfM Output
get_word32s Word32
8 Word32
len
                             forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word32 -> InfM ()
output_w32 Output
ws
                             forall (m :: * -> *) a. Monad m => a -> m a
return Output
ws
                      (Bool
True, Bool
False) ->
                          Bool -> Tables -> InfM Output
inflate_codes Bool
is_last Tables
inflate_trees_fixed
                      (Bool
False, Bool
True) ->
                          do Tables
tables <- InfM Tables
inflate_tables
                             Bool -> Tables -> InfM Output
inflate_codes Bool
is_last Tables
tables
                      (Bool
True, Bool
True) ->
                          forall a. HasCallStack => String -> a
error (String
"inflate_blocks: case 11 reserved")
              [Bit]
_ -> forall a. HasCallStack => String -> a
error (String
"inflate_blocks: expected 3 bits")

inflate_tables :: InfM Tables
inflate_tables :: InfM Tables
inflate_tables
 = do Word32
hlit <- Word32 -> InfM Word32
get_w32 Word32
5
      Word32
hdist <- Word32 -> InfM Word32
get_w32 Word32
5
      Word32
hclen <- Word32 -> InfM Word32
get_w32 Word32
4
      [Bit]
llc_bs <- Word32 -> InfM [Bit]
get_bits ((Word32
hclen forall a. Num a => a -> a -> a
+ Word32
4) forall a. Num a => a -> a -> a
* Word32
3)
      let llc_bs' :: [(Word32, Word32)]
llc_bs' = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map [Bit] -> Word32
bits_to_word32 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
triple [Bit]
llc_bs)
                        [Word32
16,Word32
17,Word32
18,Word32
0,Word32
8,Word32
7,Word32
9,Word32
6,Word32
10,Word32
5,Word32
11,Word32
4,Word32
12,Word32
3,Word32
13,Word32
2,Word32
14,Word32
1,Word32
15]
          tab :: InfM Word32
tab = [(Word32, Word32)] -> InfM Word32
make_table [(Word32, Word32)]
llc_bs'
      Output
lit_dist_lengths <- InfM Word32 -> Word32 -> Word32 -> InfM Output
make_lit_dist_lengths InfM Word32
tab
                                                (Word32
258 forall a. Num a => a -> a -> a
+ Word32
hlit forall a. Num a => a -> a -> a
+ Word32
hdist)
                                                (forall a. HasCallStack => String -> a
error String
"inflate_tables dummy")
      let (Output
lit_lengths, Output
dist_lengths) = forall i a. Integral i => i -> [a] -> ([a], [a])
genericSplitAt (Word32
257 forall a. Num a => a -> a -> a
+ Word32
hlit)
                                                       Output
lit_dist_lengths
          lit_table :: InfM Word32
lit_table = [(Word32, Word32)] -> InfM Word32
make_table (forall a b. [a] -> [b] -> [(a, b)]
zip Output
lit_lengths [Word32
0..])
          dist_table :: InfM Word32
dist_table = [(Word32, Word32)] -> InfM Word32
make_table (forall a b. [a] -> [b] -> [(a, b)]
zip Output
dist_lengths [Word32
0..])
      forall (m :: * -> *) a. Monad m => a -> m a
return (InfM Word32
lit_table, InfM Word32
dist_table)

triple :: [a] -> [[a]]
triple :: forall a. [a] -> [[a]]
triple (a
a:a
b:a
c:[a]
xs) = [a
a,a
b,a
c]forall a. a -> [a] -> [a]
:forall a. [a] -> [[a]]
triple [a]
xs
triple []         = []
triple [a]
_          = forall a. HasCallStack => String -> a
error String
"triple: can't happen"

make_lit_dist_lengths :: Table -> Word32 -> Word32 -> InfM [Word32]
make_lit_dist_lengths :: InfM Word32 -> Word32 -> Word32 -> InfM Output
make_lit_dist_lengths InfM Word32
_ Word32
i Word32
_ | Word32
i forall a. Ord a => a -> a -> Bool
< Word32
0 = forall a. HasCallStack => String -> a
error String
"make_lit_dist_lengths i < 0"
make_lit_dist_lengths InfM Word32
_ Word32
0 Word32
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
make_lit_dist_lengths InfM Word32
tab Word32
i Word32
last_thing
 = do Word32
c <- InfM Word32
tab
      (Output
ls, Word32
i', Word32
last_thing') <- Word32 -> Word32 -> Word32 -> InfM (Output, Word32, Word32)
meta_code Word32
i Word32
c Word32
last_thing
      Output
ws <- InfM Word32 -> Word32 -> Word32 -> InfM Output
make_lit_dist_lengths InfM Word32
tab Word32
i' Word32
last_thing'
      forall (m :: * -> *) a. Monad m => a -> m a
return (Output
ls forall a. [a] -> [a] -> [a]
++ Output
ws)

meta_code :: Word32 -> Code -> Word32 -> InfM ([Word32], Word32, Word32)
meta_code :: Word32 -> Word32 -> Word32 -> InfM (Output, Word32, Word32)
meta_code Word32
c Word32
i Word32
_ | Word32
i forall a. Ord a => a -> a -> Bool
< Word32
16 = forall (m :: * -> *) a. Monad m => a -> m a
return ([Word32
i], Word32
c forall a. Num a => a -> a -> a
- Word32
1, Word32
i)
meta_code Word32
c Word32
16 Word32
last_thing
                 = do [Bit]
xs <- Word32 -> InfM [Bit]
get_bits Word32
2
                      let l :: Word32
l = Word32
3 forall a. Num a => a -> a -> a
+ [Bit] -> Word32
bits_to_word32 [Bit]
xs
                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall i a. Integral i => i -> a -> [a]
genericReplicate Word32
l Word32
last_thing, Word32
c forall a. Num a => a -> a -> a
- Word32
l, Word32
last_thing)
meta_code Word32
c Word32
17 Word32
_ = do [Bit]
xs <- Word32 -> InfM [Bit]
get_bits Word32
3
                      let l :: Word32
l = Word32
3 forall a. Num a => a -> a -> a
+ [Bit] -> Word32
bits_to_word32 [Bit]
xs
                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall i a. Integral i => i -> a -> [a]
genericReplicate Word32
l Word32
0, Word32
c forall a. Num a => a -> a -> a
- Word32
l, Word32
0)
meta_code Word32
c Word32
18 Word32
_ = do [Bit]
xs <- Word32 -> InfM [Bit]
get_bits Word32
7
                      let l :: Word32
l = Word32
11 forall a. Num a => a -> a -> a
+ [Bit] -> Word32
bits_to_word32 [Bit]
xs
                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall i a. Integral i => i -> a -> [a]
genericReplicate Word32
l Word32
0, Word32
c forall a. Num a => a -> a -> a
- Word32
l, Word32
0)
meta_code Word32
_ Word32
i Word32
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"meta_code: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
i

inflate_codes :: Bool -> Tables -> InfM Output
inflate_codes :: Bool -> Tables -> InfM Output
inflate_codes Bool
seen_last tabs :: Tables
tabs@(InfM Word32
tab_litlen, InfM Word32
tab_dist)
 =
   {- do done <- no_bits
      if done
        then return [] -- XXX Is this right?
        else -}
             do Word32
i <- InfM Word32
tab_litlen;
                if Word32
i forall a. Eq a => a -> a -> Bool
== Word32
256
                  then Bool -> InfM Output
inflate_blocks Bool
seen_last
                  else
                       do Output
pref <- if Word32
i forall a. Ord a => a -> a -> Bool
< Word32
256
                                  then do Word32 -> InfM ()
output_w32 Word32
i
                                          forall (m :: * -> *) a. Monad m => a -> m a
return [Word32
i]
                                  else case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word32
i [(Word32, (Word32, Word32))]
litlens of
                                           Maybe (Word32, Word32)
Nothing -> forall a. HasCallStack => String -> a
error String
"do_code_litlen"
                                           Just (Word32
base, Word32
num_bits) ->
                                               do Word32
extra <- Word32 -> InfM Word32
get_w32 Word32
num_bits
                                                  let l :: Word32
l = Word32
base forall a. Num a => a -> a -> a
+ Word32
extra
                                                  Word32
dist <- InfM Word32 -> InfM Word32
dist_code InfM Word32
tab_dist
                                                  Word32 -> Word32 -> InfM Output
repeat_w32s Word32
l Word32
dist
                          Output
o <- Bool -> Tables -> InfM Output
inflate_codes Bool
seen_last Tables
tabs
                          forall (m :: * -> *) a. Monad m => a -> m a
return (Output
pref forall a. [a] -> [a] -> [a]
++ Output
o)

litlens :: [(Code, (LitLen, Word32))]
litlens :: [(Word32, (Word32, Word32))]
litlens = forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
257..Word32
285] forall a b. (a -> b) -> a -> b
$ Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases Word32
3 [(Int, Word32)]
litlen_counts forall a. [a] -> [a] -> [a]
++ [(Word32
258, Word32
0)]
    where litlen_counts :: [(Int, Word32)]
litlen_counts = [(Int
8,Word32
0),(Int
4,Word32
1),(Int
4,Word32
2),(Int
4,Word32
3),(Int
4,Word32
4),(Int
4,Word32
5)]

dist_code :: Table -> InfM Dist
dist_code :: InfM Word32 -> InfM Word32
dist_code InfM Word32
tab
 = do Word32
code <- InfM Word32
tab
      case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word32
code [(Word32, (Word32, Word32))]
dists of
          Maybe (Word32, Word32)
Nothing -> forall a. HasCallStack => String -> a
error String
"dist_code"
          Just (Word32
base, Word32
num_bits) -> do Word32
extra <- Word32 -> InfM Word32
get_w32 Word32
num_bits
                                      forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
base forall a. Num a => a -> a -> a
+ Word32
extra)

dists :: [(Code, (Dist, Word32))]
dists :: [(Word32, (Word32, Word32))]
dists = forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0..Word32
29] forall a b. (a -> b) -> a -> b
$ Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases Word32
1 [(Int, Word32)]
dist_counts
    where dist_counts :: [(Int, Word32)]
dist_counts = (Int
4,Word32
0)forall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map ((,) Int
2) [Word32
1..Word32
13]

mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases Word32
base [(Int, Word32)]
counts = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {b} {a}. (Integral b, Num a) => a -> b -> (a, (a, b))
next_base Word32
base Output
incs
            where next_base :: a -> b -> (a, (a, b))
next_base a
current b
bs = (a
current forall a. Num a => a -> a -> a
+ a
2forall a b. (Num a, Integral b) => a -> b -> a
^b
bs, (a
current, b
bs))
                  incs :: Output
incs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Int -> a -> [a]
replicate) [(Int, Word32)]
counts

{-
\section{Fixed tables}

The fixed tables. Not much to say really.

-}
inflate_trees_fixed :: Tables
inflate_trees_fixed :: Tables
inflate_trees_fixed = ([(Word32, Word32)] -> InfM Word32
make_table forall a b. (a -> b) -> a -> b
$ [(Word32
8, Word32
c) | Word32
c <- [Word32
0..Word32
143]]
                                 forall a. [a] -> [a] -> [a]
++ [(Word32
9, Word32
c) | Word32
c <- [Word32
144..Word32
255]]
                                 forall a. [a] -> [a] -> [a]
++ [(Word32
7, Word32
c) | Word32
c <- [Word32
256..Word32
279]]
                                 forall a. [a] -> [a] -> [a]
++ [(Word32
8, Word32
c) | Word32
c <- [Word32
280..Word32
287]],
                       [(Word32, Word32)] -> InfM Word32
make_table [(Word32
5, Word32
c) | Word32
c <- [Word32
0..Word32
29]])

{-
\section{The Huffman Tree}

As the name suggests, the obvious way to store Huffman trees is in a
tree datastructure. Externally we want to view them as functions though,
so we wrap the tree with \verb!get_code! which takes a list of bits and
returns the corresponding code and the remaining bits. To make a tree
from a list of length code pairs is a simple recursive process.

-}
data Tree = Branch Tree Tree | Leaf Word32 | Null

make_table :: [(Length, Code)] -> Table
make_table :: [(Word32, Word32)] -> InfM Word32
make_table [(Word32, Word32)]
lcs = case Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree Word32
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Word32
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Word32, Word32)]
lcs of
                     (Tree
tree, []) -> Tree -> InfM Word32
get_code Tree
tree
                     (Tree, [(Word32, Word32)])
_          -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"make_table: Left-over lcs from"

get_code :: Tree -> InfM Code
get_code :: Tree -> InfM Word32
get_code (Branch Tree
zero_tree Tree
one_tree)
 = do Bit Bool
b <- InfM Bit
get_bit
      if Bool
b then Tree -> InfM Word32
get_code Tree
one_tree else Tree -> InfM Word32
get_code Tree
zero_tree
get_code (Leaf Word32
w) = forall (m :: * -> *) a. Monad m => a -> m a
return Word32
w
get_code Tree
Null = forall a. HasCallStack => String -> a
error String
"get_code Null"

make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)])
make_tree :: Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree Word32
_ [] = (Tree
Null, [])
make_tree Word32
i lcs :: [(Word32, Word32)]
lcs@((Word32
l, Word32
c):[(Word32, Word32)]
lcs')
 | Word32
i forall a. Eq a => a -> a -> Bool
== Word32
l = (Word32 -> Tree
Leaf Word32
c, [(Word32, Word32)]
lcs')
 | Word32
i forall a. Ord a => a -> a -> Bool
< Word32
l = let (Tree
zero_tree, [(Word32, Word32)]
lcs_z) = Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree (Word32
iforall a. Num a => a -> a -> a
+Word32
1) [(Word32, Word32)]
lcs
               (Tree
one_tree, [(Word32, Word32)]
lcs_o) = Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree (Word32
iforall a. Num a => a -> a -> a
+Word32
1) [(Word32, Word32)]
lcs_z
           in (Tree -> Tree -> Tree
Branch Tree
zero_tree Tree
one_tree, [(Word32, Word32)]
lcs_o)
 | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"make_tree: can't happen"