[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:49:33 UTC 2010
The following commit has been merged in the master branch:
commit c8c7e9325f29a678e226158ddaf2adabc7d0412e
Author: John Goerzen <jgoerzen at complete.org>
Date: Sat Dec 4 03:48:08 2004 +0100
Import Inflate
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.7--patch-15)
diff --git a/ChangeLog b/ChangeLog
index 451a392..ea5388f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,21 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
#
+2004-12-03 20:48:08 GMT John Goerzen <jgoerzen at complete.org> patch-15
+
+ Summary:
+ Import Inflate
+ Revision:
+ missingh--head--0.7--patch-15
+
+
+ new files:
+ libsrc/MissingH/Compression/Inflate.hs
+
+ modified files:
+ ChangeLog Setup.description
+
+
2004-12-03 20:41:57 GMT John Goerzen <jgoerzen at complete.org> patch-14
Summary:
diff --git a/Setup.description b/Setup.description
index b2289d0..98ec193 100644
--- a/Setup.description
+++ b/Setup.description
@@ -26,6 +26,8 @@ Modules: MissingH.IO, MissingH.IO.Binary, MissingH.List,
MissingH.ConfigParser.Parser,
MissingH.Printf, MissingH.Printf.Types, MissingH.Printf.Printer,
MissingH.Bits,
+ MissingH.Checksum.CRC32,
+ MissingH.Compression.Inflate,
MissingH.Wash.Mail.Email,
MissingH.Wash.Mail.EmailConfig,
MissingH.Wash.Mail.HeaderField,
diff --git a/libsrc/MissingH/Compression/Inflate.hs b/libsrc/MissingH/Compression/Inflate.hs
new file mode 100644
index 0000000..aabf14c
--- /dev/null
+++ b/libsrc/MissingH/Compression/Inflate.hs
@@ -0,0 +1,314 @@
+-- arch-tag: Inflate implementation for Haskell
+
+{-
+Inflate implementation for Haskell
+
+Copyright 2004 Ian Lynagh <igloo at earth.li>
+Licence: 3 clause BSD.
+
+\section{Inflate}
+
+This module provides a Haskell implementation of the inflate function,
+as described by RFC 1951.
+
+-}
+module Inflate (inflate) where
+
+import Array
+import List
+import Maybe
+import Monad
+
+import Bits
+import Word
+
+{-
+\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 Eq
+instance Show Bit where
+ show = (\x -> [x]) . show_b
+ showList bs = showString $ "'" ++ map show_b bs ++ "'"
+
+show_b :: Bit -> Char
+show_b (Bit True) = '1'
+show_b (Bit False) = '0'
+
+int_to_bits :: Int -> [Bit]
+int_to_bits = word8_to_bits . fromIntegral
+
+word8_to_bits :: Word8 -> [Bit]
+word8_to_bits n = map (\i -> Bit (testBit n i)) [0..7]
+
+bits_to_word32 :: [Bit] -> Word32
+bits_to_word32 = foldr (\(Bit b) i -> 2 * i + (if b then 1 else 0)) 0
+
+{-
+
+\section{Monad}
+
+offset is rarely used, so make it strict to avoid building huge closures.
+
+-}
+data State = State { bits :: [Bit], -- remaining input bits
+ offset :: !Word32, -- num bits consumed mod 8
+ history :: Array Word32 Word32, -- last 32768 output words
+ 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 >>= f = InfM $ \s -> let (x, s') = v s
+ InfM y = f x
+ in y s'
+ -- return :: a -> InfM a
+ return x = InfM $ \s -> (x, s)
+
+set_bits :: [Bit] -> InfM ()
+set_bits bs = InfM $ const ((), State bs 0 (array (0, 32767) []) 0)
+
+{-
+no_bits :: InfM Bool
+no_bits = InfM $ \s -> (null (bits s), s)
+-}
+
+align_8_bits :: InfM ()
+align_8_bits
+ = InfM $ \s -> ((), s { bits = genericDrop ((8 - offset s) `mod` 8) (bits s),
+ offset = 0 })
+
+get_bits :: Word32 -> InfM [Bit]
+get_bits n = InfM $ \s -> case need n (bits s) of
+ (ys, zs) ->
+ (ys, s { bits = zs,
+ offset = (n + offset s) `mod` 8 } )
+ where need 0 xs = ([], xs)
+ need _ [] = error "get_bits: Don't have enough!"
+ need (i+1) (x:xs) = let (ys, zs) = need i xs in (x:ys, zs)
+
+extract_InfM :: InfM a -> (a, [Bit])
+extract_InfM (InfM f) = let (x, s) = f undefined in (x, bits s)
+
+output_w32 :: Word32 -> InfM ()
+output_w32 w = InfM $ \s -> let l = loc s
+ in ((), s { history = history s // [(l, w)],
+ loc = l + 1 })
+
+repeat_w32s :: Word32 -> Word32 -> InfM [Word32]
+repeat_w32s len dist
+ = InfM $ \s -> let l = loc s
+ h = history s
+ new = map (h!) $ genericTake dist ([(l - dist) `mod` 32768..32767] ++ [0..])
+ new_bit = genericTake len (cycle new)
+ h' = h // zip (map (`mod` 32768) [l..]) new_bit
+ in (new_bit, s { history = h', loc = (l + len) `mod` 32768 })
+
+-----------------------------------
+
+get_word32s :: Word32 -> Word32 -> InfM [Word32]
+get_word32s _ 0 = return []
+get_word32s b n = do w <- get_w32 b
+ ws <- get_word32s b (n-1)
+ return (w:ws)
+
+get_w32 :: Word32 -> InfM Word32
+get_w32 i = do bs <- get_bits i
+ return (bits_to_word32 bs)
+
+get_bit :: InfM Bit
+get_bit = do [x] <- get_bits 1
+ return x
+
+{-
+\section{Inflate itself}
+
+The hardcore stuff!
+
+-}
+inflate :: [Int] -> (Output, [Bit])
+inflate is = extract_InfM $ do set_bits $ concatMap int_to_bits is
+ inflate_blocks False
+
+-- Bool is true if we have seen the "last" block
+inflate_blocks :: Bool -> InfM Output
+inflate_blocks True = return []
+inflate_blocks False
+ = do [Bit is_last, Bit t1, Bit t2] <- get_bits 3
+ case (t1, t2) of
+ (False, False) ->
+ do align_8_bits
+ len <- get_w32 16
+ nlen <- get_w32 16
+ unless (len + nlen == 2^(32 :: Int) - 1)
+ $ error "inflate_blocks: Mismatched lengths"
+ ws <- get_word32s 8 len
+ mapM_ output_w32 ws
+ return ws
+ (True, False) ->
+ inflate_codes is_last inflate_trees_fixed
+ (False, True) ->
+ do tables <- inflate_tables
+ inflate_codes is_last tables
+ (True, True) ->
+ error ("inflate_blocks: case 11 reserved")
+
+inflate_tables :: InfM Tables
+inflate_tables
+ = do hlit <- get_w32 5
+ hdist <- get_w32 5
+ hclen <- get_w32 4
+ llc_bs <- get_bits ((hclen + 4) * 3)
+ let llc_bs' = zip (map bits_to_word32 $ triple llc_bs)
+ [16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15]
+ tab = make_table llc_bs'
+ lit_dist_lengths <- make_lit_dist_lengths tab
+ (258 + hlit + hdist)
+ (error "inflate_tables dummy")
+ let (lit_lengths, dist_lengths) = genericSplitAt (257 + hlit)
+ lit_dist_lengths
+ lit_table = make_table (zip lit_lengths [0..])
+ dist_table = make_table (zip dist_lengths [0..])
+ return (lit_table, dist_table)
+
+triple :: [a] -> [[a]]
+triple (a:b:c:xs) = [a,b,c]:triple xs
+triple [] = []
+triple _ = error "triple: can't happen"
+
+make_lit_dist_lengths :: Table -> Word32 -> Word32 -> InfM [Word32]
+make_lit_dist_lengths _ i _ | i < 0 = error "make_lit_dist_lengths i < 0"
+make_lit_dist_lengths _ 0 _ = return []
+make_lit_dist_lengths tab i last_thing
+ = do c <- tab
+ (ls, i', last_thing') <- meta_code i c last_thing
+ ws <- make_lit_dist_lengths tab i' last_thing'
+ return (ls ++ ws)
+
+meta_code :: Word32 -> Code -> Word32 -> InfM ([Word32], Word32, Word32)
+meta_code c i _ | i < 16 = return ([i], c - 1, i)
+meta_code c 16 last_thing
+ = do xs <- get_bits 2
+ let l = 3 + bits_to_word32 xs
+ return (genericReplicate l last_thing, c - l, last_thing)
+meta_code c 17 _ = do xs <- get_bits 3
+ let l = 3 + bits_to_word32 xs
+ return (genericReplicate l 0, c - l, 0)
+meta_code c 18 _ = do xs <- get_bits 7
+ let l = 11 + bits_to_word32 xs
+ return (genericReplicate l 0, c - l, 0)
+meta_code _ i _ = error $ "meta_code: " ++ show i
+
+inflate_codes :: Bool -> Tables -> InfM Output
+inflate_codes seen_last tabs@(tab_litlen, tab_dist)
+ =
+ {- do done <- no_bits
+ if done
+ then return [] -- XXX Is this right?
+ else -}
+ do i <- tab_litlen;
+ if i == 256
+ then inflate_blocks seen_last
+ else
+ do pref <- if i < 256
+ then do output_w32 i
+ return [i]
+ else case lookup i litlens of
+ Nothing -> error "do_code_litlen"
+ Just (base, num_bits) ->
+ do extra <- get_w32 num_bits
+ let l = base + extra
+ dist <- dist_code tab_dist
+ repeat_w32s l dist
+ o <- inflate_codes seen_last tabs
+ return (pref ++ o)
+
+litlens :: [(Code, (LitLen, Word32))]
+litlens = zip [257..285] $ mk_bases 3 litlen_counts
+ where litlen_counts = [(8,0),(4,1),(4,2),(4,3),(4,4),(4,5),(1,0)]
+
+dist_code :: Table -> InfM Dist
+dist_code tab
+ = do code <- tab
+ case lookup code dists of
+ Nothing -> error "dist_code"
+ Just (base, num_bits) -> do extra <- get_w32 num_bits
+ return (base + extra)
+
+dists :: [(Code, (Dist, Word32))]
+dists = zip [0..29] $ mk_bases 1 dist_counts
+ where dist_counts = (4,0):map ((,) 2) [1..13]
+
+mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
+mk_bases base counts = snd $ mapAccumL next_base base incs
+ where next_base current bs = (current + 2^bs, (current, bs))
+ incs = concat $ map (uncurry replicate) counts
+
+{-
+\section{Fixed tables}
+
+The fixed tables. Not much to say really.
+
+-}
+inflate_trees_fixed :: Tables
+inflate_trees_fixed = (make_table $ [(8, c) | c <- [0..143]]
+ ++ [(9, c) | c <- [144..255]]
+ ++ [(7, c) | c <- [256..279]]
+ ++ [(8, c) | c <- [280..287]],
+ make_table [(5, c) | 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 lcs = case make_tree 0 $ sort $ filter ((/= 0) . fst) lcs of
+ (tree, []) -> get_code tree
+ _ -> error $ "make_table: Left-over lcs from"
+
+get_code :: Tree -> InfM Code
+get_code (Branch zero_tree one_tree)
+ = do Bit b <- get_bit
+ if b then get_code one_tree else get_code zero_tree
+get_code (Leaf w) = return w
+get_code Null = error "get_code Null"
+
+make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)])
+make_tree _ [] = (Null, [])
+make_tree i lcs@((l, c):lcs')
+ | i == l = (Leaf c, lcs')
+ | i < l = let (zero_tree, lcs_z) = make_tree (i+1) lcs
+ (one_tree, lcs_o) = make_tree (i+1) lcs_z
+ in (Branch zero_tree one_tree, lcs_o)
+ | otherwise = error "make_tree: can't happen"
+
+
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list