gdritter repos hvif / 4959f25
HVIF parser almost minimally done Still needs sections that don't appear in the sample file, more stress-testing, and actual parsing of 24-bit floats. Getty Ritter 7 years ago
1 changed file(s) with 71 addition(s) and 12 deletion(s). Collapse all Expand all
+71
-12
Graphics/HVIF.hs less more
33 module Graphics.HVIF where
44
55 import Control.Monad (replicateM, when)
6 import Data.Bits ((.|.), clearBit, shift, testBit)
6 import Data.Bits ((.|.), (.&.), clearBit, shift, testBit)
77 import Data.ByteString (ByteString)
88 import Data.Sequence (Seq)
99 import qualified Data.Sequence as S
140140
141141 data Path = Path
142142 { pathFlags :: PathFlags
143 , pathPoints :: Seq Point
143 , pathPoints :: Seq Command
144144 } deriving (Eq, Show)
145145
146146 pPath :: Get Path
169169 , coordY :: Float
170170 } deriving (Eq, Show)
171171
172 pPoints :: PathFlags -> Get (Seq Point)
173 pPoints PathFlags { pfUsesCommands = False } =
174 getSeveral (Point <$> pCoord <*> pCoord)
175 pPoints PathFlags { pfUsesCommands = True } = do
176 c1 <- getWord8
177 c2 <- getWord8
178 return $ S.empty
172 data Command
173 = CmdHLine Float
174 | CmdVLine Float
175 | CmdLine Point
176 | CmdCurve Point Point Point
177 deriving (Eq, Show)
178
179 pPoints :: PathFlags -> Get (Seq Command)
180 pPoints PathFlags { pfUsesCommands = False
181 , pfNoCurves = False } =
182 getSeveral pCurveCommand
183 pPoints PathFlags { pfUsesCommands = False
184 , pfNoCurves = True } =
185 getSeveral pLineCommand
186 pPoints PathFlags { pfUsesCommands = True } =
187 pCommandList
188
189 pLineCommand :: Get Command
190 pLineCommand = CmdLine <$> (Point <$> pCoord <*> pCoord)
191
192 pCurveCommand :: Get Command
193 pCurveCommand = CmdCurve <$> (Point <$> pCoord <*> pCoord)
194 <*> (Point <$> pCoord <*> pCoord)
195 <*> (Point <$> pCoord <*> pCoord)
196
197 pCommandList :: Get (Seq Command)
198 pCommandList = do
199 pointCount <- getWord8
200 let cmdByteCount = (pointCount + 3) `div` 4
201 cmdBytes <- replicateM (fromIntegral cmdByteCount) getWord8
202 let go n
203 | n == fromIntegral pointCount = return S.empty
204 | otherwise =
205 let bIdx = n `div` 4
206 iIdx = (n `mod` 4) * 2
207 in case (cmdBytes !! bIdx) `shift` (negate iIdx) .&. 0x03 of
208 0x00 ->
209 (S.<|) <$> (CmdHLine <$> pCoord) <*> go (n+1)
210 0x01 ->
211 (S.<|) <$> (CmdVLine <$> pCoord) <*> go (n+1)
212 0x02 ->
213 (S.<|) <$> pLineCommand <*> go (n+1)
214 0x03 ->
215 (S.<|) <$> pCurveCommand <*> go (n+1)
216 _ -> error "[unreachable]"
217 go 0
179218
180219 pCoord :: Get Float
181220 pCoord = do
182221 b1 <- getWord8
183222 if testBit b1 7 then do
184223 b2 <- getWord8
185 let cVal :: Word16 = (clearBit 7 (fromIntegral b1) `shift` 8) .|. fromIntegral b2
186 return ((fromIntegral cVal / 102.0) - 128.0)
224 let cVal :: Word16 = (clearBit (fromIntegral b1) 7 `shift` 8) .|. fromIntegral b2
225 return (fromIntegral cVal / 102.0 - 128.0)
187226 else
188227 return (fromIntegral b1 - 32.0)
189228
193232 { shapeStyle :: StyleRef
194233 , shapePaths :: Seq PathRef
195234 , shapeFlags :: ShapeFlags
196 } deriving (Eq, Show)
235 , shapeTransform :: Maybe Matrix
236 } deriving (Eq, Show)
237
238 type Matrix = Seq Float
197239
198240 pShape :: Get Shape
199241 pShape = do
242 sType <- getWord8
243 when (sType /= 0x0a) $
244 fail ("Unknown shape type: " ++ show sType)
200245 shapeStyle <- StyleRef <$> get
201246 shapePaths <- getSeveral (PathRef <$> get)
202247 shapeFlags <- pShapeFlags
248 shapeTransform <-
249 if sfTransform shapeFlags
250 then Just <$> pMatrix
251 else return Nothing
203252 return Shape { .. }
204253
205254 newtype PathRef = PathRef { prIdx :: Word8 } deriving (Eq, Show)
223272 , sfHasTransformers = testBit sFlags 4
224273 , sfTranslation = testBit sFlags 5
225274 }
275
276 pMatrix :: Get Matrix
277 pMatrix = S.fromList `fmap` replicateM 6 pFloat
278
279 pFloat :: Get Float
280 pFloat = do
281 _ <- getWord8
282 _ <- getWord8
283 _ <- getWord8
284 return 0.0