module Swf.Tags where
import Text.PrettyPrint.HughesPJ
import System.IO
import Swf.Assembly
import Swf.Bin
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
data Bitmaps = Int
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
| PlaceObject2 { po2PlaceMove :: SwfU8
, po2Depth :: SwfU16
, po2CharacterId :: Maybe SwfU16
, po2Matrix :: Maybe SwfMatrix
, po2ColorTransform :: Maybe SwfColorTransform
, po2Ratio :: Maybe SwfU16
, po2Name :: Maybe SwfString
, po2ClipDepth :: Maybe SwfU16
}
| ShowFrame
| DefineShape { dsShapeId :: SwfU16
, dsShapeBounds :: SwfRect
, dsShapes :: ShapeWithStyle
}
| 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
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
instance SwfBin SwfColorTransform where
toBin (SwfColorTransform _ _ _ _ _ _ _) = [] --fixme
instance SwfBin SwfMatrix where
toBin (SwfMatrix _ _ _ _ _ _) = []
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)
`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 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)
`addBits` (has autoSize, 1)
`addBits` (has layout, 1)
`addBits` (has noSel, 1)
`addBits` (has border, 1)
`addBits` (0::Word8,1)
`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) ++
concatMap toBin fillStyles ++
toBin ((fromIntegral (length lineStyles)) :: Word8) ++
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
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
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
, 0x57
, 0x53
, 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
instance SwfBin SwfAssembly where
toBin ActionAdd = [0x0A]
toBin ActionSubtract = [0x0B]
toBin ActionMultiply = [0x0C]
toBin ActionDivide = [0x0D]
toBin (ActionPushString s) = [0x96] ++
toBin ((fromIntegral ((length s) + 2)) :: SwfU16) ++
[0] ++
(toBin s)
toBin ActionPop = [0x17]
toBin ActionGetVariable = [0x1C]
toBin ActionSetVariable = [0x1D]