{-# LANGUAGE MultiWayIf #-}

module Codec.Compression.Zlib.Deflate (
  inflate,
  computeCodeValues,
) where

import Codec.Compression.Zlib.HuffmanTree (
  HuffmanTree,
  createHuffmanTree,
 )
import Codec.Compression.Zlib.Monad (
  DecompressionError (..),
  DeflateM,
  advanceToByte,
  emitBlock,
  emitByte,
  emitPastChunk,
  finalAdler,
  finalize,
  moveWindow,
  nextBits,
  nextBlock,
  nextCode,
  nextWord16,
  nextWord32,
  raise,
 )
import Control.Monad (replicateM, unless)
import Data.Array (Array, array, (!))
import Data.Bits (complement, shiftL)
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as Map
import Data.List (sortBy)
import Data.Word (Word8)
import Numeric (showHex)

inflate :: DeflateM s ()
inflate :: DeflateM s ()
inflate = do
  HuffmanTree Int
fixedLit <- DeflateM s (HuffmanTree Int)
forall s. DeflateM s (HuffmanTree Int)
buildFixedLitTree
  HuffmanTree Int
fixedDist <- DeflateM s (HuffmanTree Int)
forall s. DeflateM s (HuffmanTree Int)
buildFixedDistanceTree
  HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
forall s. HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
go HuffmanTree Int
fixedLit HuffmanTree Int
fixedDist
 where
  go :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
go HuffmanTree Int
fixedLit HuffmanTree Int
fixedDist = do
    Bool
isFinal <- HuffmanTree Int -> HuffmanTree Int -> DeflateM s Bool
forall s. HuffmanTree Int -> HuffmanTree Int -> DeflateM s Bool
inflateBlock HuffmanTree Int
fixedLit HuffmanTree Int
fixedDist
    DeflateM s ()
forall s. DeflateM s ()
moveWindow
    if Bool
isFinal
      then DeflateM s ()
forall s. DeflateM s ()
checkChecksum DeflateM s () -> DeflateM s () -> DeflateM s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DeflateM s ()
forall s. DeflateM s ()
finalize
      else HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
go HuffmanTree Int
fixedLit HuffmanTree Int
fixedDist
  --
  checkChecksum :: DeflateM s ()
checkChecksum = do
    DeflateM s ()
forall s. DeflateM s ()
advanceToByte
    Word32
ourAdler <- DeflateM s Word32
forall s. DeflateM s Word32
finalAdler
    Word32
theirAdler <- DeflateM s Word32
forall s. DeflateM s Word32
nextWord32
    Bool -> DeflateM s () -> DeflateM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
theirAdler Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
ourAdler) (DeflateM s () -> DeflateM s ()) -> DeflateM s () -> DeflateM s ()
forall a b. (a -> b) -> a -> b
$
      DecompressionError -> DeflateM s ()
forall s a. DecompressionError -> DeflateM s a
raise
        ( String -> DecompressionError
ChecksumError
            ( String
"checksum mismatch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Word32
theirAdler String
""
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" != "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Word32
ourAdler String
""
            )
        )

inflateBlock :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s Bool
inflateBlock :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s Bool
inflateBlock HuffmanTree Int
fixedLitTree HuffmanTree Int
fixedDistanceTree = do
  Bool
bfinal <- (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8
1 :: Word8)) (Word8 -> Bool) -> DeflateM s Word8 -> DeflateM s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Word8
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1
  Word8
btype <- Int -> DeflateM s Word8
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2
  case Word8
btype :: Word8 of
    Word8
0 -> do
      -- no compression
      DeflateM s ()
forall s. DeflateM s ()
advanceToByte
      Word16
len <- DeflateM s Word16
forall s. DeflateM s Word16
nextWord16
      Word16
nlen <- DeflateM s Word16
forall s. DeflateM s Word16
nextWord16
      Bool -> DeflateM s () -> DeflateM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16 -> Word16
forall a. Bits a => a -> a
complement Word16
nlen) (DeflateM s () -> DeflateM s ()) -> DeflateM s () -> DeflateM s ()
forall a b. (a -> b) -> a -> b
$
        DecompressionError -> DeflateM s ()
forall s a. DecompressionError -> DeflateM s a
raise (String -> DecompressionError
FormatError String
"Len/nlen mismatch in uncompressed block.")
      ByteString -> DeflateM s ()
forall s. ByteString -> DeflateM s ()
emitBlock (ByteString -> DeflateM s ())
-> DeflateM s ByteString -> DeflateM s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Word16 -> DeflateM s ByteString
forall a s. Integral a => a -> DeflateM s ByteString
nextBlock Word16
len
      Bool -> DeflateM s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bfinal
    Word8
1 -> do
      -- compressed with fixed Huffman codes
      HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
forall s. HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
runInflate HuffmanTree Int
fixedLitTree HuffmanTree Int
fixedDistanceTree
      Bool -> DeflateM s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bfinal
    Word8
2 -> do
      -- compressed with dynamic Huffman codes
      Int
hlit <- (Int
257 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5
      Int
hdist <- (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5
      Int
hclen <- (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4
      [Int]
codeLens <- Int -> DeflateM s Int -> DeflateM s [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
hclen (Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
      let codeLens' :: [(Int, Int)]
codeLens' = [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
codeLengthOrder [Int]
codeLens
      HuffmanTree Int
codeTree <- [(Int, Int)] -> DeflateM s (HuffmanTree Int)
forall s. [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree [(Int, Int)]
codeLens'
      IntMap Int
lens <- HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
forall s.
HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
getCodeLengths HuffmanTree Int
codeTree Int
0 (Int
hlit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hdist) Int
0 IntMap Int
forall a. IntMap a
Map.empty
      -- We do this as a big chunk and then split it up because the spec
      -- allows repeat codes to cross the hlit / hdist boundary. So now we
      -- need to pull off the hdist items.
      let (IntMap Int
litlens, IntMap Int
offdistlens) =
            (Int -> Int -> Bool) -> IntMap Int -> (IntMap Int, IntMap Int)
forall a. (Int -> a -> Bool) -> IntMap a -> (IntMap a, IntMap a)
Map.partitionWithKey (\Int
k Int
_ -> Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
hlit) IntMap Int
lens
          distlens :: IntMap Int
distlens = (Int -> Int) -> IntMap Int -> IntMap Int
forall a. (Int -> Int) -> IntMap a -> IntMap a
Map.mapKeys (\Int
k -> Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hlit) IntMap Int
offdistlens
      HuffmanTree Int
litTree <- [(Int, Int)] -> DeflateM s (HuffmanTree Int)
forall s. [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree (IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
Map.toList IntMap Int
litlens)
      HuffmanTree Int
distTree <- [(Int, Int)] -> DeflateM s (HuffmanTree Int)
forall s. [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree (IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
Map.toList IntMap Int
distlens)
      HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
forall s. HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
runInflate HuffmanTree Int
litTree HuffmanTree Int
distTree
      Bool -> DeflateM s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bfinal
    Word8
_ ->
      -- reserved / error
      DecompressionError -> DeflateM s Bool
forall s a. DecompressionError -> DeflateM s a
raise (String -> DecompressionError
FormatError (String
"Unacceptable BTYPE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
btype))
 where
  runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
  runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
runInflate HuffmanTree Int
litTree HuffmanTree Int
distTree = do
    Int
code <- HuffmanTree Int -> DeflateM s Int
forall a s. Show a => HuffmanTree a -> DeflateM s a
nextCode HuffmanTree Int
litTree
    case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
code Int
256 of
      Ordering
LT -> do
        Word8 -> DeflateM s ()
forall s. Word8 -> DeflateM s ()
emitByte (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code)
        HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
forall s. HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
runInflate HuffmanTree Int
litTree HuffmanTree Int
distTree
      Ordering
EQ -> () -> DeflateM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Ordering
GT -> do
        Int64
len <- Int -> DeflateM s Int64
forall s. Int -> DeflateM s Int64
getLength Int
code
        Int
distCode <- HuffmanTree Int -> DeflateM s Int
forall a s. Show a => HuffmanTree a -> DeflateM s a
nextCode HuffmanTree Int
distTree
        Int
dist <- Int -> DeflateM s Int
forall s. Int -> DeflateM s Int
getDistance Int
distCode
        Int -> Int -> DeflateM s ()
forall s. Int -> Int -> DeflateM s ()
emitPastChunk Int
dist (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)
        DeflateM s ()
forall s. DeflateM s ()
moveWindow
        HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
forall s. HuffmanTree Int -> HuffmanTree Int -> DeflateM s ()
runInflate HuffmanTree Int
litTree HuffmanTree Int
distTree

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

getCodeLengths ::
  HuffmanTree Int ->
  Int ->
  Int ->
  Int ->
  IntMap Int ->
  DeflateM s (IntMap Int)
getCodeLengths :: HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
getCodeLengths HuffmanTree Int
tree Int
n Int
maxl Int
prev IntMap Int
acc
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxl = IntMap Int -> DeflateM s (IntMap Int)
forall (m :: * -> *) a. Monad m => a -> m a
return IntMap Int
acc
  | Bool
otherwise = do
    Int
code <- HuffmanTree Int -> DeflateM s Int
forall a s. Show a => HuffmanTree a -> DeflateM s a
nextCode HuffmanTree Int
tree
    if
        | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
15 ->
          HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
forall s.
HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
getCodeLengths HuffmanTree Int
tree (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
maxl Int
code (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
n Int
code IntMap Int
acc)
        | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 -> do
          -- copy the previous code length 3 - 6 times
          Int
num <- (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2
          HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
forall s.
HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
getCodeLengths HuffmanTree Int
tree (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
num) Int
maxl Int
prev (Int -> Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> Int -> a -> IntMap a -> IntMap a
addNTimes Int
n Int
num Int
prev IntMap Int
acc)
        | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
17 -> do
          -- repeat a code length of 0 for 3 - 10 times
          Int
num <- (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3
          HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
forall s.
HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
getCodeLengths HuffmanTree Int
tree (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
num) Int
maxl Int
0 (Int -> Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> Int -> a -> IntMap a -> IntMap a
addNTimes Int
n Int
num Int
0 IntMap Int
acc)
        | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
18 -> do
          -- repeat a code length of 0 for 11 - 138 times
          Int
num <- (Int
11 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
7
          HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
forall s.
HuffmanTree Int
-> Int -> Int -> Int -> IntMap Int -> DeflateM s (IntMap Int)
getCodeLengths HuffmanTree Int
tree (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
num) Int
maxl Int
0 (Int -> Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> Int -> a -> IntMap a -> IntMap a
addNTimes Int
n Int
num Int
0 IntMap Int
acc)
        | Bool
otherwise ->
          DecompressionError -> DeflateM s (IntMap Int)
forall s a. DecompressionError -> DeflateM s a
raise (String -> DecompressionError
DecompressionError (String
"Unexpected code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
code))
 where
  addNTimes :: Int -> Int -> a -> IntMap a -> IntMap a
addNTimes Int
idx Int
count a
val IntMap a
old =
    let idxs :: [Int]
idxs = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
count [Int
idx ..]
        vals :: [a]
vals = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
count a
val
     in IntMap a -> IntMap a -> IntMap a
forall a. IntMap a -> IntMap a -> IntMap a
Map.union IntMap a
old ([(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
Map.fromList ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
idxs [a]
vals))

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

getLength :: Int -> DeflateM s Int64
getLength :: Int -> DeflateM s Int64
getLength Int
c = Array Int (DeflateM s Int64)
forall s. Array Int (DeflateM s Int64)
lengthArray Array Int (DeflateM s Int64) -> Int -> DeflateM s Int64
forall i e. Ix i => Array i e -> i -> e
! Int
c
{-# INLINE getLength #-}

lengthArray :: Array Int (DeflateM s Int64)
lengthArray :: Array Int (DeflateM s Int64)
lengthArray =
  (Int, Int)
-> [(Int, DeflateM s Int64)] -> Array Int (DeflateM s Int64)
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array
    (Int
257, Int
285)
    [ (Int
257, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
3)
    , (Int
258, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
4)
    , (Int
259, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
5)
    , (Int
260, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
6)
    , (Int
261, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
7)
    , (Int
262, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
8)
    , (Int
263, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
9)
    , (Int
264, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
10)
    , (Int
265, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
11) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1)
    , (Int
266, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
13) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1)
    , (Int
267, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
15) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1)
    , (Int
268, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
17) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1)
    , (Int
269, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
19) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2)
    , (Int
270, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
23) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2)
    , (Int
271, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
27) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2)
    , (Int
272, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
31) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2)
    , (Int
273, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
35) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
    , (Int
274, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
43) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
    , (Int
275, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
51) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
    , (Int
276, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
59) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
    , (Int
277, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
67) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4)
    , (Int
278, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
83) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4)
    , (Int
279, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
99) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4)
    , (Int
280, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
115) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4)
    , (Int
281, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
131) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5)
    , (Int
282, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
163) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5)
    , (Int
283, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
195) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5)
    , (Int
284, (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
227) (Int64 -> Int64) -> DeflateM s Int64 -> DeflateM s Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int64
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5)
    , (Int
285, Int64 -> DeflateM s Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
258)
    ]

getDistance :: Int -> DeflateM s Int
getDistance :: Int -> DeflateM s Int
getDistance Int
c = Array Int (DeflateM s Int)
forall s. Array Int (DeflateM s Int)
distanceArray Array Int (DeflateM s Int) -> Int -> DeflateM s Int
forall i e. Ix i => Array i e -> i -> e
! Int
c
{-# INLINE getDistance #-}

distanceArray :: Array Int (DeflateM s Int)
distanceArray :: Array Int (DeflateM s Int)
distanceArray =
  (Int, Int) -> [(Int, DeflateM s Int)] -> Array Int (DeflateM s Int)
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array
    (Int
0, Int
29)
    [ (Int
0, Int -> DeflateM s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1)
    , (Int
1, Int -> DeflateM s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
2)
    , (Int
2, Int -> DeflateM s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
3)
    , (Int
3, Int -> DeflateM s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
4)
    , (Int
4, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1)
    , (Int
5, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
1)
    , (Int
6, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
9) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2)
    , (Int
7, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
13) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
2)
    , (Int
8, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
17) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
    , (Int
9, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
25) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
3)
    , (Int
10, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
33) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4)
    , (Int
11, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
49) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
4)
    , (Int
12, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
65) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5)
    , (Int
13, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
97) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
5)
    , (Int
14, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
129) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
6)
    , (Int
15, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
193) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
6)
    , (Int
16, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
257) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
7)
    , (Int
17, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
385) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
7)
    , (Int
18, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
513) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
8)
    , (Int
19, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
769) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
8)
    , (Int
20, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1025) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
9)
    , (Int
21, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1537) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
9)
    , (Int
22, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2049) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
10)
    , (Int
23, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3073) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
10)
    , (Int
24, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4097) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
11)
    , (Int
25, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6145) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
11)
    , (Int
26, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8193) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
12)
    , (Int
27, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12289) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
12)
    , (Int
28, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16385) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
13)
    , (Int
29, (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
24577) (Int -> Int) -> DeflateM s Int -> DeflateM s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> DeflateM s Int
forall a s. (Num a, Bits a) => Int -> DeflateM s a
nextBits Int
13)
    ]

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

buildFixedLitTree :: DeflateM s (HuffmanTree Int)
buildFixedLitTree :: DeflateM s (HuffmanTree Int)
buildFixedLitTree =
  [(Int, Int)] -> DeflateM s (HuffmanTree Int)
forall s. [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree
    ( [(Int
x, Int
8) | Int
x <- [Int
0 .. Int
143]]
      [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
x, Int
9) | Int
x <- [Int
144 .. Int
255]]
        [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
x, Int
7) | Int
x <- [Int
256 .. Int
279]]
        [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
x, Int
8) | Int
x <- [Int
280 .. Int
287]]
    )

buildFixedDistanceTree :: DeflateM s (HuffmanTree Int)
buildFixedDistanceTree :: DeflateM s (HuffmanTree Int)
buildFixedDistanceTree = [(Int, Int)] -> DeflateM s (HuffmanTree Int)
forall s. [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree [(Int
x, Int
5) | Int
x <- [Int
0 .. Int
31]]

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

computeHuffmanTree :: [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree :: [(Int, Int)] -> DeflateM s (HuffmanTree Int)
computeHuffmanTree [(Int, Int)]
initialData =
  case [(Int, Int, Int)] -> Either String (HuffmanTree Int)
forall a.
Show a =>
[(a, Int, Int)] -> Either String (HuffmanTree a)
createHuffmanTree ([(Int, Int)] -> [(Int, Int, Int)]
computeCodeValues [(Int, Int)]
initialData) of
    Left String
err -> DecompressionError -> DeflateM s (HuffmanTree Int)
forall s a. DecompressionError -> DeflateM s a
raise (String -> DecompressionError
HuffmanTreeError String
err)
    Right HuffmanTree Int
x -> HuffmanTree Int -> DeflateM s (HuffmanTree Int)
forall (m :: * -> *) a. Monad m => a -> m a
return HuffmanTree Int
x

computeCodeValues :: [(Int, Int)] -> [(Int, Int, Int)]
computeCodeValues :: [(Int, Int)] -> [(Int, Int, Int)]
computeCodeValues [(Int, Int)]
vals = (Int -> (Int, Int) -> [(Int, Int, Int)] -> [(Int, Int, Int)])
-> [(Int, Int, Int)] -> IntMap (Int, Int) -> [(Int, Int, Int)]
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
Map.foldrWithKey (\Int
v (Int
l, Int
c) [(Int, Int, Int)]
a -> (Int
v, Int
l, Int
c) (Int, Int, Int) -> [(Int, Int, Int)] -> [(Int, Int, Int)]
forall a. a -> [a] -> [a]
: [(Int, Int, Int)]
a) [] IntMap (Int, Int)
codes
 where
  valsNo0s :: [(Int, Int)]
valsNo0s = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_, Int
b) -> (Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)) [(Int, Int)]
vals
  valsSort :: [(Int, Int)]
valsSort = ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int
a, Int
_) (Int
b, Int
_) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
b) [(Int, Int)]
valsNo0s
  blCount :: IntMap Int
blCount = ((Int, Int) -> IntMap Int -> IntMap Int)
-> IntMap Int -> [(Int, Int)] -> IntMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
_, Int
k) IntMap Int
m -> (Int -> Int -> Int) -> Int -> Int -> IntMap Int -> IntMap Int
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
k Int
1 IntMap Int
m) IntMap Int
forall a. IntMap a
Map.empty [(Int, Int)]
valsNo0s
  nextcode :: IntMap Int
nextcode = Int -> Int -> IntMap Int -> IntMap Int
step2 Int
0 Int
1 (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
0 Int
0 IntMap Int
forall a. IntMap a
Map.empty)
  lenTree :: IntMap Int
lenTree = [(Int, Int)] -> IntMap Int
forall a. [(Int, a)] -> IntMap a
Map.fromList [(Int, Int)]
valsSort
  codeTree :: IntMap Int
codeTree = [Int] -> IntMap Int -> IntMap Int -> IntMap Int
forall a. Num a => [Int] -> IntMap a -> IntMap a -> IntMap a
step3 (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
valsSort) IntMap Int
nextcode IntMap Int
forall a. IntMap a
Map.empty
  maxBits :: Int
maxBits = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd [(Int, Int)]
valsSort)
  codes :: IntMap (Int, Int)
codes = (Int -> Int -> (Int, Int))
-> IntMap Int -> IntMap Int -> IntMap (Int, Int)
forall a b c. (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
Map.intersectionWith (,) IntMap Int
lenTree IntMap Int
codeTree
  --
  step2 :: Int -> Int -> IntMap Int -> IntMap Int
step2 Int
code Int
bits IntMap Int
nc
    | Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBits = IntMap Int
nc
    | Bool
otherwise =
      let prevCount :: Int
prevCount = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
Map.findWithDefault Int
0 (Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) IntMap Int
blCount
          code' :: Int
code' = (Int
code Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
prevCount) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
       in Int -> Int -> IntMap Int -> IntMap Int
step2 Int
code' (Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
bits Int
code' IntMap Int
nc)
  --
  step3 :: [Int] -> IntMap a -> IntMap a -> IntMap a
step3 [] IntMap a
_ IntMap a
ct = IntMap a
ct
  step3 (Int
n : [Int]
rest) IntMap a
nc IntMap a
ct =
    let len :: Int
len = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
Map.findWithDefault Int
0 Int
n IntMap Int
lenTree
        Just a
ncLen = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
Map.lookup Int
len IntMap a
nc
        ct' :: IntMap a
ct' = Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
n a
ncLen IntMap a
ct
        nc' :: IntMap a
nc' = Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
len (a
ncLen a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) IntMap a
nc
     in if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          then [Int] -> IntMap a -> IntMap a -> IntMap a
step3 [Int]
rest IntMap a
nc IntMap a
ct
          else [Int] -> IntMap a -> IntMap a -> IntMap a
step3 [Int]
rest IntMap a
nc' IntMap a
ct'

codeLengthOrder :: [Int]
codeLengthOrder :: [Int]
codeLengthOrder =
  [Int
16, Int
17, Int
18, Int
0, Int
8, Int
7, Int
9, Int
6, Int
10, Int
5, Int
11, Int
4, Int
12, Int
3, Int
13, Int
2, Int
14, Int
1, Int
15]