1 module WriteRoutines (outputCodes) 2 where 3 4 --import GlaExts 5 import GHC.Base ( Int(..), word2Int#, int2Word#, and#, or#, shiftL#, shiftRL# ) 6 import Encode (CodeEvent(..)) 7 8 -- Start of code added for ghc 9 w2i x = word2Int# x 10 i2w x = int2Word# x 11 12 intAnd (I# x) (I# y) = I# (w2i (and# (i2w x) (i2w y))) 13 intOr (I# x) (I# y) = I# (w2i (or# (i2w x) (i2w y))) 14 intLsh (I# x) (I# y) = I# (w2i (shiftL# (i2w x) y)) 15 intRsh (I# x) (I# y) = I# (w2i (shiftRL# (i2w x) y)) 16 -- End of code added for ghc 17 18 outputCodes :: [CodeEvent] -> (String, [Int]) 19 outputCodes cs = (map (\x -> toEnum (intAnd 255 x)) (fst result), snd result) 20 where result = output 9 8 0 0 cs -- assume 9 bit start 21 22 output :: Int -> Int -> Int -> Int -> [CodeEvent] -> ([Int], [Int]) 23 output _ _ _ prev [] = ([prev], [1]) 24 25 output nbits stillToGo r_off prev (NewWordSize : cs) 26 = (fst rest, 0 : snd rest) 27 where 28 rest = output (nbits + 1) 8 0 0 cs 29 outBits = if stillToGo /= 8 then nbits else 0 30 31 output nbits stillToGo r_off prev (Clear : cs) 32 = ((prev : 1 : take' padBits padding) ++ fst rest, outBits : snd rest) 33 where 34 rest = output 9 8 0 0 cs 35 outBits = if stillToGo /= 8 then nbits else 0 36 padBits = nbits - ((9 - stillToGo) * 2) 37 take' n l = if n < 0 then take 1 l else take n l 38 39 output nbits stillToGo r_off prev css@(Code code : cs) 40 41 | stillToGo == 0 = output nbits 8 0 0 css 42 | otherwise = if (nbits + r_off) >= 16 then 43 (byte1 : byte2 : fst rest1, outBits : snd rest1) 44 else 45 (byte1 : fst rest2, outBits : snd rest2) 46 where 47 r_off' = 8 - r_off 48 byte1 = intOr prev (intLsh code r_off) 49 byte2 = intRsh code r_off' 50 byte3 = intRsh byte2 8 51 outBits = if stillToGo == 1 then nbits else 0 52 rest1 = output nbits (stillToGo-1) ((r_off+nbits) `mod` 8) byte3 cs 53 rest2 = output nbits (stillToGo-1) ((r_off+nbits) `mod` 8) byte2 cs 54 55 padding :: [Int] 56 padding = [255, 255 ..]