gdritter repos hvif / dc983cb
Added extra Shape features Getty Ritter 7 years ago
1 changed file(s) with 65 addition(s) and 7 deletion(s). Collapse all Expand all
+65
-7
Graphics/HVIF.hs less more
11 {-# LANGUAGE RecordWildCards #-}
22 {-# LANGUAGE BinaryLiterals #-}
3 {-# LANGUAGE MultiWayIf #-}
34
45 module Graphics.HVIF
56 (
2324 , PathRef(..)
2425 , StyleRef(..)
2526 , ShapeFlags(..)
27 , Translation(..)
28 , LodScale(..)
2629 ) where
2730
2831 import Control.Monad (replicateM, when)
118121 , shapePaths :: Seq PathRef
119122 , shapeFlags :: ShapeFlags
120123 , shapeTransform :: Maybe Matrix
124 , shapeTranslate :: Maybe Translation
125 , shapeLodScale :: Maybe LodScale
126 , shapeTransList :: Seq Transformer
121127 } deriving (Eq, Show)
122128
123129 type Matrix = Seq Float
133139 , sfTranslation :: Bool
134140 } deriving (Eq, Show)
135141
142 data Translation = Translation
143 { transX :: Float
144 , transY :: Float
145 } deriving (Eq, Show)
146
147 data LodScale = LodScale
148 { lsMin :: Float
149 , lsMax :: Float
150 } deriving (Eq, Show)
151
152 data Transformer
153 = TransformerAffine Matrix
154 | TransformerContour Float Word8 Word8
155 | TransformerPerspective -- Not fully supported, I think?
156 | TransformerStroke Float Word8 Word8 Word8
157 deriving (Eq, Show)
158
136159 -- Decoding code
137160
138161 getSeveral :: Get a -> Get (Seq a)
144167 pFile = do
145168 header <- getByteString 4
146169 when (header /= "ncif") $
147 fail "Missing `ficn' header"
170 fail "Missing `ncif' header"
148171 hvifColors <- getSeveral pStyle
149172 hvifPaths <- getSeveral pPath
150173 hvifShapes <- getSeveral pShape
161184 0x03 -> ColorSolidNoAlpha <$> get <*> get <*> get
162185 0x04 -> ColorSolidGray <$> get <*> get
163186 0x05 -> ColorSolidGrayNoAlpha <$> get
164 _ -> fail "invalid"
187 _ -> getWord16be >> fail "invalid"
165188
166189 pGradient :: Get Gradient
167190 pGradient = do
278301 else
279302 return (fromIntegral b1 - 32.0)
280303
304 ifFlag :: Bool -> Get a -> Get (Maybe a)
305 ifFlag True m = Just <$> m
306 ifFlag False _ = pure Nothing
307
281308 pShape :: Get Shape
282309 pShape = do
283310 sType <- getWord8
286313 shapeStyle <- StyleRef <$> get
287314 shapePaths <- getSeveral (PathRef <$> get)
288315 shapeFlags <- pShapeFlags
289 shapeTransform <-
290 if sfTransform shapeFlags
291 then Just <$> pMatrix
292 else return Nothing
316 shapeTransform <- ifFlag (sfTransform shapeFlags) $
317 pMatrix
318 shapeTranslate <- ifFlag (sfTranslation shapeFlags) $
319 Translation <$> pCoord <*> pCoord
320 shapeLodScale <- ifFlag (sfLodScale shapeFlags) $
321 pLodScale
322 shapeTransList <- getSeveral pTransformer
293323 return Shape { .. }
294324
295325 pShapeFlags :: Get ShapeFlags
323353 then return 0.0
324354 else castToFloat val
325355
326
327356 castToFloat :: Word32 -> Get Float
328357 castToFloat w32 =
329358 let bs = encode w32
330359 in case runGet getFloat32be bs of
331360 Left err -> fail err
332361 Right x -> return x
362
363 pLodScale :: Get LodScale
364 pLodScale = do
365 minS <- fromIntegral <$> getWord8
366 maxS <- fromIntegral <$> getWord8
367 return LodScale
368 { lsMin = minS / 63.75
369 , lsMax = maxS / 63.75
370 }
371
372 pTransformer :: Get Transformer
373 pTransformer = do
374 tType <- getWord8
375 case tType of
376 20 -> TransformerAffine <$> pMatrix
377 21 -> do
378 width <- fromIntegral <$> getWord8
379 lineJoin <- getWord8
380 miterLimit <- getWord8
381 return (TransformerContour (width - 128.0) lineJoin miterLimit)
382 22 -> pure TransformerPerspective
383 23 -> do
384 width <- fromIntegral <$> getWord8
385 lineOptions <- getWord8
386 miterLimit <- getWord8
387 let lineJoin = lineOptions .&. 15
388 lineCap = lineOptions `shift` 4
389 return (TransformerStroke (width - 128.0) lineJoin lineCap miterLimit)
390 _ -> fail ("Unknown transformer type: " ++ show tType)