WriteRoutines.hs 1.98 KB
Newer Older
1 2
{-# LANGUAGE MagicHash #-}

3 4 5
module WriteRoutines (outputCodes)
where

6
--import GlaExts
Ben Gamari's avatar
Ben Gamari committed
7
import GHC.Base        ( Int(..), word2Int#, int2Word#, and#, or#, shiftL#, shiftRL# )
8 9
import Encode (CodeEvent(..))

dnt's avatar
dnt committed
10 11 12
-- Start of code added for ghc
w2i x = word2Int# x
i2w x = int2Word# x
13

dnt's avatar
dnt committed
14 15 16 17 18
intAnd (I# x) (I# y) = I# (w2i (and# (i2w x) (i2w y)))
intOr  (I# x) (I# y) = I# (w2i (or# (i2w x) (i2w y)))
intLsh (I# x) (I# y) = I# (w2i (shiftL# (i2w x) y))
intRsh (I# x) (I# y) = I# (w2i (shiftRL# (i2w x) y))
-- End of code added for ghc
19 20

outputCodes :: [CodeEvent] -> (String, [Int])
21
outputCodes cs = (map (\x -> toEnum (intAnd 255 x)) (fst result), snd result)
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
               where result = output 9 8 0 0 cs       -- assume 9 bit start

output :: Int -> Int -> Int -> Int -> [CodeEvent] -> ([Int], [Int])
output _ _ _ prev [] = ([prev], [1])

output nbits stillToGo r_off prev (NewWordSize : cs)
    = (fst rest, 0 : snd rest)
      where
      rest = output (nbits + 1) 8 0 0 cs
      outBits = if stillToGo /= 8 then nbits else 0

output nbits stillToGo r_off prev (Clear : cs)
    = ((prev : 1 : take' padBits padding) ++ fst rest, outBits : snd rest)
      where
      rest = output 9 8 0 0 cs
      outBits = if stillToGo /= 8 then nbits else 0
      padBits = nbits - ((9 - stillToGo) * 2)
      take' n l = if n < 0 then take 1 l else take n l

output nbits stillToGo r_off prev css@(Code code : cs)

    | stillToGo == 0 = output nbits 8 0 0 css
    | otherwise = if (nbits + r_off) >= 16 then
                      (byte1 : byte2 : fst rest1, outBits : snd rest1)
                  else
                      (byte1 : fst rest2, outBits : snd rest2)
      where
      r_off' = 8 - r_off
dnt's avatar
dnt committed
50 51 52
      byte1 = intOr prev (intLsh code r_off)
      byte2 = intRsh code r_off'
      byte3 = intRsh byte2 8
53 54 55 56 57 58
      outBits = if stillToGo == 1 then nbits else 0
      rest1 = output nbits (stillToGo-1) ((r_off+nbits) `mod` 8) byte3 cs
      rest2 = output nbits (stillToGo-1) ((r_off+nbits) `mod` 8) byte2 cs

padding :: [Int]
padding = [255, 255 ..]