{-# 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 = (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
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 ([Int] -> (Output, [Bit])) -> [Int] -> (Output, [Bit])
forall a b. (a -> b) -> a -> b
$ (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
Data.Char.ord String
s
        convw32l :: [a] -> String
convw32l [a]
l = (a -> Char) -> [a] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
Data.Char.chr (Int -> Char) -> (a -> Int) -> a -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [a]
l
        output :: String
output = Output -> String
forall {a}. Integral a => [a] -> String
convw32l (Output -> String) -> Output -> String
forall a b. (a -> b) -> a -> b
$ (Output, [Bit]) -> Output
forall a b. (a, b) -> a
fst (Output, [Bit])
res
        b2w32 :: [Bit] -> Output
b2w32 [] = []
        b2w32 [Bit]
b = let ([Bit]
this, [Bit]
next) = Int -> [Bit] -> ([Bit], [Bit])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Bit]
b
                      in
                      [Bit] -> Word32
bits_to_word32 [Bit]
this Word32 -> Output -> Output
forall a. a -> [a] -> [a]
: [Bit] -> Output
b2w32 [Bit]
next
        remainder :: String
remainder = Output -> String
forall {a}. Integral a => [a] -> String
convw32l (Output -> String) -> Output -> String
forall a b. (a -> b) -> a -> b
$ [Bit] -> Output
b2w32 ([Bit] -> Output) -> [Bit] -> Output
forall a b. (a -> b) -> a -> b
$ (Output, [Bit]) -> [Bit]
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
(Bit -> Bit -> Bool) -> (Bit -> Bit -> Bool) -> Eq Bit
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]) (Char -> String) -> (Bit -> Char) -> Bit -> String
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 (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Bit -> Char) -> [Bit] -> String
forall a b. (a -> b) -> [a] -> [b]
map Bit -> Char
show_b [Bit]
bs String -> String -> String
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 (Word8 -> [Bit]) -> (Int -> Word8) -> Int -> [Bit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
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 = (Int -> Bit) -> [Int] -> [Bit]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Bool -> Bit
Bit (Word8 -> Int -> Bool
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 = (Bit -> Word32 -> Word32) -> Word32 -> [Bit] -> Word32
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Bit Bool
b) Word32
i -> Word32
2 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
i Word32 -> Word32 -> Word32
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 = (State -> (b, State)) -> InfM b
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> (b, State)) -> InfM b)
-> (State -> (b, State)) -> InfM b
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 = a -> InfM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Applicative InfM where
    pure :: forall a. a -> InfM a
pure a
x = (State -> (a, State)) -> InfM a
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> (a, State)) -> InfM a)
-> (State -> (a, State)) -> InfM a
forall a b. (a -> b) -> a -> b
$ \State
s -> (a
x, State
s)
    <*> :: forall a b. InfM (a -> b) -> InfM a -> InfM 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) = (State -> (b, State)) -> InfM b
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> (b, State)) -> InfM b)
-> (State -> (b, State)) -> InfM b
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 = (State -> ((), State)) -> InfM ()
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> ((), State)) -> InfM ())
-> (State -> ((), State)) -> InfM ()
forall a b. (a -> b) -> a -> b
$ ((), State) -> State -> ((), State)
forall a b. a -> b -> a
const ((), [Bit] -> Word32 -> Array Word32 Word32 -> Word32 -> State
State [Bit]
bs Word32
0 ((Word32, Word32) -> [(Word32, Word32)] -> Array Word32 Word32
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
 = (State -> ((), State)) -> InfM ()
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> ((), State)) -> InfM ())
-> (State -> ((), State)) -> InfM ()
forall a b. (a -> b) -> a -> b
$ \State
s -> ((), State
s { bits :: [Bit]
bits = Word32 -> [Bit] -> [Bit]
forall i a. Integral i => i -> [a] -> [a]
genericDrop ((Word32
8 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- State -> Word32
offset State
s) Word32 -> Word32 -> Word32
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 = (State -> ([Bit], State)) -> InfM [Bit]
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> ([Bit], State)) -> InfM [Bit])
-> (State -> ([Bit], State)) -> InfM [Bit]
forall a b. (a -> b) -> a -> b
$ \State
s -> case Word32 -> [Bit] -> ([Bit], [Bit])
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ State -> Word32
offset State
s) Word32 -> Word32 -> Word32
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
_ []     = String -> ([a], [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
ia -> a -> a
forall a. Num a => a -> a -> a
-a
1) [a]
xs in (a
xa -> [a] -> [a]
forall 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 State
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 = (State -> ((), State)) -> InfM ()
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> ((), State)) -> InfM ())
-> (State -> ((), State)) -> 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 Array Word32 Word32 -> [(Word32, Word32)] -> Array Word32 Word32
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Word32
l, Word32
w)],
                                        loc :: Word32
loc = Word32
l Word32 -> Word32 -> Word32
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
 = (State -> (Output, State)) -> InfM Output
forall a. (State -> (a, State)) -> InfM a
InfM ((State -> (Output, State)) -> InfM Output)
-> (State -> (Output, State)) -> InfM Output
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 = (Word32 -> Word32) -> Output -> Output
forall a b. (a -> b) -> [a] -> [b]
map (Array Word32 Word32
hArray Word32 Word32 -> Word32 -> Word32
forall i e. Ix i => Array i e -> i -> e
!) (Output -> Output) -> Output -> Output
forall a b. (a -> b) -> a -> b
$ Word32 -> Output -> Output
forall i a. Integral i => i -> [a] -> [a]
genericTake Word32
dist ([(Word32
l Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
dist) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` Word32
32768..Word32
32767] Output -> Output -> Output
forall a. [a] -> [a] -> [a]
++ [Word32
0..])
                    new_bit :: Output
new_bit = Word32 -> Output -> Output
forall i a. Integral i => i -> [a] -> [a]
genericTake Word32
len (Output -> Output
forall a. [a] -> [a]
cycle Output
new)
                    h' :: Array Word32 Word32
h' = Array Word32 Word32
h Array Word32 Word32 -> [(Word32, Word32)] -> Array Word32 Word32
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// Output -> Output -> [(Word32, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Word32 -> Word32) -> Output -> Output
forall a b. (a -> b) -> [a] -> [b]
map (Word32 -> Word32 -> Word32
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
len) Word32 -> Word32 -> Word32
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 = Output -> InfM Output
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
nWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1)
                     Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
wWord32 -> Output -> Output
forall 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
               Word32 -> InfM Word32
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] -> Bit -> InfM Bit
forall (m :: * -> *) a. Monad m => a -> m a
return Bit
x
                 [Bit]
_   -> String -> InfM Bit
forall a. HasCallStack => String -> a
error (String -> InfM Bit) -> String -> InfM Bit
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 = InfM Output -> (Output, [Bit])
forall a. InfM a -> (a, [Bit])
extract_InfM (InfM Output -> (Output, [Bit])) -> InfM Output -> (Output, [Bit])
forall a b. (a -> b) -> a -> b
$ do [Bit] -> InfM ()
set_bits ([Bit] -> InfM ()) -> [Bit] -> InfM ()
forall a b. (a -> b) -> a -> b
$ (Int -> [Bit]) -> [Int] -> [Bit]
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
                               Output -> InfM Output
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 = Output -> InfM Output
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
                             Bool -> InfM () -> InfM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
len Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
nlen Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
2Word32 -> Int -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1)
                                (InfM () -> InfM ()) -> InfM () -> InfM ()
forall a b. (a -> b) -> a -> b
$ String -> InfM ()
forall a. HasCallStack => String -> a
error String
"inflate_blocks: Mismatched lengths"
                             Output
ws <- Word32 -> Word32 -> InfM Output
get_word32s Word32
8 Word32
len
                             (Word32 -> InfM ()) -> Output -> InfM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word32 -> InfM ()
output_w32 Output
ws
                             Output -> InfM Output
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) ->
                          String -> InfM Output
forall a. HasCallStack => String -> a
error (String
"inflate_blocks: case 11 reserved")
              [Bit]
_ -> String -> InfM Output
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
4) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
3)
      let llc_bs' :: [(Word32, Word32)]
llc_bs' = Output -> Output -> [(Word32, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([Bit] -> Word32) -> [[Bit]] -> Output
forall a b. (a -> b) -> [a] -> [b]
map [Bit] -> Word32
bits_to_word32 ([[Bit]] -> Output) -> [[Bit]] -> Output
forall a b. (a -> b) -> a -> b
$ [Bit] -> [[Bit]]
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
hlit Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
hdist)
                                                (String -> Word32
forall a. HasCallStack => String -> a
error String
"inflate_tables dummy")
      let (Output
lit_lengths, Output
dist_lengths) = Word32 -> Output -> (Output, Output)
forall i a. Integral i => i -> [a] -> ([a], [a])
genericSplitAt (Word32
257 Word32 -> Word32 -> Word32
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 (Output -> Output -> [(Word32, Word32)]
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 (Output -> Output -> [(Word32, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip Output
dist_lengths [Word32
0..])
      Tables -> InfM Tables
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][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[a] -> [[a]]
forall a. [a] -> [[a]]
triple [a]
xs
triple []         = []
triple [a]
_          = String -> [[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 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
0 = String -> InfM Output
forall a. HasCallStack => String -> a
error String
"make_lit_dist_lengths i < 0"
make_lit_dist_lengths InfM Word32
_ Word32
0 Word32
_ = Output -> InfM Output
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'
      Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return (Output
ls Output -> Output -> Output
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 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
16 = (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word32
i], Word32
c Word32 -> Word32 -> Word32
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ [Bit] -> Word32
bits_to_word32 [Bit]
xs
                      (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word32 -> Output
forall i a. Integral i => i -> a -> [a]
genericReplicate Word32
l Word32
last_thing, Word32
c Word32 -> Word32 -> Word32
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ [Bit] -> Word32
bits_to_word32 [Bit]
xs
                      (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word32 -> Output
forall i a. Integral i => i -> a -> [a]
genericReplicate Word32
l Word32
0, Word32
c Word32 -> Word32 -> Word32
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ [Bit] -> Word32
bits_to_word32 [Bit]
xs
                      (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word32 -> Output
forall i a. Integral i => i -> a -> [a]
genericReplicate Word32
l Word32
0, Word32
c Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
l, Word32
0)
meta_code Word32
_ Word32
i Word32
_ = String -> InfM (Output, Word32, Word32)
forall a. HasCallStack => String -> a
error (String -> InfM (Output, Word32, Word32))
-> String -> InfM (Output, Word32, Word32)
forall a b. (a -> b) -> a -> b
$ String
"meta_code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
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 Word32 -> Word32 -> Bool
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 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
256
                                  then do Word32 -> InfM ()
output_w32 Word32
i
                                          Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return [Word32
i]
                                  else case Word32 -> [(Word32, (Word32, Word32))] -> Maybe (Word32, Word32)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word32
i [(Word32, (Word32, Word32))]
litlens of
                                           Maybe (Word32, Word32)
Nothing -> String -> InfM Output
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 Word32 -> Word32 -> Word32
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
                          Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return (Output
pref Output -> Output -> Output
forall a. [a] -> [a] -> [a]
++ Output
o)

litlens :: [(Code, (LitLen, Word32))]
litlens :: [(Word32, (Word32, Word32))]
litlens = Output -> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
257..Word32
285] ([(Word32, Word32)] -> [(Word32, (Word32, Word32))])
-> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
forall a b. (a -> b) -> a -> b
$ Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases Word32
3 [(Int, Word32)]
litlen_counts [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
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 Word32 -> [(Word32, (Word32, Word32))] -> Maybe (Word32, Word32)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word32
code [(Word32, (Word32, Word32))]
dists of
          Maybe (Word32, Word32)
Nothing -> String -> InfM Word32
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
                                      Word32 -> InfM Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
base Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
extra)

dists :: [(Code, (Dist, Word32))]
dists :: [(Word32, (Word32, Word32))]
dists = Output -> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0..Word32
29] ([(Word32, Word32)] -> [(Word32, (Word32, Word32))])
-> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
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)(Int, Word32) -> [(Int, Word32)] -> [(Int, Word32)]
forall a. a -> [a] -> [a]
:(Word32 -> (Int, Word32)) -> Output -> [(Int, Word32)]
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 = (Word32, [(Word32, Word32)]) -> [(Word32, Word32)]
forall a b. (a, b) -> b
snd ((Word32, [(Word32, Word32)]) -> [(Word32, Word32)])
-> (Word32, [(Word32, Word32)]) -> [(Word32, Word32)]
forall a b. (a -> b) -> a -> b
$ (Word32 -> Word32 -> (Word32, (Word32, Word32)))
-> Word32 -> Output -> (Word32, [(Word32, Word32)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Word32 -> Word32 -> (Word32, (Word32, Word32))
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 a -> a -> a
forall a. Num a => a -> a -> a
+ a
2a -> b -> a
forall a b. (Num a, Integral b) => a -> b -> a
^b
bs, (a
current, b
bs))
                  incs :: Output
incs = [Output] -> Output
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Output] -> Output) -> [Output] -> Output
forall a b. (a -> b) -> a -> b
$ ((Int, Word32) -> Output) -> [(Int, Word32)] -> [Output]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Word32 -> Output) -> (Int, Word32) -> Output
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Word32 -> Output
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 ([(Word32, Word32)] -> InfM Word32)
-> [(Word32, Word32)] -> InfM Word32
forall a b. (a -> b) -> a -> b
$ [(Word32
8, Word32
c) | Word32
c <- [Word32
0..Word32
143]]
                                 [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a] -> [a]
++ [(Word32
9, Word32
c) | Word32
c <- [Word32
144..Word32
255]]
                                 [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a] -> [a]
++ [(Word32
7, Word32
c) | Word32
c <- [Word32
256..Word32
279]]
                                 [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
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 ([(Word32, Word32)] -> (Tree, [(Word32, Word32)]))
-> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
forall a b. (a -> b) -> a -> b
$ [(Word32, Word32)] -> [(Word32, Word32)]
forall a. Ord a => [a] -> [a]
sort ([(Word32, Word32)] -> [(Word32, Word32)])
-> [(Word32, Word32)] -> [(Word32, Word32)]
forall a b. (a -> b) -> a -> b
$ ((Word32, Word32) -> Bool)
-> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0) (Word32 -> Bool)
-> ((Word32, Word32) -> Word32) -> (Word32, Word32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32, Word32) -> Word32
forall a b. (a, b) -> a
fst) [(Word32, Word32)]
lcs of
                     (Tree
tree, []) -> Tree -> InfM Word32
get_code Tree
tree
                     (Tree, [(Word32, Word32)])
_          -> String -> InfM Word32
forall a. HasCallStack => String -> a
error (String -> InfM Word32) -> String -> InfM Word32
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) = Word32 -> InfM Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
w
get_code Tree
Null = String -> InfM Word32
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 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
l = (Word32 -> Tree
Leaf Word32
c, [(Word32, Word32)]
lcs')
 | Word32
i Word32 -> Word32 -> Bool
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
iWord32 -> Word32 -> Word32
forall 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
iWord32 -> Word32 -> Word32
forall 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 = String -> (Tree, [(Word32, Word32)])
forall a. HasCallStack => String -> a
error String
"make_tree: can't happen"