[Haskell-cafe] Bit streams programs in Haskell

[Chris Kuklewicz]

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
-------------- next part --------------
--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)))