123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284 |
- {-# LANGUAGE RecordWildCards #-}
- module Graphics.HVIF where
- import Control.Monad (replicateM, when)
- import Data.Bits ((.|.), (.&.), clearBit, shift, testBit)
- import Data.ByteString (ByteString)
- import Data.Sequence (Seq)
- import qualified Data.Sequence as S
- import Data.Serialize
- import Data.Word
- data HVIFFile = HVIFFile
- { hvifColors :: Seq Style
- , hvifPaths :: Seq Path
- , hvifShapes :: Seq Shape
- } deriving (Eq, Show)
- decodeFile :: ByteString -> Either String HVIFFile
- decodeFile = runGet pFile
- getSeveral :: Get a -> Get (Seq a)
- getSeveral getter = do
- count <- getWord8
- S.fromList `fmap` replicateM (fromIntegral count) getter
- pFile :: Get HVIFFile
- pFile = do
- header <- getByteString 4
- when (header /= "ncif") $
- fail "Missing `ficn' header"
- hvifColors <- getSeveral pStyle
- hvifPaths <- getSeveral pPath
- hvifShapes <- getSeveral pShape
- return HVIFFile { .. }
- -- Style Section
- data Style
- = ColorSolid Word8 Word8 Word8 Word8
- | ColorGradient Gradient
- | ColorSolidNoAlpha Word8 Word8 Word8
- | ColorSolidGray Word8 Word8
- | ColorSolidGrayNoAlpha Word8
- deriving (Eq, Show)
- pStyle :: Get Style
- pStyle = do
- sType <- getWord8
- case sType of
- 0x01 -> ColorSolid <$> get <*> get <*> get <*> get
- 0x02 -> ColorGradient <$> pGradient
- 0x03 -> ColorSolidNoAlpha <$> get <*> get <*> get
- 0x04 -> ColorSolidGray <$> get <*> get
- 0x05 -> ColorSolidGrayNoAlpha <$> get
- _ -> fail "invalid"
- data Gradient = Gradient
- { gType :: GradientType
- , gFlags :: GradientFlags
- , gStops :: Seq GradientStop
- } deriving (Eq, Show)
- pGradient :: Get Gradient
- pGradient = do
- gType <- pGradientType
- gFlags <- pGradientFlags
- gStops <- getSeveral (pGradientStop gFlags)
- return Gradient { .. }
- data GradientType
- = GTLinear
- | GTCircular
- | GTDiamond
- | GTConic
- | GTXY
- | GTSqrtXY
- deriving (Eq, Show)
- pGradientType :: Get GradientType
- pGradientType = do
- gType <- getWord8
- case gType of
- 00 -> return GTLinear
- 01 -> return GTCircular
- 02 -> return GTDiamond
- 03 -> return GTConic
- 04 -> return GTXY
- 05 -> return GTSqrtXY
- _ -> fail ("Unknown gradient type: " ++ show gType)
- data GradientFlags = GradientFlags
- { gfTransform :: Bool
- , gfNoAlpha :: Bool
- , gf16Bit :: Bool
- , gfGrays :: Bool
- } deriving (Eq, Show)
- pGradientFlags :: Get GradientFlags
- pGradientFlags = do
- gFlags <- getWord8
- return $ GradientFlags
- { gfTransform = testBit gFlags 1
- , gfNoAlpha = testBit gFlags 2
- , gf16Bit = testBit gFlags 3
- , gfGrays = testBit gFlags 4
- }
- data GradientStop = GradientStop
- { gsOffset :: Word8
- , gsRed :: Word8
- , gsGreen :: Word8
- , gsBlue :: Word8
- , gsAlpha :: Word8
- } deriving (Eq, Show)
- pGradientStop :: GradientFlags -> Get GradientStop
- pGradientStop flags = do
- offset <- get
- (r, g, b) <-
- if gfGrays flags
- then do
- val <- get
- return (val, val, val)
- else do
- r <- get
- g <- get
- b <- get
- return (r, g, b)
- a <-
- if gfNoAlpha flags
- then return 0xff
- else get
- return $ GradientStop offset r g b a
- -- Path Section
- data Path = Path
- { pathFlags :: PathFlags
- , pathPoints :: Seq Command
- } deriving (Eq, Show)
- pPath :: Get Path
- pPath = do
- pathFlags <- pPathFlags
- pathPoints <- pPoints pathFlags
- return Path { .. }
- data PathFlags = PathFlags
- { pfClosed :: Bool
- , pfUsesCommands :: Bool
- , pfNoCurves :: Bool
- } deriving (Eq, Show)
- pPathFlags :: Get PathFlags
- pPathFlags = do
- pFlags <- getWord8
- return $ PathFlags
- { pfClosed = testBit pFlags 1
- , pfUsesCommands = testBit pFlags 2
- , pfNoCurves = testBit pFlags 3
- }
- data Point = Point
- { coordX :: Float
- , coordY :: Float
- } deriving (Eq, Show)
- data Command
- = CmdHLine Float
- | CmdVLine Float
- | CmdLine Point
- | CmdCurve Point Point Point
- deriving (Eq, Show)
- pPoints :: PathFlags -> Get (Seq Command)
- pPoints PathFlags { pfUsesCommands = False
- , pfNoCurves = False } =
- getSeveral pCurveCommand
- pPoints PathFlags { pfUsesCommands = False
- , pfNoCurves = True } =
- getSeveral pLineCommand
- pPoints PathFlags { pfUsesCommands = True } =
- pCommandList
- pLineCommand :: Get Command
- pLineCommand = CmdLine <$> (Point <$> pCoord <*> pCoord)
- pCurveCommand :: Get Command
- pCurveCommand = CmdCurve <$> (Point <$> pCoord <*> pCoord)
- <*> (Point <$> pCoord <*> pCoord)
- <*> (Point <$> pCoord <*> pCoord)
- pCommandList :: Get (Seq Command)
- pCommandList = do
- pointCount <- getWord8
- let cmdByteCount = (pointCount + 3) `div` 4
- cmdBytes <- replicateM (fromIntegral cmdByteCount) getWord8
- let go n
- | n == fromIntegral pointCount = return S.empty
- | otherwise =
- let bIdx = n `div` 4
- iIdx = (n `mod` 4) * 2
- in case (cmdBytes !! bIdx) `shift` (negate iIdx) .&. 0x03 of
- 0x00 ->
- (S.<|) <$> (CmdHLine <$> pCoord) <*> go (n+1)
- 0x01 ->
- (S.<|) <$> (CmdVLine <$> pCoord) <*> go (n+1)
- 0x02 ->
- (S.<|) <$> pLineCommand <*> go (n+1)
- 0x03 ->
- (S.<|) <$> pCurveCommand <*> go (n+1)
- _ -> error "[unreachable]"
- go 0
- pCoord :: Get Float
- pCoord = do
- b1 <- getWord8
- if testBit b1 7 then do
- b2 <- getWord8
- let cVal :: Word16 = (clearBit (fromIntegral b1) 7 `shift` 8) .|. fromIntegral b2
- return (fromIntegral cVal / 102.0 - 128.0)
- else
- return (fromIntegral b1 - 32.0)
- -- Shape Section
- data Shape = Shape
- { shapeStyle :: StyleRef
- , shapePaths :: Seq PathRef
- , shapeFlags :: ShapeFlags
- , shapeTransform :: Maybe Matrix
- } deriving (Eq, Show)
- type Matrix = Seq Float
- pShape :: Get Shape
- pShape = do
- sType <- getWord8
- when (sType /= 0x0a) $
- fail ("Unknown shape type: " ++ show sType)
- shapeStyle <- StyleRef <$> get
- shapePaths <- getSeveral (PathRef <$> get)
- shapeFlags <- pShapeFlags
- shapeTransform <-
- if sfTransform shapeFlags
- then Just <$> pMatrix
- else return Nothing
- return Shape { .. }
- newtype PathRef = PathRef { prIdx :: Word8 } deriving (Eq, Show)
- newtype StyleRef = StyleRef { stIdx :: Word8 } deriving (Eq, Show)
- data ShapeFlags = ShapeFlags
- { sfTransform :: Bool
- , sfHinting :: Bool
- , sfLodScale :: Bool
- , sfHasTransformers :: Bool
- , sfTranslation :: Bool
- } deriving (Eq, Show)
- pShapeFlags :: Get ShapeFlags
- pShapeFlags = do
- sFlags <- getWord8
- return ShapeFlags
- { sfTransform = testBit sFlags 1
- , sfHinting = testBit sFlags 2
- , sfLodScale = testBit sFlags 3
- , sfHasTransformers = testBit sFlags 4
- , sfTranslation = testBit sFlags 5
- }
- pMatrix :: Get Matrix
- pMatrix = S.fromList `fmap` replicateM 6 pFloat
- pFloat :: Get Float
- pFloat = do
- _ <- getWord8
- _ <- getWord8
- _ <- getWord8
- return 0.0
|