{-# OPTIONS -fglasgow-exts #-}
module Swf.Bin where

-- arch-tag: dfd8b252-e0f2-4a86-a400-e3a60064fd28

import Data.Word
import Data.Int
import Data.Bits

import GHC.Base
import GHC.Word
import GHC.Float

import Numeric

-- Basic Data Types

type SwfString = String
type SwfLanguageCode = Int
type SwfRGB = (SwfU8, SwfU8, SwfU8)
type SwfRGBA = (SwfU8, SwfU8, SwfU8, SwfU8)
data SwfRect = SwfRect SwfSB SwfSB SwfSB SwfSB -- xmin, xmax, ymin, ymax
             | SwfRectS SwfU8 SwfSB SwfSB SwfSB SwfSB 
	       deriving Show
type SwfU32 = Word32
type SwfU16 = Word16
type SwfU8 = Word8
type SwfUB = Word32
type SwfSB = Int32
type SwfBool = Bool
type SwfFloat = Float
type SwfDouble = Double



-- Calculate the numbers of bits needed to represent 'n'
class NBits a where
    nBits :: a -> Word8

instance NBits Word8 where
    nBits = nuBits

instance NBits Word16 where
    nBits = nuBits

instance NBits Word32 where
    nBits = nuBits

instance NBits Int8 where
    nBits = nsBits

instance NBits Int16 where
    nBits = nsBits

instance NBits Int32 where
    nBits = nsBits

instance NBits Int where
    nBits = nsBits


nuBits :: (Ord a, Bits a) => a -> Word8
nuBits n = fromIntegral (length [n | y <- [0 .. 31], n `shiftR` y > 0 ])

nsBits :: (Ord a, Bits a) => a -> Word8
nsBits n
    | n >  0 = fromIntegral (1 + length [n | y <- [0 .. 31], n `shiftR` y > 0 ])
    | n == 0 = 1
    | n <  0 = fromIntegral (1 + (length [n | y <- [0 .. 31], n `shiftR` y < -1 ]))

addBits :: (Integral a, Ord a, Bits a) => ([Word8], Int) -> (a, Int) -> ([Word8], Int)
addBits (bytes,0) (word, nbits)
    | nbits <  8 = ((fromIntegral (word `shiftL` (8 - nbits)):bytes), (8 - nbits))
    | nbits == 8 = (fromIntegral word:bytes, 0)
    | otherwise  = ((fromIntegral (word `shiftR` (nbits - 8)):bytes), 0) `addBits` (word, (nbits - 8))
addBits ((hd:tl),emptyCount) (word, nbits)
    | nbits < emptyCount  = ((((fromIntegral ((word .&. (bitMask nbits)) `shiftL` (emptyCount - nbits))) .|. hd):tl), 
			    (emptyCount - nbits))
    | nbits == emptyCount = ((((fromIntegral (word .&. (bitMask nbits))) .|. hd):tl), 0)
    | otherwise = ((((fromIntegral ((word `shiftR` (nbits - emptyCount))) .&. (bitMask emptyCount)) .|. hd):tl), 0) `addBits` (word, (nbits - emptyCount))
    where
    bitMask n = ((1 `shiftL` n) - 1)

finalizeBits :: ([Word8],Int) -> [Word8]
finalizeBits (bytes, _) = reverse bytes

class Has a where
    has :: a -> Word8

instance Has (Maybe a) where
    has Nothing  = 0
    has (Just _) = 1

instance Has SwfBool where
    has False = 0
    has True = 1

-- Convert Tags into [Word8]

class SwfBin a where
    toBin :: a -> [Word8]

class SwfBinPartial a where
    toBinP :: Word8 -> Word8 -> ([Word8],Int) -> a -> ([Word8],Int)

-- General Datatypes

instance SwfBin Word8 where
    toBin w8 = [w8]

instance SwfBin Word16 where
    toBin w16 = [ fromIntegral (w16 .&. 0xff)
		, fromIntegral ((w16 `shiftR` 8) .&. 0xff)
		]

instance SwfBin Word32 where
    toBin w32 = [ fromIntegral (w32 .&. 0xff) 
		, fromIntegral ((w32 `shiftR` 8) .&. 0xff) 
		, fromIntegral ((w32 `shiftR` 16) .&. 0xff) 
		, fromIntegral ((w32 `shiftR` 24) .&. 0xff) 
		]

instance SwfBin Word64 where
    toBin w64 = [ fromIntegral (w64 .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 8) .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 16) .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 24) .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 32) .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 40) .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 48) .&. 0xff) 
		, fromIntegral ((w64 `shiftR` 56) .&. 0xff) 
		]

instance SwfBin Int where
    toBin w32 = [ fromIntegral (w32 .&. 0xff) 
		      , fromIntegral ((w32 `shiftR` 8) .&. 0xff) 
		      , fromIntegral ((w32 `shiftR` 16) .&. 0xff) 
		      , fromIntegral ((w32 `shiftR` 24) .&. 0xff) 
		      ]

instance SwfBin Float where
    toBin (F# f) = toBin (W32# (unsafeCoerce# f))

instance SwfBin Double where
    toBin (D# d) = toBin (W64# (unsafeCoerce# d))

instance SwfBin Char where
    toBin char = [(fromIntegral . fromEnum) char]

instance SwfBin a => SwfBin [a] where
    toBin str = (concatMap toBin str) ++ [0]

instance (SwfBin a, SwfBin b) => SwfBin (a,b) where
    toBin (x, y) = toBin x ++ toBin y

instance (SwfBin a, SwfBin b, SwfBin c) => SwfBin (a,b,c) where
    toBin (w, x, y) = toBin w ++ toBin x ++ toBin y

instance (SwfBin a, SwfBin b, SwfBin c, SwfBin d) => SwfBin (a,b,c,d) where
    toBin (w, x, y, z) = toBin w ++ toBin x ++ toBin y ++ toBin z

instance (SwfBin a, SwfBin b, SwfBin c, SwfBin d, SwfBin e) => SwfBin (a,b,c,d,e) where
    toBin (v, w, x, y, z) = toBin v ++ toBin w ++ toBin x ++ toBin y ++ toBin z

instance (SwfBin a) => SwfBin (Maybe a) where
    toBin Nothing = []
    toBin (Just x) = toBin x