gdritter repos hvif / 5bf503e
Better SVG converter, a few fixes to actual parser Getty Ritter 8 years ago
2 changed file(s) with 84 addition(s) and 20 deletion(s). Collapse all Expand all
+7
-5
Graphics/HVIF.hs less more
128128
129129 type Matrix = Seq Float
130130
131 newtype PathRef = PathRef { prIdx :: Word8 } deriving (Eq, Show)
132 newtype StyleRef = StyleRef { stIdx :: Word8 } deriving (Eq, Show)
131 newtype PathRef = PathRef { prIdx :: Int } deriving (Eq, Show)
132 newtype StyleRef = StyleRef { stIdx :: Int } deriving (Eq, Show)
133133
134134 data ShapeFlags = ShapeFlags
135135 { sfTransform :: Bool
310310 sType <- getWord8
311311 when (sType /= 0x0a) $
312312 fail ("Unknown shape type: " ++ show sType)
313 shapeStyle <- StyleRef <$> get
314 shapePaths <- getSeveral (PathRef <$> get)
313 shapeStyle <- StyleRef . fromIntegral <$> getWord8
314 shapePaths <- getSeveral ((PathRef . fromIntegral) <$> getWord8)
315315 shapeFlags <- pShapeFlags
316316 shapeTransform <- ifFlag (sfTransform shapeFlags) $
317317 pMatrix
319319 Translation <$> pCoord <*> pCoord
320320 shapeLodScale <- ifFlag (sfLodScale shapeFlags) $
321321 pLodScale
322 shapeTransList <- getSeveral pTransformer
322 shapeTransList <- if (sfHasTransformers shapeFlags)
323 then getSeveral pTransformer
324 else return S.empty
323325 return Shape { .. }
324326
325327 pShapeFlags :: Get ShapeFlags
+77
-15
hvif2svg/Main.hs less more
11 {-# LANGUAGE PatternGuards #-}
2 {-# LANGUAGE ViewPatterns #-}
3 {-# LANGUAGE ParallelListComp #-}
24
35 module Main where
46
57 import Control.Monad (forM_)
68 import qualified Data.ByteString as BS
9 import Data.Foldable (toList)
710 import Data.Sequence (Seq, ViewL(..))
811 import qualified Data.Sequence as S
912 import Graphics.HVIF
1518 Left err -> putStrLn err
1619 Right hvif -> do
1720 putStrLn "<svg width=\"200\" height=\"200\" xmlns=\"http://www.w3.org/2000/svg\">"
18 forM_ (hvifPaths hvif) $ \path -> do
21 putStrLn "<defs>"
22 forM_ [ (i, c) | i <- [0..]
23 | c <- toList (hvifColors hvif) ] $ \ (idx, style) ->
24 case style of
25 ColorGradient g -> printGradient idx g
26 _ -> return ()
27 putStrLn "</defs>"
28 forM_ (hvifShapes hvif) $ \shape -> do
1929 putStr "<path d=\""
20 drawPoints True 0.0 0.0 (pathPoints path)
21 putStrLn "stroke=\"black\"/>"
30 let paths = [ hvifPaths hvif `S.index` p
31 | PathRef p <- toList (shapePaths shape)
32 ]
33 let tr = case shapeTransform shape of
34 Just m -> transform m
35 Nothing -> id
36 mapM_ (drawPoints True 0.0 0.0 tr . pathPoints) paths
37 putStr "fill=\""
38 let styleId = stIdx (shapeStyle shape)
39 drawStyle styleId (hvifColors hvif `S.index` stIdx (shapeStyle shape))
40 putStrLn "\"/>"
2241 putStrLn "</svg>"
2342
24 drawPoints :: Bool -> Float -> Float -> Seq Command -> IO ()
25 drawPoints first lx ly seq
43 percent :: Integral a => a -> String
44 percent n = show (floor ((fromIntegral n / 255.0) * 100.0 :: Float))
45
46 printGradient :: Int -> Gradient -> IO ()
47 printGradient n g = do
48 let gname = "grad" ++ show n
49 putStrLn ("<linearGradient id=\"" ++ gname ++
50 "\" x1=\"100%\" y1=\"0%\" x2=\"0%\" y2=\"100%\">")
51 forM_ (gStops g) $ \ (GradientStop off r g b a) -> do
52 putStrLn $ concat [ "<stop offset=\""
53 , percent off
54 , "%\" stop-color=\"rgba("
55 , show r
56 , ","
57 , show g
58 , ","
59 , show b
60 , ","
61 , show (fromIntegral a / 255.0)
62 , ")\"/>"
63 ]
64 putStrLn "</linearGradient>"
65
66 type Transformer = (Float, Float) -> (Float, Float)
67
68 drawPoints :: Bool -> Float -> Float -> Transformer -> Seq Command -> IO ()
69 drawPoints first lx ly tr seq
2670 | cmd :< xs <- S.viewl seq = do
27 let dir = if first then "M" else "L"
71 let dir = if first then "M" else " L"
72 showPt x y = do
73 let (x', y') = tr (x, y)
74 putStr $ unwords [dir, show (floor x'), show (floor y')]
2875 case cmd of
2976 CmdLine (Point x y) -> do
30 putStr $ unwords [dir, show (floor x), show (floor y)]
31 drawPoints False x y xs
77 showPt x y
78 drawPoints False x y tr xs
3279 CmdHLine x -> do
33 putStr $ unwords [dir, show (floor x), show (floor ly)]
34 drawPoints False x ly xs
80 showPt x ly
81 drawPoints False x ly tr xs
3582 CmdVLine y -> do
36 putStr $ unwords [dir, show (floor lx), show (floor y)]
37 drawPoints False lx y xs
83 showPt lx y
84 drawPoints False lx y tr xs
3885 CmdCurve (Point x y) _ _ -> do
39 putStr $ unwords [dir, show (floor x), show (floor y)]
40 drawPoints False x y xs
41 | otherwise = putStr "Z\" "
86 showPt x y
87 drawPoints False x y tr xs
88 | otherwise = putStr " Z\" "
89
90 transform :: Seq Float -> (Float, Float) -> (Float, Float)
91 transform (toList-> [m0,m1,m2,m3,m4,m5]) (x, y) =
92 (x * m0 + y * m2 + m4, x * m1 + y * m3 + m5)
93
94 drawStyle :: Int -> Style -> IO ()
95 drawStyle _ (ColorSolid r g b a) = putStr $ concat
96 ["rgba(", show r, ",", show g, ",", show b, ",", show (fromIntegral a / 255.0), ")"]
97 drawStyle _ (ColorSolidNoAlpha r g b) = putStr $ concat
98 ["rgb(", show r, ",", show g, ",", show b, ")"]
99 drawStyle _ (ColorSolidGray g a) = putStr $ concat
100 ["rgba(", show g, ",", show g, ",", show g, ",", show (fromIntegral a / 255.0), ")"]
101 drawStyle _ (ColorSolidGrayNoAlpha g) = putStr $ concat
102 ["rgb(", show g, ",", show g, ",", show g, ")"]
103 drawStyle n _ = putStr ("url(#grad" ++ show n ++ ")")