Re: [Haskell-cafe] Bit streams programs in Haskell

22 Mar 2006


      Per Gustafsson wrote:
...
Haskell gurus,
I am not a guru, but I'll clean up some of this.
...
Our experience in writing efficient (and beautiful) Haskell programs is
close to (if not below) zero. Also, perhaps our mind might be suffering
from severe case of strictness and might be completely unable to `think
lazily'. So, we request your help in noticing obvious NO-NOs and stupid
mistakes that we might have made. We even welcome completely different
Haskell programs provided they adhere to the constraint mentioned
above -- no mutation.
Best regards,
Kostis Sagonas and Per Gustafsson
I can't test this, but I have attached a new version of huffman.hs that may
perform a bit better.  I don't know if all the changes I made helped instead of
hurt.  I doubt it was sped up by much.

-- 
Chris Kuklewicz

--module Huffman where
import System.IO
import Data.Bits
import Data.Word
import Data.Array.IO
import Data.Array.Unboxed hiding ((!))
import Data.Array.Base(unsafeAt)
import System(getArgs)
import System.CPUTime(getCPUTime)
import Foreign.Marshal.Array (withArrayLen)
import Control.Exception(bracket)

data HuffTree  = Leaf Word8 | Branch HuffTree HuffTree 

type A = UArray Int Word8

(!) = unsafeAt

iter = 10

{-- the do_iter function repeats a function iter times
 it is not pretty, but it is hard to convince haskell to 
 repeat a computation many times --}

do_iter 1 func input = let x = func input
                       in return x
do_iter k func input =  let x = func input
                        in seq (last x) (do_iter (k-1) func input)

main =
    do 
     [arg] <- getArgs
     handle <- openFile arg ReadMode
     let size = 2000000
     arrM <- newArray (0,pred size) 0 :: IO (IOUArray Int Word8)
     read_size <- hGetArray handle arrM size
     -- convert to immutable array
     arr <- unsafeFreeze arrM :: IO (UArray Int Word8)
     t0 <- getCPUTime
     res <- do_iter iter huff arr
     t1 <- getCPUTime
     putStr ((show ((fromInteger(t1-t0)::Float)/(1000000000000.0::Float))))
     bracket (openBinaryFile (arg++".haskell") WriteMode)
             hClose
             (\file -> withArrayLen res (flip (hPutBuf file)))

huff:: A -> [Word8]
huff arr  = let (hufftree, newindex) = build_tree 4 arr 
                limit = get_32bit_int newindex arr
            in huffdecode ((newindex+4)*8) arr hufftree (limit+((newindex+4)*8))

huffdecode :: Int -> A -> HuffTree -> Int -> [Word8]
huffdecode index arr tree limit = helper index tree
  where helper index (Leaf charval) | index == limit = []
                                    | otherwise      = charval : helper index tree 
        helper index (Branch left right) | index `seq` True = 
            helper (index+1) (if get_bit arr index then right else left)

get_bit :: A -> Int -> Bool
{-# INLINE get_bit #-}
get_bit arr bitoffset =
    let byte = arr ! (shiftR bitoffset 3)
    in testBit (shiftL byte (bitoffset .&. 7)) 7

build_tree :: Int->A->(HuffTree,Int)
build_tree index arr =
    let size = get_16_bitint index arr
        build_tree_2 index limit
            | (limit-index) == 1 = Leaf (arr ! index)
            | otherwise          = let left_size = get_16_bitint index arr
                                   in Branch (build_tree_2 (index+2)           (index+2+left_size))
                                             (build_tree_2 (index+4+left_size) limit              )
    in (build_tree_2 (index+2) (index+2+size)
       ,(index+2+size))

get_16_bitint :: Int -> A -> Int
{-# INLINE get_16_bitint #-}
get_16_bitint index arr =
    (shiftL (fromIntegral (arr ! index)) 8) .|. 
    (fromIntegral (arr ! (index+1)))

get_32bit_int :: Int -> A -> Int
{-# INLINE get_32bit_int #-}
get_32bit_int index arr =
    (shiftL (fromIntegral (arr ! index)) 24) .|. 
    (shiftL (fromIntegral (arr ! (index+1))) 16) .|.
    (shiftL (fromIntegral (arr ! (index+2))) 8) .|. 
    (fromIntegral (arr ! (index+3)))