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 -- | ColorTransformAlpha -- 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] {- g (F# f) = let words = W32# (unsafeCoerce# f) ba = unsafeCoerce# words :: ByteArray# -- more evil w0 = W8# (ba `indexWord8Array#` 0#) w1 = W8# (ba `indexWord8Array#` 1#) w2 = W8# (ba `indexWord8Array#` 2#) w3 = W8# (ba `indexWord8Array#` 3#) 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) -}