{-# 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  : provisional
   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           Control.Applicative
import           Control.Monad
import           Data.Array
import qualified Data.Char
import           Data.List
import           Data.Maybe

import           Data.Bits
import           Data.Word

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 s :: 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 l :: [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 b :: [Bit]
b = let (this :: [Bit]
this, next :: [Bit]
next) = Int -> [Bit] -> ([Bit], [Bit])
forall a. Int -> [a] -> ([a], [a])
splitAt 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 = (\x :: 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 bs :: [Bit]
bs = String -> String -> String
showString (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ "'" 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]
++ "'"

show_b :: Bit -> Char
show_b :: Bit -> Char
show_b (Bit True)  = '1'
show_b (Bit False) = '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 n :: Word8
n = (Int -> Bit) -> [Int] -> [Bit]
forall a b. (a -> b) -> [a] -> [b]
map (\i :: Int
i -> Bool -> Bit
Bit (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
i)) [0..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 b :: Bool
b) i :: Word32
i -> 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 1 else 0)) 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 v :: State -> (a, State)
v >>= :: InfM a -> (a -> InfM b) -> InfM b
>>= f :: 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
$ \s :: State
s -> let (x :: a
x, s' :: State
s') = State -> (a, State)
v State
s
                                    InfM y :: State -> (b, State)
y = a -> InfM b
f a
x
                                in State -> (b, State)
y State
s'
 -- return :: a -> InfM a
    return :: a -> InfM a
return x :: 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
$ \s :: State
s -> (a
x, State
s)

instance Applicative InfM where
    pure :: a -> InfM a
pure = a -> InfM a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: 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 :: (a -> b) -> InfM a -> InfM b
fmap f :: a -> b
f (InfM g :: 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
$ \s :: State
s ->
        case State -> (a, State)
g State
s of ~(a :: a
a, s' :: State
s') -> (a -> b
f a
a, State
s')

set_bits :: [Bit] -> InfM ()
set_bits :: [Bit] -> InfM ()
set_bits bs :: [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 0 ((Word32, Word32) -> [(Word32, Word32)] -> Array Word32 Word32
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (0, 32767) []) 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
$ \s :: State
s -> ((), State
s { bits :: [Bit]
bits = Word32 -> [Bit] -> [Bit]
forall i a. Integral i => i -> [a] -> [a]
genericDrop ((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` 8) (State -> [Bit]
bits State
s),
                         offset :: Word32
offset = 0 })

get_bits :: Word32 -> InfM [Bit]
get_bits :: Word32 -> InfM [Bit]
get_bits n :: 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
$ \s :: 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
                              (ys :: [Bit]
ys, zs :: [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` 8 } )
    where need :: a -> [a] -> ([a], [a])
need 0 xs :: [a]
xs     = ([], [a]
xs)
          need _ []     = String -> ([a], [a])
forall a. HasCallStack => String -> a
error "get_bits: Don't have enough!"
          need i :: a
i (x :: a
x:xs :: [a]
xs) = let (ys :: [a]
ys, zs :: [a]
zs) = a -> [a] -> ([a], [a])
need (a
ia -> a -> a
forall a. Num 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 :: InfM a -> (a, [Bit])
extract_InfM (InfM f :: State -> (a, State)
f) = let (x :: a
x, s :: 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 w :: 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
$ \s :: 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
+ 1 })

repeat_w32s :: Word32 -> Word32 -> InfM [Word32]
repeat_w32s :: Word32 -> Word32 -> InfM Output
repeat_w32s len :: Word32
len dist :: 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
$ \s :: 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` 32768..32767] Output -> Output -> Output
forall a. [a] -> [a] -> [a]
++ [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` 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` 32768 })

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

get_word32s :: Word32 -> Word32 -> InfM [Word32]
get_word32s :: Word32 -> Word32 -> InfM Output
get_word32s _ 0 = Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return []
get_word32s b :: Word32
b n :: 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
-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 i :: 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 1
             case [Bit]
res of
                 [x :: Bit
x] -> Bit -> InfM Bit
forall (m :: * -> *) a. Monad m => a -> m a
return Bit
x
                 _   -> String -> InfM Bit
forall a. HasCallStack => String -> a
error (String -> InfM Bit) -> String -> InfM Bit
forall a b. (a -> b) -> a -> b
$ "get_bit: expected exactly one bit"

{-
\section{Inflate itself}

The hardcore stuff!

-}
inflate :: [Int] -> (Output, [Bit])
inflate :: [Int] -> (Output, [Bit])
inflate is :: [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 True = Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return []
inflate_blocks False
     = do [Bit]
res <- Word32 -> InfM [Bit]
get_bits 3
          case [Bit]
res of
              [Bit is_last :: Bool
is_last, Bit t1 :: Bool
t1, Bit t2 :: Bool
t2] ->
                  case (Bool
t1, Bool
t2) of
                      (False, False) ->
                          do InfM ()
align_8_bits
                             Word32
len <- Word32 -> InfM Word32
get_w32 16
                             Word32
nlen <- Word32 -> InfM Word32
get_w32 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
== 2Word32 -> Int -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^(32 :: Int) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- 1)
                                (InfM () -> InfM ()) -> InfM () -> InfM ()
forall a b. (a -> b) -> a -> b
$ String -> InfM ()
forall a. HasCallStack => String -> a
error "inflate_blocks: Mismatched lengths"
                             Output
ws <- Word32 -> Word32 -> InfM Output
get_word32s 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
                      (True, False) ->
                          Bool -> Tables -> InfM Output
inflate_codes Bool
is_last Tables
inflate_trees_fixed
                      (False, True) ->
                          do Tables
tables <- InfM Tables
inflate_tables
                             Bool -> Tables -> InfM Output
inflate_codes Bool
is_last Tables
tables
                      (True, True) ->
                          String -> InfM Output
forall a. HasCallStack => String -> a
error ("inflate_blocks: case 11 reserved")
              _ -> String -> InfM Output
forall a. HasCallStack => String -> a
error ("inflate_blocks: expected 3 bits")

inflate_tables :: InfM Tables
inflate_tables :: InfM Tables
inflate_tables
 = do Word32
hlit <- Word32 -> InfM Word32
get_w32 5
      Word32
hdist <- Word32 -> InfM Word32
get_w32 5
      Word32
hclen <- Word32 -> InfM Word32
get_w32 4
      [Bit]
llc_bs <- Word32 -> InfM [Bit]
get_bits ((Word32
hclen Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ 4) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* 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)
                        [16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,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
                                                (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 "inflate_tables dummy")
      let (lit_lengths :: Output
lit_lengths, dist_lengths :: Output
dist_lengths) = Word32 -> Output -> (Output, Output)
forall i a. Integral i => i -> [a] -> ([a], [a])
genericSplitAt (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 [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 [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 :: [a] -> [[a]]
triple (a :: a
a:b :: a
b:c :: a
c:xs :: [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 _          = String -> [[a]]
forall a. HasCallStack => String -> a
error "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 _ i :: Word32
i _ | Word32
i Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> InfM Output
forall a. HasCallStack => String -> a
error "make_lit_dist_lengths i < 0"
make_lit_dist_lengths _ 0 _ = Output -> InfM Output
forall (m :: * -> *) a. Monad m => a -> m a
return []
make_lit_dist_lengths tab :: InfM Word32
tab i :: Word32
i last_thing :: Word32
last_thing
 = do Word32
c <- InfM Word32
tab
      (ls :: Output
ls, i' :: Word32
i', last_thing' :: 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 c :: Word32
c i :: Word32
i _ | Word32
i Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 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
- 1, Word32
i)
meta_code c :: Word32
c 16 last_thing :: Word32
last_thing
                 = do [Bit]
xs <- Word32 -> InfM [Bit]
get_bits 2
                      let l :: Word32
l = 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 c :: Word32
c 17 _ = do [Bit]
xs <- Word32 -> InfM [Bit]
get_bits 3
                      let l :: Word32
l = 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 0, Word32
c Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
l, 0)
meta_code c :: Word32
c 18 _ = do [Bit]
xs <- Word32 -> InfM [Bit]
get_bits 7
                      let l :: Word32
l = 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 0, Word32
c Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
l, 0)
meta_code _ i :: Word32
i _ = 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
$ "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 seen_last :: Bool
seen_last tabs :: Tables
tabs@(tab_litlen :: InfM Word32
tab_litlen, tab_dist :: 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
== 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
< 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
                                           Nothing -> String -> InfM Output
forall a. HasCallStack => String -> a
error "do_code_litlen"
                                           Just (base :: Word32
base, num_bits :: 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 [257..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 3 [(Int, Word32)]
litlen_counts [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a] -> [a]
++ [(258, 0)]
    where litlen_counts :: [(Int, Word32)]
litlen_counts = [(8,0),(4,1),(4,2),(4,3),(4,4),(4,5)]

dist_code :: Table -> InfM Dist
dist_code :: InfM Word32 -> InfM Word32
dist_code tab :: 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
          Nothing -> String -> InfM Word32
forall a. HasCallStack => String -> a
error "dist_code"
          Just (base :: Word32
base, num_bits :: 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 [0..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 1 [(Int, Word32)]
dist_counts
    where dist_counts :: [(Int, Word32)]
dist_counts = (4,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 ((,) 2) [1..13]

mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
mk_bases base :: Word32
base counts :: [(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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 current :: a
current bs :: b
bs = (a
current a -> a -> a
forall a. Num 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
$ [(8, Word32
c) | Word32
c <- [0..143]]
                                 [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a] -> [a]
++ [(9, Word32
c) | Word32
c <- [144..255]]
                                 [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a] -> [a]
++ [(7, Word32
c) | Word32
c <- [256..279]]
                                 [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. [a] -> [a] -> [a]
++ [(8, Word32
c) | Word32
c <- [280..287]],
                       [(Word32, Word32)] -> InfM Word32
make_table [(5, Word32
c) | Word32
c <- [0..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 lcs :: [(Word32, Word32)]
lcs = case Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree 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
/= 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, []) -> Tree -> InfM Word32
get_code Tree
tree
                     _          -> String -> InfM Word32
forall a. HasCallStack => String -> a
error (String -> InfM Word32) -> String -> InfM Word32
forall a b. (a -> b) -> a -> b
$ "make_table: Left-over lcs from"

get_code :: Tree -> InfM Code
get_code :: Tree -> InfM Word32
get_code (Branch zero_tree :: Tree
zero_tree one_tree :: Tree
one_tree)
 = do Bit b :: 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 w :: Word32
w) = Word32 -> InfM Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
w
get_code Null = String -> InfM Word32
forall a. HasCallStack => String -> a
error "get_code Null"

make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)])
make_tree :: Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree _ [] = (Tree
Null, [])
make_tree i :: Word32
i lcs :: [(Word32, Word32)]
lcs@((l :: Word32
l, c :: Word32
c):lcs' :: [(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 (zero_tree :: Tree
zero_tree, lcs_z :: [(Word32, Word32)]
lcs_z) = Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree (Word32
iWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1) [(Word32, Word32)]
lcs
               (one_tree :: Tree
one_tree, lcs_o :: [(Word32, Word32)]
lcs_o) = Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
make_tree (Word32
iWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+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 "make_tree: can't happen"