gdritter repos hvif / 17a8bbd
Organized the HVIF module a bit more Getty Ritter 7 years ago
1 changed file(s) with 123 addition(s) and 93 deletion(s). Collapse all Expand all
+123
-93
Graphics/HVIF.hs less more
11 {-# LANGUAGE RecordWildCards #-}
22
3 module Graphics.HVIF where
3 module Graphics.HVIF
4 (
5 -- * Decoding
6 decodeFile
7 -- * Types
8 , HVIFFile(..)
9 -- ** Style Section
10 , Style(..)
11 , Gradient(..)
12 , GradientType(..)
13 , GradientFlags(..)
14 , GradientStop(..)
15 -- ** Paths Section
16 , Path(..)
17 , PathFlags(..)
18 , Point(..)
19 , Command(..)
20 -- ** Shape Section
21 , Shape(..)
22 , PathRef(..)
23 , StyleRef(..)
24 , ShapeFlags(..)
25 ) where
426
527 import Control.Monad (replicateM, when)
628 import Data.Bits ((.|.), (.&.), clearBit, shift, testBit)
729 import Data.ByteString (ByteString)
8 import Data.Sequence (Seq)
30 import Data.Sequence (Seq, (<|))
931 import qualified Data.Sequence as S
1032 import Data.Serialize
1133 import Data.Word
1840
1941 decodeFile :: ByteString -> Either String HVIFFile
2042 decodeFile = runGet pFile
43
44 instance Serialize HVIFFile where
45 get = pFile
46 put = error "[unfinished]"
47
48 -- Style Section
49
50 data Style
51 = ColorSolid Word8 Word8 Word8 Word8
52 | ColorGradient Gradient
53 | ColorSolidNoAlpha Word8 Word8 Word8
54 | ColorSolidGray Word8 Word8
55 | ColorSolidGrayNoAlpha Word8
56 deriving (Eq, Show)
57
58 data Gradient = Gradient
59 { gType :: GradientType
60 , gFlags :: GradientFlags
61 , gStops :: Seq GradientStop
62 } deriving (Eq, Show)
63
64 data GradientType
65 = GTLinear
66 | GTCircular
67 | GTDiamond
68 | GTConic
69 | GTXY
70 | GTSqrtXY
71 deriving (Eq, Show)
72
73 data GradientFlags = GradientFlags
74 { gfTransform :: Bool
75 , gfNoAlpha :: Bool
76 , gf16Bit :: Bool
77 , gfGrays :: Bool
78 } deriving (Eq, Show)
79
80 data GradientStop = GradientStop
81 { gsOffset :: Word8
82 , gsRed :: Word8
83 , gsGreen :: Word8
84 , gsBlue :: Word8
85 , gsAlpha :: Word8
86 } deriving (Eq, Show)
87
88 -- Path Section
89
90 data Path = Path
91 { pathFlags :: PathFlags
92 , pathPoints :: Seq Command
93 } deriving (Eq, Show)
94
95 data PathFlags = PathFlags
96 { pfClosed :: Bool
97 , pfUsesCommands :: Bool
98 , pfNoCurves :: Bool
99 } deriving (Eq, Show)
100
101 data Point = Point
102 { coordX :: Float
103 , coordY :: Float
104 } deriving (Eq, Show)
105
106 data Command
107 = CmdHLine Float
108 | CmdVLine Float
109 | CmdLine Point
110 | CmdCurve Point Point Point
111 deriving (Eq, Show)
112
113 -- Shape Section
114
115 data Shape = Shape
116 { shapeStyle :: StyleRef
117 , shapePaths :: Seq PathRef
118 , shapeFlags :: ShapeFlags
119 , shapeTransform :: Maybe Matrix
120 } deriving (Eq, Show)
121
122 type Matrix = Seq Float
123
124 newtype PathRef = PathRef { prIdx :: Word8 } deriving (Eq, Show)
125 newtype StyleRef = StyleRef { stIdx :: Word8 } deriving (Eq, Show)
126
127 data ShapeFlags = ShapeFlags
128 { sfTransform :: Bool
129 , sfHinting :: Bool
130 , sfLodScale :: Bool
131 , sfHasTransformers :: Bool
132 , sfTranslation :: Bool
133 } deriving (Eq, Show)
134
135 -- Decoding code
21136
22137 getSeveral :: Get a -> Get (Seq a)
23138 getSeveral getter = do
34149 hvifShapes <- getSeveral pShape
35150 return HVIFFile { .. }
36151
37 -- Style Section
38
39 data Style
40 = ColorSolid Word8 Word8 Word8 Word8
41 | ColorGradient Gradient
42 | ColorSolidNoAlpha Word8 Word8 Word8
43 | ColorSolidGray Word8 Word8
44 | ColorSolidGrayNoAlpha Word8
45 deriving (Eq, Show)
152 -- Style section
46153
47154 pStyle :: Get Style
48155 pStyle = do
55162 0x05 -> ColorSolidGrayNoAlpha <$> get
56163 _ -> fail "invalid"
57164
58
59 data Gradient = Gradient
60 { gType :: GradientType
61 , gFlags :: GradientFlags
62 , gStops :: Seq GradientStop
63 } deriving (Eq, Show)
64
65165 pGradient :: Get Gradient
66166 pGradient = do
67167 gType <- pGradientType
68168 gFlags <- pGradientFlags
69169 gStops <- getSeveral (pGradientStop gFlags)
70170 return Gradient { .. }
71
72 data GradientType
73 = GTLinear
74 | GTCircular
75 | GTDiamond
76 | GTConic
77 | GTXY
78 | GTSqrtXY
79 deriving (Eq, Show)
80171
81172 pGradientType :: Get GradientType
82173 pGradientType = do
90181 05 -> return GTSqrtXY
91182 _ -> fail ("Unknown gradient type: " ++ show gType)
92183
93
94 data GradientFlags = GradientFlags
95 { gfTransform :: Bool
96 , gfNoAlpha :: Bool
97 , gf16Bit :: Bool
98 , gfGrays :: Bool
99 } deriving (Eq, Show)
100
101184 pGradientFlags :: Get GradientFlags
102185 pGradientFlags = do
103186 gFlags <- getWord8
107190 , gf16Bit = testBit gFlags 3
108191 , gfGrays = testBit gFlags 4
109192 }
110
111 data GradientStop = GradientStop
112 { gsOffset :: Word8
113 , gsRed :: Word8
114 , gsGreen :: Word8
115 , gsBlue :: Word8
116 , gsAlpha :: Word8
117 } deriving (Eq, Show)
118193
119194 pGradientStop :: GradientFlags -> Get GradientStop
120195 pGradientStop flags = do
135210 else get
136211 return $ GradientStop offset r g b a
137212
138
139213 -- Path Section
140
141 data Path = Path
142 { pathFlags :: PathFlags
143 , pathPoints :: Seq Command
144 } deriving (Eq, Show)
145214
146215 pPath :: Get Path
147216 pPath = do
148217 pathFlags <- pPathFlags
149218 pathPoints <- pPoints pathFlags
150219 return Path { .. }
151
152 data PathFlags = PathFlags
153 { pfClosed :: Bool
154 , pfUsesCommands :: Bool
155 , pfNoCurves :: Bool
156 } deriving (Eq, Show)
157220
158221 pPathFlags :: Get PathFlags
159222 pPathFlags = do
163226 , pfUsesCommands = testBit pFlags 2
164227 , pfNoCurves = testBit pFlags 3
165228 }
166
167 data Point = Point
168 { coordX :: Float
169 , coordY :: Float
170 } deriving (Eq, Show)
171
172 data Command
173 = CmdHLine Float
174 | CmdVLine Float
175 | CmdLine Point
176 | CmdCurve Point Point Point
177 deriving (Eq, Show)
178229
179230 pPoints :: PathFlags -> Get (Seq Command)
180231 pPoints PathFlags { pfUsesCommands = False
206257 iIdx = (n `mod` 4) * 2
207258 in case (cmdBytes !! bIdx) `shift` (negate iIdx) .&. 0x03 of
208259 0x00 ->
209 (S.<|) <$> (CmdHLine <$> pCoord) <*> go (n+1)
260 (<|) <$> (CmdHLine <$> pCoord) <*> go (n+1)
210261 0x01 ->
211 (S.<|) <$> (CmdVLine <$> pCoord) <*> go (n+1)
262 (<|) <$> (CmdVLine <$> pCoord) <*> go (n+1)
212263 0x02 ->
213 (S.<|) <$> pLineCommand <*> go (n+1)
264 (<|) <$> pLineCommand <*> go (n+1)
214265 0x03 ->
215 (S.<|) <$> pCurveCommand <*> go (n+1)
266 (<|) <$> pCurveCommand <*> go (n+1)
216267 _ -> error "[unreachable]"
217268 go 0
218269
225276 return (fromIntegral cVal / 102.0 - 128.0)
226277 else
227278 return (fromIntegral b1 - 32.0)
228
229 -- Shape Section
230
231 data Shape = Shape
232 { shapeStyle :: StyleRef
233 , shapePaths :: Seq PathRef
234 , shapeFlags :: ShapeFlags
235 , shapeTransform :: Maybe Matrix
236 } deriving (Eq, Show)
237
238 type Matrix = Seq Float
239279
240280 pShape :: Get Shape
241281 pShape = do
251291 else return Nothing
252292 return Shape { .. }
253293
254 newtype PathRef = PathRef { prIdx :: Word8 } deriving (Eq, Show)
255 newtype StyleRef = StyleRef { stIdx :: Word8 } deriving (Eq, Show)
256
257 data ShapeFlags = ShapeFlags
258 { sfTransform :: Bool
259 , sfHinting :: Bool
260 , sfLodScale :: Bool
261 , sfHasTransformers :: Bool
262 , sfTranslation :: Bool
263 } deriving (Eq, Show)
264
265294 pShapeFlags :: Get ShapeFlags
266295 pShapeFlags = do
267296 sFlags <- getWord8
276305 pMatrix :: Get Matrix
277306 pMatrix = S.fromList `fmap` replicateM 6 pFloat
278307
308 -- XXX Actually parse 24-bit floats right
279309 pFloat :: Get Float
280310 pFloat = do
281311 _ <- getWord8