module Swf.Tags where

-- arch-tag: e72a682a-2520-496b-a772-03366481aac4
-- notes: maybe one bit values should be represented with SwfBool?

-- import PPrint

import Text.PrettyPrint.HughesPJ
import System.IO

import Swf.Assembly
import Swf.Bin
-- import SchemeParser
-- import SwfCompiler
import Swf.Assembler

import Data.Bits
import Data.Word

data SwfMatrix = SwfMatrix { mScaleX :: Maybe SwfU32
			   , mScaleY :: Maybe SwfU32
			   , mRotateSkew0 :: Maybe SwfU32
			   , mRotateSkew1 :: Maybe SwfU32
			   , mTranslateX :: Maybe SwfU32
			   , mTranslateY :: Maybe SwfU32
			   }
		 deriving Show

data SwfColorTransform = SwfColorTransform { ctNbits :: SwfUB
					   , ctRedAddTerm :: Maybe SwfSB
					   , ctGreenAddTerm :: Maybe SwfSB
					   , ctBlueAddTerm :: Maybe SwfSB
					   , ctRedMultTerm :: Maybe SwfSB
					   , ctGreenMultTerm :: Maybe SwfSB
					   , ctBlueMultTrem :: Maybe SwfSB
					   }
			 deriving Show

-- Control Tags

data Bitmaps = Int -- fixme

data GradientRecord = GradientRecordRGB { grRatio :: SwfU8
					, grRGB :: SwfRGB
					}
		    | GradientRecordRGBA { grRatio :: SwfU8
					 , grRGBA :: SwfRGBA
					 }
    deriving Show

data FillStyle = FillStyleSolid { fsColor :: SwfRGBA
				 }
    deriving Show --fixme

data LineStyle = LineStyle { lsWidth  :: SwfU16
			   , lsColor :: SwfRGBA
			   }
    deriving Show

data Shape = Shape { sNumFillBits :: SwfUB
		   , sNumLineBits :: SwfUB
		   , sShapeRecords :: [ShapeRecord]
		   }

data ShapeWithStyle = ShapeWithStyle 
    { swsFillStyles :: [FillStyle]
    , swsLineStyles :: [LineStyle]
    , swsShapeRecords :: [ShapeRecord]
    }
    deriving Show


data ShapeRecord = EndShapeRecord

		 | StyleChangeRecord { scrMoveDelta	:: Maybe (SwfSB,SwfSB)
				     , scrFillStyle0	:: Maybe SwfUB
				     , scrFillStyle1	:: Maybe SwfUB
				     , scrLineStyle	:: Maybe SwfUB
				     , scrFillStyles	:: Maybe [FillStyle]
				     , scrLineStyles	:: Maybe [LineStyle]
				     }

                 | StraightEdgeRecordH { deltaX :: SwfSB
				       }

                 | StraightEdgeRecordV { deltaY :: SwfSB
				       }

                 | StraightEdgeRecordG { deltaX :: SwfSB
				       , deltaY :: SwfSB
				       }
	deriving Show


data Tag = DoAction { daActions :: [SwfAssembly] }
	 | SetBackgroundColor { sbcBackgroundColor :: SwfRGB }
	 | FrameLabel { flName :: SwfString }
	 | End 
	 -- Display List Tags
	 | PlaceObject2 { po2PlaceMove :: SwfU8
			, po2Depth :: SwfU16
			, po2CharacterId :: Maybe SwfU16
			, po2Matrix :: Maybe SwfMatrix
			, po2ColorTransform :: Maybe SwfColorTransform
			, po2Ratio :: Maybe SwfU16
			, po2Name :: Maybe SwfString
			, po2ClipDepth :: Maybe SwfU16
-- 			, po2ClipActions :: Maybe SwfClipActions --fixme: add SwfClipActions type
			}
	 | ShowFrame
	 -- Shape Tags
	 | DefineShape { dsShapeId :: SwfU16
		       , dsShapeBounds :: SwfRect
		       , dsShapes :: ShapeWithStyle
		       }
         -- Font and Text Tags
	 | DefineEditText { detCharacterId :: SwfU16
			  , detBounds :: SwfRect
			  , detInitialText :: Maybe SwfString
			  , detWordWrap :: SwfBool
			  , detMultiline :: SwfBool
			  , detPassword :: SwfBool
			  , detReadOnly :: SwfBool
			  , detTextColor :: Maybe SwfRGBA
			  , detMaxLength :: Maybe SwfU16
			  , detFont :: Maybe (SwfU16, SwfU16)
			  , detAutosize :: SwfBool
			  , detLayout :: Maybe (SwfU8, SwfU16, SwfU16, SwfU16, SwfU16)
			  , detNoSelect :: SwfBool
			  , detBorder :: SwfBool
			  , detHTML :: SwfBool
			  , detUseOutlines :: SwfBool
			  , detVariableName :: SwfString
			  }
	   deriving Show

-- Header

data HeaderTag = SwfHeader { shVersion :: SwfU8
			   , shFrameSize :: SwfRect
			   , shFrameRate :: SwfU16
			   , shFrameCount :: SwfU16
			   , shTags :: [Tag]
			   }
	       deriving Show

addTagHeader :: Word16 -> [Word8] -> [Word8]
addTagHeader tagType tagData =
    let dataLength = length tagData in
		     if (dataLength < 63)
			    then toBin ((tagType `shiftL` 6) .|. (fromIntegral dataLength)) ++ tagData
			    else toBin ((tagType `shiftL` 6) .|. 0x3f) ++ 
				 toBin ((fromIntegral dataLength) :: SwfU32) ++ 
				 tagData


-- Swf Specific Stuff

instance SwfBin SwfColorTransform where
    toBin (SwfColorTransform _ _ _ _ _ _ _)  = [] --fixme

instance SwfBin SwfMatrix where
    toBin (SwfMatrix _ _ _ _ _ _) = [] -- fixme

instance SwfBin Tag where
    toBin (DoAction actions) = 
	let (_,objCode) = assemble actions 0 [] in
	    addTagHeader 12 (objCode ++ (toBin (0::SwfU8)))
    toBin (SetBackgroundColor bgColor) = addTagHeader 9 (toBin bgColor)
    toBin (DefineShape dsShapeId dsShapeBounds dsShapes) = addTagHeader 32 (toBin dsShapeId ++ 
									    toBin dsShapeBounds ++ 
									    toBin dsShapes
									   )
    toBin (PlaceObject2 placeMove depth charId matrix colorTransform ratio name clipDepth) =
	addTagHeader 26 ((finalizeBits (([],0) 
				       `addBits` (has Nothing,  1) -- fixme
				       `addBits` (has clipDepth, 1)
				       `addBits` (has name, 1)
				       `addBits` (has ratio, 1)
				       `addBits` (has colorTransform, 1)
				       `addBits` (has matrix, 1)
				       `addBits` (has charId, 1)
				       `addBits` (placeMove, 1)))
			 ++ toBin depth
			 ++ toBin charId
			 ++ toBin matrix
			 ++ toBin colorTransform
			 ++ toBin ratio
			 ++ toBin name
			 ++ toBin clipDepth
			 -- ++ toBin clipActions -- fixme
			)
    toBin ShowFrame = addTagHeader 1 []
    toBin End = addTagHeader 0 []
    toBin (DefineEditText charId bounds initialText wordWrap multiline password readOnly textColor maxLen font autoSize layout noSel border html useOutlines varName) =
	addTagHeader 37 (toBin charId ++
			 toBin bounds ++
			 finalizeBits (([],0)
				       `addBits` (has initialText, 1)
				       `addBits` (has wordWrap, 1)
				       `addBits` (has multiline, 1)
				       `addBits` (has password, 1)
				       `addBits` (has readOnly, 1)
				       `addBits` (has textColor, 1)
				       `addBits` (has maxLen, 1)
				       `addBits` (has font, 1)
				       `addBits` (0::Word8,1) -- reserved
				       `addBits` (has autoSize, 1)
				       `addBits` (has layout, 1)
				       `addBits` (has noSel, 1)
				       `addBits` (has border, 1)
				       `addBits` (0::Word8,1) -- reserved
				       `addBits` (has html, 1)
				       `addBits` (has useOutlines, 1)
				      ) ++
			 toBin font ++
			 toBin textColor ++
			 toBin maxLen ++
			 toBin layout ++
			 toBin varName ++
			 toBin initialText
			)

instance SwfBin ShapeWithStyle where
    toBin (ShapeWithStyle fillStyles lineStyles shapeRecords) = 
	toBin ((fromIntegral (length fillStyles)) :: Word8) ++ -- fixme, add support for >255
	concatMap toBin fillStyles ++
	toBin ((fromIntegral (length lineStyles)) :: Word8) ++ -- fixme, add support for >255
	concatMap toBin lineStyles ++
	finalizeBits (([],0) `addBits` (nFillStylesBits, 4) `addBits` (nLineStylesBits, 4)) ++
	finalizeBits (foldl (toBinP nLineStylesBits nFillStylesBits) ([],0) shapeRecords)
	    where nLineStylesBits = (nBits ((fromIntegral (length lineStyles)) :: Word32))
		  nFillStylesBits = (nBits ((fromIntegral (length fillStyles)) :: Word32))

instance SwfBin FillStyle where  -- fixme, add other fill styles
    toBin (FillStyleSolid fsColor) = [0] ++ toBin fsColor

instance SwfBin LineStyle where
    toBin (LineStyle lsWidth lsColor) = toBin lsWidth ++ toBin lsColor

instance SwfBinPartial ShapeRecord where
    toBinP _ _ partial EndShapeRecord = partial `addBits` (0::Word8, 6)
    toBinP _ _ partial (StraightEdgeRecordH deltaX) = partial
						      `addBits` (3::Word8,2) 
						      `addBits` (nbits,4)
						      `addBits` (0::Word8,2)
						      `addBits` (deltaX, nbits + 2)
	where nbits = if (fromIntegral (nBits deltaX)) - 2 < 0
		      then 0 
		      else  (fromIntegral (nBits deltaX)) - 2

    toBinP _ _ partial (StraightEdgeRecordV deltaY) = partial
						      `addBits` (3::Word8,2) 
						      `addBits` (nbits, 4)
						      `addBits` (1::Word8,2)
						      `addBits` (deltaY, nbits + 2)
	where nbits = if (fromIntegral (nBits deltaY)) - 2 < 0
		      then 0 
		      else  (fromIntegral (nBits deltaY)) - 2

    toBinP _ _ partial (StraightEdgeRecordG deltaX deltaY) = partial
							     `addBits` (3::Word8,2) 
							     `addBits` (nbits, 4)
							     `addBits` (1::Word8,1)
							     `addBits` (deltaX, nbits + 2)
							     `addBits` (deltaY, nbits + 2)
	where nbits = if (deltaX > deltaY) 
		      then if (nBits deltaX) - 2 < 0
			   then 0 
			   else  (fromIntegral (nBits deltaX) - 2)
		      else if (nBits deltaY) - 2 < 0
			   then 0 
			   else  (fromIntegral (nBits deltaY) - 2)

    toBinP nLineStylesBits nFillStylesBits partial (StyleChangeRecord moveDelta fillStyle0 fillStyle1 lineStyle fillStyles lineStyles) =
	partial
	`addBits` (0::Word8, 1)
	`addBits` ((has fillStyles) .|. (has lineStyles), 1)
	`addBits` ((has lineStyle), 1)
	`addBits` ((has fillStyle1), 1)
	`addBits` ((has fillStyle0), 1)
	`addBits` ((has moveDelta), 1)
	`moveDeltaBits` moveDelta
        `fillStyleBits` fillStyle0
        `fillStyleBits` fillStyle1
        `lineStyleBits` lineStyle
			-- fixme: add fillStyles, lineStyles
	    where moveDeltaBits partial Nothing = partial
		  moveDeltaBits partial (Just (deltaX, deltaY)) = 
		      let nbits = max (nBits deltaX) (nBits deltaY) in
				  partial
				  `addBits` (nbits, 5)
				  `addBits` (deltaX, fromIntegral nbits)
				  `addBits` (deltaY, fromIntegral nbits)
		  fillStyleBits partial Nothing = partial
		  fillStyleBits partial (Just fillStyle) = partial
							   `addBits` (fillStyle, fromIntegral nFillStylesBits)
		  lineStyleBits partial Nothing = partial
		  lineStyleBits partial (Just lineStyle) = partial
							   `addBits` (lineStyle, fromIntegral nLineStylesBits)

instance SwfBin SwfRect where
    toBin (SwfRect xmin xmax ymin ymax) = 
	let nbits = fromIntegral (maximum [nBits xmin,nBits xmax,nBits ymin,nBits ymax]) in
		    finalizeBits (([],0) 
				  `addBits` (nbits,5)
				  `addBits` (xmin,nbits)
				  `addBits` (xmax,nbits)
				  `addBits` (ymin,nbits)
				  `addBits` (ymax,nbits)
				 )


    toBin (SwfRectS numbits xmin xmax ymin ymax) = 
	let nbits = fromIntegral numbits in
		    finalizeBits (([],0) 
				  `addBits` (nbits,5)
				  `addBits` (xmin,nbits)
				  `addBits` (xmax,nbits)
				  `addBits` (ymin,nbits) 
				  `addBits` (ymax,nbits)
				 )

instance SwfBin HeaderTag where
    toBin (SwfHeader shVersion shFrameSize shFrameRate shFrameCount shTags) =  
	let shTagsBin = concatMap toBin shTags in
	let tail = toBin shFrameSize ++
		   toBin shFrameRate ++
		   toBin shFrameCount ++
		   shTagsBin
		   in
			[ 0x46 -- 'F'
			, 0x57 -- 'W'
			, 0x53 -- 'S'
			, shVersion
			] ++
                        toBin (fromIntegral (8 + (length tail)) :: SwfU32) ++
			tail


swfWrite :: String -> [Word8] -> IO ()
swfWrite filename swfData = do h <- openFile filename WriteMode
			       hPutStr h (map (toEnum . fromIntegral) swfData)
			       hClose h

-- assembly

instance SwfBin SwfAssembly where
    -- Arithmetic
    toBin ActionAdd		= [0x0A]
    toBin ActionSubtract	= [0x0B]
    toBin ActionMultiply	= [0x0C]
    toBin ActionDivide		= [0x0D]
    -- Control Flow
    -- Stack
    toBin (ActionPushString s)	= [0x96] ++
				  toBin ((fromIntegral ((length s) + 2)) :: SwfU16) ++
				  [0] ++
				  (toBin s)
--    toBin (ActionPushFloat f)   = [0x96, 0x5, 0x0, 0x1] ++ (toBin f)
    toBin ActionPop		= [0x17]
    -- Variables
    toBin ActionGetVariable	= [0x1C]
    toBin ActionSetVariable	= [0x1D]


{-
<dons> g (F# f) =
<dons>         let words = W32# (unsafeCoerce# f)
<dons>             ba    = unsafeCoerce# words :: ByteArray#     -- more evil
<dons>             w0    = W8# (ba `indexWord8Array#` 0#)
<dons>             w1    = W8# (ba `indexWord8Array#` 1#)
<dons>             w2    = W8# (ba `indexWord8Array#` 2#)
<dons>             w3    = W8# (ba `indexWord8Array#` 3#)
<dons>         in (w0, w1, w2, w3)

floatToWord32 (F# f) = W# (unsafeCoerce# f) 

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

import Data.Bits

main = let f  = 7777.0 
           f' = g f
           f''= g' f'
       in do putStrLn (show f) 
             putStrLn (show f')
             putStrLn (show f'')

g :: Float -> (Word8,Word8,Word8,Word8)
g (F# f) = 
        let w     = W32# (unsafeCoerce# f)
            w0    = (fromIntegral (w `shiftR` 24))
            w1    = (fromIntegral ((w `shiftR` 16) .&. 0xff))
            w2    = (fromIntegral ((w `shiftR` 8)  .&. 0xff))
            w3    = (fromIntegral (w .&. 0xff))
        in (w0,w1,w2,w3)
        
g' :: (Word8,Word8,Word8,Word8) -> Float
g' (w0,w1,w2,w3) =
        let (W32# w) = (fromIntegral w0 `shiftL` 24) .|.
                       (fromIntegral w1 `shiftL` 16) .|.
                       (fromIntegral w2 `shiftL`  8) .|.
                       (fromIntegral w3)
        in F# (unsafeCoerce# w)
 
-}