svg2q (empty) → 0.3.1
raw patch · 14 files changed
+1747/−0 lines, 14 filesdep +basedep +haskell98dep +language-csetup-changed
Dependencies added: base, haskell98, language-c, pretty, svgutils, syb, xml
Files
- Color.hs +217/−0
- Helpers.hs +36/−0
- Output.hs +99/−0
- PathCommand.hs +119/−0
- Point.hs +38/−0
- Setup.hs +2/−0
- TextElement.hs +16/−0
- Translate.hs +632/−0
- Types.hs +103/−0
- license.txt +10/−0
- main.hs +190/−0
- svg2q.cabal +21/−0
- svg2q.h +117/−0
- svg2q.m +147/−0
+ Color.hs view
@@ -0,0 +1,217 @@+module Color where++import Numeric (readHex)+import Debug.Trace (trace)+import Helpers (clean, split, replace)++data Color = Color {+ red :: Float+ , green :: Float+ , blue :: Float+ }+ deriving (Show, Eq)+++-- reads the supplied string and returns the contained color, if there is any. +getColor :: Maybe String -> Maybe Color+getColor Nothing = getColor (Just "")+getColor (Just s) =+ case s of+ '#':hr:hg:hb:[] -> colorFromHexStrings [hr, hr] [hg, hg] [hb, hb]+ '#':hr1:hr2:hg1:hg2:hb1:hb2:[] -> + colorFromHexStrings [hr1, hr2] [hg1, hg2] [hb1, hb2]+ "" -> trace "Warning: No valid color supplied where expected.\+ \ Falling back to black." rgb 0 0 0+ 'r':'g':'b':'(':xs -> decrgb xs+ _:_ -> colorFromLiteralString s+ ++-- gets 3 strings, representing hex-values of red, green and blue.+-- returns a color, if the values are between 0-255+colorFromHexStrings :: String -> String -> String -> Maybe Color+colorFromHexStrings hr hg hb = let+ dr = fst (head (readHex hr))::Float+ dg = fst (head (readHex hg))::Float+ db = fst (head (readHex hb)):: Float+ in+ rgb dr dg db+++-- strings to Maybe Color. +-- strings recognized: http://www.w3.org/TR/SVG/types.html#ColorKeywords+-- strings are matched in alphabetical order. +-- runtime is probably not that important to optimize+colorFromLiteralString :: String -> Maybe Color+colorFromLiteralString s = case clean s of+ "acliceblue" -> rgb 240 248 255+ "antiquewhite" -> rgb 250 235 215+ "aqua" -> rgb 0 255 255+ "aquamarine" -> rgb 127 255 212+ "azure" -> rgb 240 255 255+ "beige" -> rgb 245 245 220+ "bisque" -> rgb 255 228 196+ "black" -> rgb 0 0 0+ "blancheldalmond" -> rgb 255 235 205+ "blue" -> rgb 0 0 255+ "blueviolet" -> rgb 138 43 226+ "brown" -> rgb 165 42 42+ "burlywood" -> rgb 222 184 135+ "cadetblue" -> rgb 95 158 160+ "charteuse" -> rgb 127 255 0+ "chocolate" -> rgb 210 105 30+ "coral"-> rgb 255 127 80+ "cornflowerblue" -> rgb 100 149 237+ "cornsilk" -> rgb 255 248 220+ "crimson" -> rgb 220 20 60+ "cyan" -> rgb 0 255 255+ "darkblue" -> rgb 0 0 139+ "darkcyan" -> rgb 0 139 139+ "darkgoldenrod" -> rgb 184 134 11+ "darkgray" -> rgb 169 169 169+ "darkgreen" -> rgb 0 100 0+ "darkgrey" -> rgb 169 169 169+ "darkkhaki" -> rgb 189 183 107+ "darkmagenta" -> rgb 139 0 139+ "darkolivegreen" -> rgb 85 107 47+ "darkorange" -> rgb 255 140 0+ "darkorchid" -> rgb 153 50 204+ "darkred" -> rgb 139 0 0+ "darksalmin" -> rgb 233 150 122+ "darkseagreen" -> rgb 143 188 143+ "darkslateblue" -> rgb 72 61 139+ "darkslategray" -> rgb 47 79 79+ "darkslategrey" -> rgb 47 79 79+ "darkturquoise" -> rgb 0 206 209+ "darkviolet" -> rgb 148 0 211+ "deeppink" -> rgb 255 20 147+ "deepskyblue" -> rgb 0 191 255+ "dimgray" -> rgb 105 105 105+ "dimgrey" -> rgb 105 105 105+ "dodgerblue" -> rgb 30 144 255+ "firebrick" -> rgb 178 34 34+ "floralwhite" -> rgb 255 250 240+ "forestgreen" -> rgb 34 139 34+ "fuchsia" -> rgb 255 0 255+ "gainsboro" -> rgb 220 220 220+ "ghostwhite" -> rgb 248 248 255+ "gold" -> rgb 255 215 0+ "goldenrod" -> rgb 218 165 32+ "gray" -> rgb 128 128 128+ "grey" -> rgb 128 128 128+ "green" -> rgb 0 128 0+ "greenyellow" -> rgb 173 255 47+ "honeydew" -> rgb 240 255 240+ "hotpink" -> rgb 255 105 180+ "indianred" -> rgb 205 92 92+ "indigo" -> rgb 75 0 130+ "ivory" -> rgb 255 255 240+ "khaki" -> rgb 240 230 140+ "lavender" -> rgb 230 230 250+ "lavenderblush" -> rgb 255 240 245+ "lawngreen" -> rgb 124 252 0+ "lemonchiffon" -> rgb 255 250 205+ "lightblue" -> rgb 173 216 230+ "lightcoral" -> rgb 240 128 128+ "lightcyan" -> rgb 224 255 255+ "lightgoldenrodyellow" -> rgb 250 250 210+ "lightgray" -> rgb 211 211 211+ "lightgreen" -> rgb 144 238 144+ "lightgrey" -> rgb 211 211 211+ "lightpink" -> rgb 255 182 193+ "lightsalmon" -> rgb 255 160 122+ "lightseagreen" -> rgb 32 178 170+ "lightskyblue" -> rgb 135 206 250+ "lightslategray" -> rgb 119 136 153+ "lightslategrey" -> rgb 119 136 153+ "lightsteelblue" -> rgb 176 196 222+ "lightyellow" -> rgb 255 255 224+ "lime" -> rgb 0 255 0+ "limegreen" -> rgb 50 205 50+ "linen" -> rgb 250 240 230+ "magenta" -> rgb 255 0 255+ "maroon" -> rgb 128 0 0+ "mediumaquamarine" -> rgb 102 205 170+ "mediumblue" -> rgb 0 0 205+ "mediumorchid" -> rgb 186 85 211+ "mediumpurple" -> rgb 147 112 219+ "mediumseagreen" -> rgb 60 179 113+ "mediumslateblue" -> rgb 123 104 238+ "mediumspringgreen" -> rgb 0 250 154+ "mediumturquoise" -> rgb 72 209 204+ "mediumvoiletred" -> rgb 199 21 133+ "midnightblue" -> rgb 25 25 112+ "mintcream" -> rgb 245 255 250+ "mistyrose" -> rgb 255 228 225+ "moccasin" -> rgb 255 228 181+ "najavowhite" -> rgb 255 222 173+ "navy" -> rgb 0 0 128+ "oldlace" -> rgb 253 245 230+ "olive" -> rgb 128 128 0+ "olivedrab" -> rgb 107 142 35+ "orange" -> rgb 255 165 0+ "orangered" -> rgb 255 69 9+ "orchid" -> rgb 218 112 214+ "palegoldenrod" -> rgb 238 232 170+ "palegreen" -> rgb 152 251 152+ "paleturquoise" -> rgb 175 238 238+ "palevioletred" -> rgb 219 112 147+ "papayawhip" -> rgb 255 239 213+ "peachpuff" -> rgb 255 218 185+ "peru" -> rgb 205 133 63+ "pink" -> rgb 255 192 203+ "plum" -> rgb 221 160 221+ "powderblue" -> rgb 176 224 230+ "purple" -> rgb 128 0 128+ "red" -> rgb 255 0 0+ "rosybrown" -> rgb 188 143 143+ "royalblue" -> rgb 65 105 225+ "saddlebrown" -> rgb 139 69 19+ "salmon" -> rgb 250 128 114+ "sandybrown" -> rgb 244 164 96+ "seagreen" -> rgb 46 139 87+ "seashell" -> rgb 255 245 238+ "sienna" -> rgb 160 82 45+ "silver" -> rgb 192 192 192+ "skyblue" -> rgb 135 206 235+ "slateblue" -> rgb 106 90 205+ "slategray" -> rgb 112 128 144+ "slategrey" -> rgb 112 128 144+ "snow" -> rgb 255 250 250+ "springgreen" -> rgb 0 255 127+ "steelblue" -> rgb 70 130 180+ "tan" -> rgb 210 180 140+ "teal" -> rgb 0 128 128+ "thistle" -> rgb 216 191 216+ "tomato" -> rgb 255 99 71+ "turquoise" -> rgb 64 224 208+ "violet" -> rgb 238 130 238+ "wheat" -> rgb 245 222 179+ "white" -> rgb 255 255 255+ "whitesmoke" -> rgb 245 245 245+ "yellow" -> rgb 255 255 0+ "yellowgreen" -> rgb 154 205 50 + "none" -> Nothing + _ -> trace ("Warning: couldn't match \+ \ color \""++s++"\".\+ \ Falling back to black.") rgb 0 0 0+++-- creates Just Color from rgb-values in range 0-255, Nothing otherwise.+rgb :: Float -> Float -> Float -> Maybe Color+rgb r g b+ | all (`elem` [0 .. 255]) [r, g, b] = Just (Color (r/255) (g/255) (b/255)) + | otherwise = getColor (Just "")++decrgb :: String -> Maybe Color+decrgb "" = getColor (Just "")+decrgb s = let xs = map (read.clean) + (split " " + (replace (replace s + ","+ " ")+ ")"+ ""))+ in if length xs >= 3+ then rgb (head xs) (xs!!1) (xs!!2)+ else decrgb ""+
+ Helpers.hs view
@@ -0,0 +1,36 @@+module Helpers where+import Data.List (groupBy)+import Data.Char (isSpace)++-- splits a string into a list of strings+-- split "," "a,b" = ["a", "b"]+split :: String -> String -> [String]+split "" _ = error "empty delemiter."+split d s = let f = (== head d)+ in (filter (/= d)+ (groupBy (\x y -> f x == f y)+ s))++-- replace. we sometimes need to replace stuff.+-- replace "hut" "u" "a" = "hat"+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace [] _ _ = []+replace s find repl =+ if take (length find) s == find+ then repl ++ replace (drop (length find) s) find repl+ else head s : replace (tail s) find repl+++-- removes whitespaces+clean :: String -> String+clean = filter (not . isSpace)++++-- determines, if a String represents a Float.+isFloat :: String -> Bool+isFloat s = let rds = reads s::[(Float, String)]+ in+ if rds == []+ then False+ else snd (head rds) == ""
+ Output.hs view
@@ -0,0 +1,99 @@+module Output where++import Types+import Translate (prettyCode, mkInitVals, codeString, mkAllocs, varNames, mkMember)+import Data.Maybe (mapMaybe, catMaybes)++mkImplementation :: [Maybe GraphicsElement] -> String -> IO ()+mkImplementation graphics file =+ let cl = mapMaybe codeString (catMaybes graphics)+ code = foldl (++) "" cl+ con = imFileStart file graphics+ ++ drawRect code+ ++ imDealloc (catMaybes graphics)+ ++ imFileEnd+ in+ writeFile (file++".m") (fileHeader++"\n\n"++con)++mkHeader :: [Maybe GraphicsElement] -> String -> IO ()+mkHeader graphics file =+ writeFile (file++".h") (hFileStart file+ ++ hMembers graphics ++ "\n}\n"+ ++ hProperties graphics + ++ hFileEnd)++fileHeader :: String+fileHeader = "/* This file is generated using svg2q v.0.3.1.\n\+ \\tPlease feel free to report any bugs. */\n\n\n"+++imInit :: [Maybe GraphicsElement] -> String+imInit ge = let b = mapMaybe mkInitVals (catMaybes ge)+ a = foldl (++) "" (mapMaybe mkAllocs (catMaybes ge))+ in+ a ++ prettyCode b++imFileStart :: String -> [Maybe GraphicsElement] -> String+imFileStart file graphics= + "#include \""++file++".h\"\n\n\+ \@implementation "++file++"\n\n"+++ imSynths (mapMaybe varNames (catMaybes graphics)) ++"\n\n\+ \- (id)init {\+ \\n\tself = [super initWithFrame:[self frame]];\+ \\n\t if (self) {\+ \\n\t\t // init code.\n\+ \\t\t self.scaleFactor = 1;\n"+++ imInit graphics +++ "\n\t}\+ \\n\treturn self;\+ \\n}\n\n"++imDealloc :: [GraphicsElement] -> String+imDealloc xs = let vn = mapMaybe varNames xs+ rl = foldl (\x y -> x++"\t["++y++" release];\n") "" vn+ in "-(void) dealloc {\n"++rl+++ "\t[super dealloc];\n}"+++imFileEnd :: String+imFileEnd = "\n\n@end\n"++drawRect :: String -> String+drawRect c = "- (void) drawRect: (CGRect) rect {\n\+ \\tCGContextRef context = UIGraphicsGetCurrentContext();\n\+ \\tCGContextScaleCTM(context, scaleFactor, scaleFactor);\n"+ ++ c ++ "}\n\n"++imSynths :: [String] -> String+imSynths = foldr (\y x -> x++"@synthesize "++y++";\n") "@synthesize scaleFactor;\n"++hFileStart :: String -> String+hFileStart file = fileHeader+++ "#import \"svg2q.h\";\n\+ \#import <UIKit/UIKit.h>;\n\n\+ \@interface "++file++" : UIView {\n"+++hFileEnd :: String+hFileEnd = "\n\n@end\n"++hProperties :: [Maybe GraphicsElement] -> String+hProperties xs = let m = (mapMaybe mkMember (catMaybes xs))+ pl = map hProp m+ in foldl (++)+ "\t@property(nonatomic, assign)\tfloat scaleFactor;\n"+ pl++hProp :: String -> String+hProp s = "\t@property(nonatomic, retain) "++s++hMem :: String -> String+hMem x= "\t"++x++";\n"++hMembers :: [Maybe GraphicsElement] -> String+hMembers xs = foldl (++) "float scaleFactor;\n" (mapMaybe mkMember (catMaybes xs))++imScale :: String+imScale = "- (void) redraw {\+ \\n\t[self setNeedsDisplay];\+ \\n}\n\n"
+ PathCommand.hs view
@@ -0,0 +1,119 @@+module PathCommand where++import Point+import Data.List(groupBy)+import Helpers (replace,isFloat)+import Debug.Trace(trace)+++type Command = Char+type Angle = Double++data PathCommand = + PathClosePath + | PathMoveTo {+ pMoveTo :: Point+ }+ | PathLineTo {+ pLineTo :: Point+ }+ | PathHLineTo {+ pHLineTo :: Float+ }+ | PathVLineTo {+ pVLineTo :: Float+ }+ | PathCurveTo {+ pCurveToC1 :: Point+ , pCurveToC2 :: Point+ , pCurveTo :: Point+ }+ | PathShorthandCurveTo {+ pCurveToC2 :: Point+ , pCurveTo :: Point+ }+ | PathQuadraticCurveTo {+ pCurveToC :: Point+ , pCurveTo :: Point+ }+ | PathShorthandQuadraticCurveTo {+ pCurveTo :: Point+ }+ | PathEllipticalArc {+ pArcRX :: Float+ , pArcRY :: Float+ , pArcxRotation :: Angle+ , pArcLargeArcFlag :: Bool+ , pArcSweepFlag :: Bool+ , pArcTo :: Point+ }+ | PathNothingYet+ deriving (Show, Eq)+++-- inserts spaces after each path-command-character+sanatize :: String -> String+sanatize s = + let+ helper r "" = r+ helper r (x:xs) = + if x `elem` "MmZzLlHhVvCcSsQqTtAa"+ then helper (r ++ (' ':x:" ")) xs+ else helper (r ++ (x:"")) xs+ in+ helper "" (replace s "," " ")++createPathCommands:: Maybe String -> [PathCommand]+createPathCommands Nothing = trace "Warning: createPathCommands got\+ \ Nothing. Returning empty list" []+createPathCommands (Just s) = let x = createCmdAndArgList (words (sanatize s))+ cpch [] = []+ cpch input@(((x':_):_):[]) = + if x' `elem` "Zz"+ then [[PathClosePath]]+ else error ("Other command than\+ \ \"Z\" supplied \+ \with no arguments\+ \ in Path:"++show input)+ cpch ((x':_):args:xs) = createCmds x' args:cpch xs+ cpch _ = error ("this shouldn't happen. cpch did\+ \not pattern match.\n\+ \Please report a bug.")+ pc = concat (cpch x)+ in optimizePath (head pc) pc ++createCmds :: String -> [String] -> [PathCommand]+createCmds _ [] = []+createCmds s@(c:_) (a0:as)+ | c =='H' = PathHLineTo (read a0):createCmds s as+ | c == 'V' = PathVLineTo (read a0):createCmds s as+createCmds s@(c:_) (a0:a1:as)+ | c == 'M' = PathMoveTo (Point (read a0) (read a1)):createCmds s as+ | c == 'L' = PathLineTo (Point (read a0) (read a1)):createCmds s as+ | c == 'T' = PathShorthandQuadraticCurveTo (Point (read a0) (read a1)):createCmds s as+createCmds s@(c:_) (a0:a1:a2:a3:as)+ | c == 'S' = PathShorthandCurveTo (Point (read a0) (read a1)) (Point (read a2) (read a3)):createCmds s as+ | c == 'Q' = PathQuadraticCurveTo (Point (read a0) (read a1)) (Point (read a2) (read a3)):createCmds s as+createCmds s@(c:_) (a0:a1:a2:a3:a4:a5:as)+ | c == 'C' = PathCurveTo (Point (read a0) (read a1)) (Point (read a2) (read a3)) (Point (read a4) (read a5)):createCmds s as +-- todo: createCmds s@(c:_) (a0:a1:a2:a3:a4:a5:a6:as)+createCmds s@(c:_) (_:_:_:_:_:_:_:_:as)+ | c == 'A' = PathNothingYet:createCmds s as++createCmds s l = error $ "createCmd: Nothing \+ \ matched for createCmds "++s++" "++show l++createCmdAndArgList :: [String] -> [[String]]+createCmdAndArgList = groupBy (\x y -> isFloat x == isFloat y)++ +optimizePath :: PathCommand -> [PathCommand] -> [PathCommand]+optimizePath _ (x:[]) = [x]+optimizePath _ [] = []+optimizePath c (PathMoveTo _:PathMoveTo x1: xs) = + optimizePath c (PathMoveTo x1:xs)+optimizePath c (x@(PathCurveTo _ c2 p1):PathShorthandCurveTo sc2 sp1:xs) =+ x : optimizePath c (PathCurveTo (reflect c2 p1) sc2 sp1:xs)+optimizePath c (x@(PathQuadraticCurveTo c0 p0):PathShorthandQuadraticCurveTo p1:xs) =+ x : optimizePath c (PathQuadraticCurveTo (reflect c0 p0) p1:xs)+optimizePath c (x:xs) = x : optimizePath c xs
+ Point.hs view
@@ -0,0 +1,38 @@+module Point where++import Helpers (replace)+import Debug.Trace (trace)++data Point = Point {+ xCood :: Float+ , yCood :: Float+ }+ deriving (Show, Eq)++-- reads a string and returns a list of points. +-- If the string contains non-parsable+-- characters, read will throw an "no parse"-exception. +-- if the count of numbers in the string+-- is odd, we will break down with an exception showing the supplied string.+getPoints :: Maybe String -> [Point]+getPoints Nothing = trace "Warning: getPoints got Nothing. \+ \Returning an empty list." []+getPoints (Just s) = + let + sl = words $ replace s "," " "+ readPoints [] pl = pl+ readPoints xs pl = + readPoints (drop 2 xs) (pl ++ [Point (read (head xs)) (read (xs !! 1))])+ in+ if odd (length sl)+ then error ("odd count of coordinates. got string: "++s)+ else readPoints sl []+++-- reflects a point relative to another point +reflect :: Point -> Point -> Point+reflect (Point x y) (Point cx cy) = + let dx = cx -x+ dy = cy -y+ in+ (Point (cx+dx) (cy+dy))
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TextElement.hs view
@@ -0,0 +1,16 @@+module TextElement where++import Point+import Color++data TextElement =+ TextElem {+ content :: String+ , fontSize :: Float+ , font :: Maybe String+ , start :: Point+ , strokeColor :: Maybe Color+ , strokeWidth :: Float+ , fillColor :: Maybe Color+ }+ deriving (Eq, Show)
+ Translate.hs view
@@ -0,0 +1,632 @@+module Translate where++import Language.C.Data.Ident+import Language.C.Data.Node+import Language.C.Data.Position+import Language.C.Syntax.AST+import Language.C.Pretty+import Types hiding (strokeWidth)+import Debug.Trace (trace)+import Color+import Data.Maybe (mapMaybe,fromJust,catMaybes)+import Data.Char (toLower)+import Prelude hiding (id)+import Point+import PathCommand+import TextElement++noNodeInfo :: NodeInfo+noNodeInfo = OnlyPos (Position "nopos" 0 0)++noIdent :: Ident+noIdent = Ident "" 0 noNodeInfo+++-- pretty prints a list of CBlockItems+printCode :: [CBlockItem] -> IO()+printCode l= let mpaa "" p = (show.pretty) p+ mpaa s p = s ++ "\n" ++ (show.pretty) p+ string = foldl mpaa "" l+ in putStrLn string+++-- creates code for color of name s representing Color c.+colorSetup :: String -> Maybe Color -> [CBlockItem]+colorSetup _ Nothing = []+colorSetup s (Just c) = let + inits = map CBlockDecl + [cDecl "CGColorSpaceRef" (s++"Colorspace"), + cDecl "CGColorRef" (s++"Color"), + cDecl "CGFloat" (s++"ColorComponents[4]")]+ assigns = + [assign (var (s++"Colorspace")) (call "CGColorSpaceCreateDeviceRGB" []),+ assign (var (s++"ColorComponents[0]"))+ (var (show (red c))),+ assign (var (s++"ColorComponents[1]"))+ (var (show (green c))),+ assign (var (s++"ColorComponents[2]"))+ (var (show (blue c))),+ assign (var (s++"ColorComponents[3]"))+ (var "1"), + assign (var (s++"Color"))+ (call "CGColorCreate" [s++"Colorspace", s++"ColorComponents"])]+ in+ inits++assigns+transparentSetup :: String -> [CBlockItem]+transparentSetup s= let + inits = map CBlockDecl + [cDecl "CGColorSpaceRef" (s++"Colorspace"), + cDecl "CGColorRef" (s++"Color"), + cDecl "CGFloat" (s++"ColorComponents[4]")]+ assigns = + [assign (var (s++"Colorspace")) (call "CGColorSpaceCreateDeviceRGB" []),+ assign (var (s++"ColorComponents[0]"))+ (var "0"),+ assign (var (s++"ColorComponents[1]"))+ (var "0"),+ assign (var (s++"ColorComponents[2]"))+ (var "0"),+ assign (var (s++"ColorComponents[3]"))+ (var "0"), + assign (var (s++"Color"))+ (call "CGColorCreate" [s++"Colorspace", s++"ColorComponents"])]+ in+ inits++assigns++release :: [String] -> [CBlockItem]+release = + foldr+ (\ s ->+ (++)+ [CBlockStmt+ (createStat (call "CGColorSpaceRelease" [s ++ "Colorspace"])),+ CBlockStmt (createStat (call "CGColorRelease" [s ++ "Color"]))])+ []+++draw :: [CBlockItem]+draw = [CBlockStmt (createStat (call "CGContextDrawPath" ["context", "kCGPathFillStroke"]))]++drawEmpty :: [CBlockItem]+drawEmpty = [CBlockStmt (createStat (call "CGContextStrokePath"+ ["context"]))]++drawRoundedRect :: [String] -> [CBlockItem]+drawRoundedRect s+ | length s == 9 = [CBlockStmt (createStat (call "drawRoundedRect" s))]+ | length s == 10 = [CBlockStmt (createStat (call "drawRoundedRectFill" s))]++createStat :: CExpr -> CStat+createStat e = CExpr (Just e) noNodeInfo++createBlStmt :: CExpr -> CBlockItem+createBlStmt e = CBlockStmt (createStat e)+ +setStrokeColor :: String -> CExpr+setStrokeColor s = call "CGContextSetStrokeColorWithColor"+ ["context", s++"Color"]++setFillColor :: String -> CExpr+setFillColor s = call "CGContextSetFillColorWithColor"+ ["context", s++"Color"]++fillPath :: CExpr+fillPath = call "CGContextFillPath" ["context"]++strokePath :: CExpr+strokePath = call "CGContextStrokePath" ["context"]++fillRect :: CExpr+fillRect = call "CGContextFillRect" ["context", "rect"]++fillEllipse :: CExpr+fillEllipse = call "CGContextFillEllipseInRect" ["context", "rect"]++setFont :: Maybe String -> Float -> CExpr+setFont _ f = call "CGContextSelectFont"+ ["context"+ ,show "Helvetica"+ ,show f+ ,"kCGEncodingMacRoman"]++setFont' :: Maybe String -> String -> CExpr+setFont' _ s = call "CGContextSelectFont"+ ["context"+ ,show "Helvetica"+ ,s+ , "kCGEncodingMacRoman"]+++textAtPoint :: Point -> String -> CExpr+textAtPoint (Point x y) s =+ call "CGContextShowTextAtPoint"+ ["context"+ ,show x+ ,show y+ ,show s+ , show (length s)]++varTextAtPoint :: Point -> String -> CExpr+varTextAtPoint (Point x y) s =+ let len = '[':s++" length]"+ cstr = '[':s++" UTF8String]"+ in+ call "CGContextShowTextAtPoint"+ ["context"+ , show x+ , show y+ , cstr+ , len]++setLineWidth :: Float -> CExpr+setLineWidth f = call "CGContextSetLineWidth"+ ["context", show f]++setLineWidth' :: String -> CExpr+setLineWidth' s = call "CGContextSetLineWidth"+ ["context", s]++cMove :: Point -> CExpr+cMove (Point x y) = call "CGContextMoveToPoint"+ ["context", show x, show y]++cLine :: Point -> CExpr+cLine (Point x y) = call "CGContextAddLineToPoint"+ ["context",show x, show y]++rrectcall :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> CBlockItem+rrectcall x y rx ry w h sw =+ CBlockStmt (CExpr (Just (var ("[QRect drawWithContext:context andX:"+ ++show x++" andY:"+ ++show y++" andRadiusX:"+ ++show rx++" andRadiusY:"+ ++show ry++" andWidth:"+ ++show w++" andHeight:"+ ++show h++" andStrokeWidth:"+ ++show sw++" andStrokeColor: strokeColor]")))+ noNodeInfo)+frrectcall :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> CBlockItem+frrectcall x y rx ry w h sw = + CBlockStmt (CExpr (Just (var ("[QRect drawWithContext:context andX:"+ ++show x++" andY:"+ ++show y++" andRadiusX:"+ ++show rx++" andRadiusY:"+ ++show ry++" andWidth:"+ ++show w++" andHeight:"+ ++show h++" andStrokeWidth:"+ ++show sw++" andStrokeColor: strokeColor"+ ++" andFillColor: fillColor]")))+ noNodeInfo)+++codeString :: GraphicsElement -> Maybe String+codeString (Group xs _) = Nothing -- future works.+codeString Description = Nothing+codeString Definition = Nothing++codeString x = if id x == Nothing+ then Just $ prettyCode (catMaybes [createCode x])+ else genVarCode x +++createCode :: GraphicsElement -> Maybe CBlockItem+createCode (Rect (Point x y) + width+ height + rx+ ry+ fillColor+ strokeWidth+ strokeColor+ Nothing) = + let color = colorSetup "stroke" strokeColor + ++ colorSetup "fill" fillColor+ in+ if fillColor == Nothing+ then Just $ createComp (color+ ++ [rrectcall x y rx ry width height strokeWidth])+ else Just $ createComp (color+ ++ [frrectcall x y rx ry width height strokeWidth])++++createCode (Circle (Point cx cy) + r + fillColor+ strokeWidth+ strokeColor+ Nothing) = + let+ x = cx - r+ y = cy - r+ color = colorSetup "stroke" strokeColor ++colorSetup "fill" fillColor+ crel = release ["stroke", "fill"]+ cbl = [CBlockDecl (cDecl "CGRect" "rect"),+ assign (var "rect")+ (call "CGRectMake"+ (map show [x, y, r*2, r*2]))]+ str = map createBlStmt+ [setFillColor "fill",+ setStrokeColor "stroke",+ call "CGContextAddEllipseInRect" + ["context", "rect"],+ setLineWidth strokeWidth]+ in+ if fillColor == Nothing+ then Just $ createComp (color+ ++ cbl ++ tail str+ ++ drawEmpty+ ++ release ["stroke"])+ else Just $createComp (color + ++ cbl ++ str + ++ draw + ++ crel)++createCode (Ellipse (Point cx cy)+ rx+ ry+ fillColor+ strokeWidth+ strokeColor+ Nothing) =+ let+ x = cx - rx+ y = cy - ry+ color = colorSetup "stroke" strokeColor ++ colorSetup "fill" fillColor+ crel = release ["stroke", "fill"]+ cbl = [CBlockDecl (cDecl "CGRect" "rect"),+ assign (var "rect")+ (call "CGRectMake"+ (map show [x, y, rx*2, ry*2]))]+ str = map createBlStmt+ [setFillColor "fill",+ setStrokeColor "stroke",+ call "CGContextAddEllipseInRect" ["context", "rect"],+ setLineWidth strokeWidth]+ in+ if fillColor == Nothing+ then Just $ createComp (color+ ++ cbl ++ tail str+ ++ drawEmpty+ ++ release ["stroke"])+ else Just $ createComp (color + ++ cbl ++ str + ++ draw + ++ crel)+createCode (Line p1 + p2 + width + strokeColor + Nothing) = + let color = (colorSetup "stroke" strokeColor)+ crel = release ["stroke"]+ stroke = map createBlStmt+ [setStrokeColor "stroke",+ cMove p1,+ cLine p2,+ setLineWidth width]+ in+ Just $ createComp (color++stroke++draw++crel)++createCode (Path pc+ Nothing+ fillColor+ strokeWidth+ strokeColor) =+ let color = colorSetup "stroke" strokeColor++colorSetup "fill" fillColor+ crel = release ["stroke", "fill"]+ stroke = map createBlStmt+ ([setFillColor "fill",+ setLineWidth strokeWidth,+ setStrokeColor "stroke"]+++ pathCommands pc)+ in+ if fillColor == Nothing+ then Just $ createComp (color+ ++ tail stroke+ ++ drawEmpty+ ++ release ["stroke"])+ else Just $ createComp (color + ++ stroke + ++ draw + ++ crel)++createCode (TextElement (TextElem text+ fontSize+ _+ start+ strokeColor+ strokeWidth+ fillColor)+ Nothing) =+ let color = colorSetup "stroke" strokeColor++colorSetup "fill" fillColor+ a = map createBlStmt [setFillColor "fill"+ ,setLineWidth strokeWidth+ ,setStrokeColor "stroke"+ ,call "CGContextSetTextMatrix"+ ["context"+ ,"CGAffineTransformMakeScale(1,-1)"]+ ,call "CGContextSetTextDrawingMode"+ ["context"+ ,"kCGTextFillStroke"]+ ,setFont (Just "Helvetica") fontSize+ ,textAtPoint start text]+ in+ Just $ createComp (color+ ++ a)++createCode (Group xs id) = Just (createComp (mapMaybe createCode xs))+createCode Description = Nothing+createCode e = trace ("Note: createCode: Not yet implemented: "++show e) Nothing++cid :: Id -> String+cid x = toLower (head x) : tail x++++genVarCode :: GraphicsElement -> Maybe String+genVarCode (Group xs _) = Nothing -- future works.+genVarCode Description = Nothing+genVarCode Definition = Nothing++genVarCode (Path pc+ (Just id)+ _+ _+ _) =+ let id' = cid id+ stroke = map createBlStmt+ ([setFillColor (id'++"Element.fill"),+ setLineWidth' (id'++"Element.strokeWidth"),+ setStrokeColor (id'++"Element.stroke")]+++ pathCommands pc)+ in Just (prettyCode [createComp (stroke + ++ draw)])+++genVarCode x =+ if id x /= Nothing+ then+ let id' = cid (fromJust (id x))+ in + Just $ "\t["++id'++"Element drawWithContext:context];\n"+ else+ Nothing++createComp :: [CBlockItem] -> CBlockItem+createComp bil = CBlockStmt $ CCompound [] bil noNodeInfo++var :: String -> CExpr+var s = CVar (Ident s 0 noNodeInfo) noNodeInfo++call :: String -> [String] -> CExpr+call s0 s1 = CCall (var s0) (map var s1) noNodeInfo++assign :: CExpr -> CExpr -> CBlockItem+assign e1 e2 = CBlockStmt (CExpr (Just (CAssign CAssignOp e1 e2 noNodeInfo)) noNodeInfo)++-- produces delaration of type s1, name s2+cDecl :: String -> String -> CDecl+cDecl s1 s2 = CDecl [typeDef s1] [(Just (nameDeclr s2),Nothing, Nothing)] noNodeInfo++-- produces declarator of input string+nameDeclr :: String -> CDeclr+nameDeclr s = CDeclr (Just (Ident s 0 noNodeInfo)) [] Nothing [] noNodeInfo++-- produces type of input string+typeDef :: String -> CDeclSpec+typeDef s = CTypeSpec (CTypeDef (Ident s 0 noNodeInfo) noNodeInfo)++pathCommands :: [PathCommand] -> [CExpr]+pathCommands [] = []+pathCommands pc = map helper pc+ where+ helper (PathMoveTo x) = cMove x+ helper (PathLineTo x) = cLine x+ helper (PathCurveTo (Point cp1x cp1y)+ (Point cp2x cp2y)+ (Point p1x p1y)) = + call "CGContextAddCurveToPoint"+ ("context":map show [cp1x, cp1y, cp2x, cp2y, p1x, p1y])+ helper (PathQuadraticCurveTo (Point cx cy)+ (Point x y)) =+ call "CGContextAddQuadCurveToPoint"+ ("context":map show [cx, cy,x,y])+ helper PathClosePath = call "CGContextClosePath" ["context"]+ helper x = error ("pathCommands: not yet implemented: "++show x)++prettyCode :: [CBlockItem] -> String+prettyCode cbi = let + f "" p = (show.pretty) p+ f s p = s ++ "\n" ++ (show.pretty) p+ in+ foldl f "" cbi ++ "\n"++convertId :: Maybe Id -> String+convertId (Just id) = toLower (head id) : tail id+convertId Nothing = []++mkInitVals :: GraphicsElement -> Maybe CBlockItem+mkInitVals (Rect (Point x y)+ width+ height+ rx+ ry+ fill+ strokeWidth+ stroke+ id)+ | id == Nothing = Nothing+ | fill == Nothing =+ let color = colorSetup "stroke" stroke+ ++ transparentSetup "fill"+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ in+ Just $ createComp (color ++ [ f "x" (show x)+ , f "y" (show y)+ , f "width" (show width)+ , f "height" (show height)+ , f "radiusX" (show rx)+ , f "radiusY" (show ry)+ , f "strokeWidth" (show strokeWidth)+ , f "fillColor" "fillColor"+ , f "strokeColor" "strokeColor"])+ | otherwise =+ let color = colorSetup "stroke" stroke ++ colorSetup "fill" fill+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ in+ Just $ createComp (color ++ [ f "x" (show x)+ , f "y" (show y)+ , f "width" (show width)+ , f "height" (show height)+ , f "radiusX" (show rx)+ , f "radiusY" (show ry)+ , f "strokeWidth" (show strokeWidth)+ , f "strokeColor" "strokeColor"+ , f "fillColor" "fillColor"])++mkInitVals (Ellipse (Point x y)+ rx+ ry+ fill+ strokeWidth+ stroke+ id)+ | id == Nothing = Nothing+ | otherwise =+ let color = colorSetup "stroke" stroke + ++ colorSetup "fill" fill+ ++ transparentSetup "trans"+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ l = color ++ [f "x" (show x)+ , f "y" (show y)+ , f "radiusX" (show rx)+ , f "radiusY" (show ry)+ , f "strokeWidth" (show strokeWidth)+ , f "strokeColor" "strokeColor"]+ in+ if fill == Nothing+ then Just $ createComp (l++[f "fillColor" "transColor"])+ else Just $ createComp (l++[f "fillColor" "fillColor"])++mkInitVals (Path _+ id+ fill+ strokeWidth+ stroke)+ | id == Nothing = Nothing+ | otherwise =+ let color = colorSetup "stroke" stroke + ++ colorSetup "fill" fill+ ++ transparentSetup "trans"+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ l = color ++ [f "strokeColor" "strokeColor"+ ,f "strokeWidth" (show strokeWidth)]+ in+ if fill == Nothing+ then Just $ createComp (l++[f "fillColor" "transColor"])+ else Just $ createComp (l++[f "fillColor" "fillColor"])++mkInitVals (Circle (Point x y)+ radius+ fill+ strokeWidth+ stroke+ id)+ | id == Nothing = Nothing+ | otherwise =+ let color = colorSetup "stroke" stroke + ++ colorSetup "fill" fill+ ++ transparentSetup "trans"+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ l = color ++ [f "x" (show x)+ ,f "y" (show y)+ ,f "radiusX" (show radius)+ ,f "radiusY" (show radius)+ ,f "strokeWidth" (show strokeWidth)+ ,f "strokeColor" "strokeColor"]+ in+ if fill == Nothing+ then Just $ createComp (l+ ++[f "fillColor"+ "transColor"])+ else Just $ createComp (l+ ++[f "fillColor" "fillColor"])++mkInitVals (Line (Point x1 y1)+ (Point x2 y2)+ strokeWidth+ stroke+ id)+ | id == Nothing = Nothing+ | otherwise =+ let color = colorSetup "stroke" stroke+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ l = color ++ [f "x1" (show x1)+ ,f "x2" (show x2)+ ,f "y1" (show y1)+ ,f "y2" (show y2)+ ,f "strokeWidth" (show strokeWidth)+ ,f "strokeColor" "strokeColor"]+ in Just $ createComp l++mkInitVals (TextElement elem id)+ | id == Nothing = Nothing+ | otherwise =+ let color = colorSetup "stroke" (strokeColor elem)+ ++ colorSetup "fill" (fillColor elem)+ f s1 s2 = assign (var (cid (fromJust id)++"Element."++s1)) (var s2)+ l = color ++ [f "text" ('@':show (content elem))+ ,f "fillColor" "fillColor"+ ,f "strokeColor" "strokeColor"+ ,f "strokeWidth" (show (strokeWidth elem))+ ,f "fontSize" (show (fontSize elem))+ , f "x" (show (xCood (start elem)))+ ,f "y" (show (yCood (start elem)))]+ in+ Just $ createComp l+ +mkInitVals e+ | e == Description = Nothing+ | e == Definition = Nothing+ | id e == Nothing = Nothing+ | otherwise = trace ("Note: mkInitVals: not yet: "++show e) Nothing+++mkAllocs :: GraphicsElement -> Maybe String+mkAllocs (Rect _ _ _ _ _ _ _ _ (Just id)) =+ Just $ "\t\t"++cid id++"Element = [[QRect alloc] init];\n"+mkAllocs (Circle _ _ _ _ _ (Just id)) =+ Just $ "\t\t"++cid id++"Element = [[QEllipse alloc] init];\n"+mkAllocs (Ellipse _ _ _ _ _ _ (Just id)) =+ Just $ "\t\t"++cid id++"Element = [[QEllipse alloc] init];\n"+mkAllocs (Line _ _ _ _ (Just id)) =+ Just $ "\t\t"++cid id++"Element = [[QLine alloc] init];\n"+mkAllocs (Path _ (Just id) _ _ _) =+ Just $ "\t\t"++cid id++"Element = [[QPath alloc] init];\n"+mkAllocs (TextElement _ (Just id)) =+ Just $ "\t\t"++cid id++"Element = [[QText alloc] init];\n"+mkAllocs _ = Nothing++varNames :: GraphicsElement -> Maybe String+varNames Description = Nothing+varNames Definition = Nothing+varNames x+ | id x /= Nothing =+ Just $ cid (fromJust (id x))++"Element"+ | otherwise = Nothing++mkMember :: GraphicsElement -> Maybe String+mkMember (Rect _ _ _ _ _ _ _ _ (Just id)) =+ Just $ "\tQRect* "++cid id++"Element;\n"+mkMember (Circle _ _ _ _ _ (Just id)) =+ Just $ "\tQEllipse* "++cid id++"Element;\n"+mkMember (Ellipse _ _ _ _ _ _ (Just id)) =+ Just $ "\tQEllipse* "++cid id++"Element;\n"+mkMember (Line _ _ _ _ (Just id)) =+ Just $ "\tQLine* "++cid id++"Element;\n"+mkMember (Path _ (Just id) _ _ _) =+ Just $ "\tQPath* "++cid id++"Element;\n"+mkMember (TextElement _ (Just id)) =+ Just $ "\tQText* "++cid id++"Element;\n"+mkMember _ = Nothing
+ Types.hs view
@@ -0,0 +1,103 @@+module Types where++import Text.XML.Light.Types+import Data.List (groupBy, find)+import Debug.Trace (trace)+import Color+import Helpers (replace, clean)+import TextElement +import Point+import PathCommand+import Data.Maybe (fromJust)++type Id = String++-- returns Just ID or Nothing, if supplied string is empty+getId :: Maybe String -> Maybe Id+getId s = s++-- key value pair - maybe Map would do the trick?+data KeyValuePair =+ KeyValuePair {+ key :: String+ , value :: String}+ deriving (Show, Eq)++getStringFromKVP :: String -> [KeyValuePair] -> Maybe String+getStringFromKVP s kvp = let sr = find (\x -> key x == s) kvp+ in+ if sr == Nothing+ then Nothing+ else Just $ value (fromJust sr)+++-- key elements+data GraphicsElement = Rect {+ coordinate :: Point+ , width :: Float+ , height :: Float+ , rx :: Float+ , ry :: Float+ , fill :: Maybe Color+ , strokeWidth :: Float+ , stroke :: Maybe Color+ , id :: Maybe Id+ }+ | Circle {+ coordinate :: Point+ , radius :: Float+ , fill :: Maybe Color+ , strokeWidth :: Float+ , stroke :: Maybe Color+ , id :: Maybe Id+ }+ | Ellipse {+ coordinate :: Point+ , rx :: Float+ , ry :: Float+ , fill :: Maybe Color+ , strokeWidth :: Float+ , stroke :: Maybe Color+ , id :: Maybe Id+ }+ | Line {+ coordinateStart :: Point+ , coordinateStop :: Point+ , strokeWidth :: Float+ , stroke :: Maybe Color+ , id :: Maybe Id+ }+ | Group {+ gElements :: [GraphicsElement]+ , gId :: Maybe Id+ }+ | Description+ | Definition+ | Path {+ commands :: [PathCommand]+ , id :: Maybe Id+ , fill :: Maybe Color+ , strokeWidth :: Float+ , stroke :: Maybe Color+ }+ | TextElement {+ text :: TextElement+ , id :: Maybe Id+ }+ | NothingYet+ | SomethingNotSimple+ deriving (Show, Eq)++++mkPolyline :: [Point] -> Maybe Color -> Float -> Maybe Color -> Maybe Id -> GraphicsElement+mkPolyline (fp:ps)+ fill+ strokewidth+ stroke+ id =+ Path (PathMoveTo fp:map PathLineTo ps)+ id + fill + strokewidth + stroke
+ license.txt view
@@ -0,0 +1,10 @@+Copyright (c) 2011, Jan Greve+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+ * Neither the name of the CAU Kiel nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ main.hs view
@@ -0,0 +1,190 @@+module Main ( main ) where+import Data.SVG.SVG+import Data.Maybe (fromJust, mapMaybe)+import System( getArgs )+import Text.XML.Light.Types as XML+import Types --my own types+--import Translate --my translation functions+import Debug.Trace (trace)+import Data.Generics.Aliases (orElse)+import Helpers (split)+import Data.List (find)+import Color+import Point+import PathCommand (createPathCommands)+import Output (mkImplementation, mkHeader)+import TextElement++main :: IO ()+main = do+ args <- getArgs+ if or [null args, null (tail args)]+ then + putStrLn "usage: svg2q <filename to read svg from>\+ \ <class name>"+ else do+ contents <- readFile $ head args+ let graphics = map createGraphicsFromContent+ (extractSVGContent contents)+ mkImplementation graphics (args !! 1)+ mkHeader graphics (args!!1)++extractSVGContent :: String -> [Content]+extractSVGContent = elContent + . getSVGElement + . fromJust + . parseSVG++createGraphicsFromContent :: Content -> Maybe GraphicsElement+createGraphicsFromContent (Elem e) = Just $ cgfe e+createGraphicsFromContent _ = Nothing++cgfe :: XML.Element -> GraphicsElement+cgfe e = let name = qName (elName e)+ a = elAttribs e+ in + case name of+ "rect" -> Rect (Point (getFloat "x" a) + (getFloat "y" a))+ (getFloat "width" a)+ (getFloat "height" a)+ (getFloat "rx" a)+ (getFloat "ry" a)+ (getColor (getString "fill" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))+ (getId (getString "id" a))+ "circle" -> Circle (Point (getFloat "cx" a)+ (getFloat "cy" a))+ (getFloat "r" a)+ (getColor (getString "fill" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))+ (getId (getString "id" a))+ "ellipse" -> Ellipse (Point (getFloat "cx" a) + (getFloat "cy" a)) + (getFloat "rx" a)+ (getFloat "ry" a)+ (getColor (getString "fill" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))+ (getId (getString "id" a))+ "line" -> Line (Point (getFloat "x1" a) + (getFloat "y1" a))+ (Point (getFloat "x2" a) + (getFloat "y2" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))+ (getId (getString "id" a))+ "polyline" -> mkPolyline (getPoints (getString "points" a))+ (getColor (getString "fill" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))+ (getId (getString "id" a))+ "polygon" -> let p = getPoints (getString "points" a) in+ mkPolyline (p++[head p])+ (getColor (getString "fill" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))+ (getId (getString "id" a))+ "g" -> createGroup e+ "desc" -> createDescription e+ "defs" -> createDefinition e+ "path" -> createPath a+ "text" -> TextElement (TextElem (getText (elContent e))+ (getFloat "font-size" a)+ (getString "font-family" a)+ (Point (getFloat "x" a)+ (getFloat "y" a))+ (getColor (getString "stroke" a))+ (getFloat "stroke-width" a)+ (getColor (getString "fill" a)))+ (getId (getString "id" a))+ -- die on unknown tags, but promt them+ _ -> error $ "unknown tag: "++ name + +createGroup :: Element -> GraphicsElement+createGroup e = Group (mapMaybe createGraphicsFromContent (elContent e))+ (getId (getString "id" (elAttribs e)))++createDescription :: Element -> GraphicsElement+createDescription _ = Description++createDefinition :: Element -> GraphicsElement+createDefinition _ = Definition++createPath :: [Attr] -> GraphicsElement+createPath a = Path (createPathCommands (getString "d" a))+ (getId (getString "id" a))+ (getColor (getString "fill" a))+ (getFloat "stroke-width" a)+ (getColor (getString "stroke" a))++++kvpFromCSSAttr :: Maybe Attr -> [KeyValuePair]+kvpFromCSSAttr Nothing = []+kvpFromCSSAttr (Just a) = + let f = map (g . split ":")+ g (x:y:[]) = KeyValuePair x y+ g (x:y:_) = trace ("Warning: too many values for \+ \Key "++x++", using "++y)+ (KeyValuePair x y)+ g (x:_) = error ("Error: No value for key "++x)+ g [] = trace ("Warning, something went wront with \+ \kvpFromCSSAttr. Probably no Attributes.")+ KeyValuePair "" ""+ sl = split ";" (attrVal a)+ in+ f sl+ +getStyleString :: String -> [Attr] -> Maybe String+getStyleString s a = + getStringFromKVP+ s + (kvpFromCSSAttr (find (\x -> qName (attrKey x) == "style") + a))++getXMLString :: String -> [Attr] -> Maybe String+getXMLString s l = let sr = (find (\x -> qName (attrKey x) == s) l)+ in+ if sr == Nothing+ then Nothing+ else Just (attrVal (fromJust sr))++getStyleFloat :: String -> [Attr] -> Maybe Float+getStyleFloat s a = let sr = (getStyleString s a)+ in+ if sr == Nothing+ then Nothing+ else Just (read (fromJust sr))++getXMLFloat :: String -> [Attr] -> Maybe Float+getXMLFloat s a = let sr = (getXMLString s a)+ in+ if sr == Nothing+ then Nothing+ else Just (read (fromJust sr))++getString :: String -> [Attr] -> Maybe String+getString s a = let xml = getXMLString s a+ style = getStyleString s a+ in+ orElse style xml++getFloat :: String -> [Attr] -> Float+getFloat s a = let xml = getXMLFloat s a+ style = getStyleFloat s a+ r = orElse style xml+ in+ if r == Nothing+ then if s `elem` ["rx", "ry"]+ then 0+ else error ("Error: expected value for key \""++s++"\"\+ \, but none found.")+ else fromJust r++getText :: [Content] -> String+getText (Text x:_) = cdData x+getText (_:xs) = getText xs+getText _ = ""
+ svg2q.cabal view
@@ -0,0 +1,21 @@+Name: svg2q+Version: 0.3.1+Cabal-Version: >= 1.6+License: BSD3+Author: Jan Greve+Maintainer: Jan Greve+Homepage: http://www.informatik.uni-kiel.de/~jgr/svg2q+Category: Parsing+Synopsis: Code generation tool for Quartz code from a SVG.+Description: svg2q will generate an Objective C Class from an SVG file which shows the SVG. The Class offers methods to set attributes of those SVG elements that have ids to change looks at runtime. This package is the result of a bachelors thesis and is not yet ready to use for "normal" SVGs. Upon request, usability may be improved if spare time is available. +build-type: Simple+stability: alpha+tested-with: GHC ==6.12.3+extra-source-files: svg2q.h, svg2q.m, *.hs+license-file: license.txt+++Executable svg2q+ Build-Depends: base >= 4.0 && <= 4.3, svgutils, language-c, xml, haskell98, syb, pretty+ Main-Is: main.hs+ Hs-Source-Dirs: .
+ svg2q.h view
@@ -0,0 +1,117 @@+/*+ svg2q Library + Created by Jan Greve+ Copyright 2011 CAU Kiel. All rights reserved.+ */++#import <UIKit/UIKit.h>;+#import <CoreGraphics/CoreGraphics.h>;++++@interface QLine : NSObject {+ CGFloat x1;+ CGFloat x2;+ CGFloat y1;+ CGFloat y2;+ CGColorRef strokeColor;+ CGFloat strokeWidth;+}+@property(nonatomic,assign) CGFloat x1;+@property(nonatomic,assign) CGFloat x2;+@property(nonatomic,assign) CGFloat y1;+@property(nonatomic,assign) CGFloat y2;+@property(nonatomic,assign) CGColorRef strokeColor;+@property(nonatomic,assign) CGFloat strokeWidth;++-(void) drawWithContext:(CGContextRef) context;++@end++@interface QPath : NSObject {+ CGColorRef strokeColor;+ CGColorRef fillColor;+ CGFloat strokeWidth;+}+@property(nonatomic,assign) CGColorRef strokeColor;+@property(nonatomic,assign) CGColorRef fillColor;+@property(nonatomic,assign) CGFloat strokeWidth;++@end++@interface QEllipse : NSObject+{+ CGColorRef strokeColor;+ CGColorRef fillColor;+ CGFloat strokeWidth;+ CGFloat x;+ CGFloat y;+ CGFloat radiusX;+ CGFloat radiusY;+}++@property(nonatomic,assign) CGColorRef strokeColor;+@property(nonatomic,assign) CGColorRef fillColor;+@property(nonatomic,assign) CGFloat strokeWidth;+@property(nonatomic,assign) CGFloat x;+@property(nonatomic,assign) CGFloat y;+@property(nonatomic,assign) CGFloat radiusX;+@property(nonatomic,assign) CGFloat radiusY;+++-(void) drawWithContext:(CGContextRef) context;++@end++@interface QRect : NSObject+{+ CGColorRef strokeColor;+ CGColorRef fillColor;+ CGFloat strokeWidth;+ CGFloat x;+ CGFloat y;+ CGFloat radiusX;+ CGFloat radiusY;+ CGFloat width;+ CGFloat height;+}++@property(nonatomic,assign) CGColorRef strokeColor;+@property(nonatomic,assign) CGColorRef fillColor;+@property(nonatomic,assign) CGFloat strokeWidth;+@property(nonatomic,assign) CGFloat x;+@property(nonatomic,assign) CGFloat y;+@property(nonatomic,assign) CGFloat radiusX;+@property(nonatomic,assign) CGFloat radiusY;+@property(nonatomic,assign) CGFloat width;+@property(nonatomic,assign) CGFloat height;++++-(void) drawWithContext:(CGContextRef) context;++(void) drawWithContext:(CGContextRef) context andX:(CGFloat) x andY:(CGFloat) y andRadiusX:(CGFloat)rx andRadiusY:(CGFloat) ry andWidth:(CGFloat) w andHeight: (CGFloat) h andStrokeWidth:(CGFloat) sw andStrokeColor:(CGColorRef) sc;++(void) drawWithContext:(CGContextRef) context andX:(CGFloat) x andY:(CGFloat) y andRadiusX:(CGFloat)rx andRadiusY:(CGFloat) ry andWidth:(CGFloat) w andHeight: (CGFloat) h andStrokeWidth:(CGFloat) sw andStrokeColor:(CGColorRef) sc andFillColor:(CGColorRef) fc;++@end++@interface QText : NSObject+{+ CGColorRef strokeColor;+ CGColorRef fillColor;+ CGFloat strokeWidth;+ int fontSize;+ NSString* text;+ CGFloat x;+ CGFloat y;+}+@property(nonatomic, assign) CGColorRef strokeColor;+@property(nonatomic, assign) CGColorRef fillColor;+@property(nonatomic, assign) CGFloat strokeWidth;+@property(nonatomic, assign) int fontSize;+@property(nonatomic, retain) NSString* text;+@property(nonatomic,assign) CGFloat x;+@property(nonatomic,assign) CGFloat y;++-(void) drawWithContext:(CGContextRef) context;++@end
+ svg2q.m view
@@ -0,0 +1,147 @@+#import "svg2q.h"+++@implementation QLine++@synthesize x1, x2, y1, y2, strokeColor, strokeWidth;++-(void) drawWithContext:(CGContextRef) context { + CGContextSetLineWidth(context, self.strokeWidth);+ CGContextSetStrokeColorWithColor(context, self.strokeColor);+ CGContextMoveToPoint(context, self.x1, self.y1);+ CGContextAddLineToPoint(context, self.x2, self.y2);+ CGContextDrawPath(context, kCGPathStroke);+}++@end++@implementation QPath+@synthesize strokeColor, fillColor, strokeWidth;++@end++@implementation QEllipse++@synthesize strokeColor, fillColor, strokeWidth, x, y, radiusX, radiusY;++-(void) drawWithContext:(CGContextRef)context { + CGRect frame = CGRectMake(self.x - self.radiusX, self.y - self.radiusY, 2*self.radiusX, 2*self.radiusY);+ CGContextSetFillColorWithColor(context, self.fillColor);+ CGContextSetStrokeColorWithColor(context, strokeColor);+ CGContextSetLineWidth(context, self.strokeWidth);+ CGContextAddEllipseInRect(context, frame);+ CGContextDrawPath(context, kCGPathFillStroke); +}+++@end++@implementation QRect++@synthesize strokeColor, fillColor, strokeWidth, x, y, radiusX, radiusY, width, height;+ +-(void) drawWithContext:(CGContextRef)context {+ if (self.radiusX > self.width / 2) {+ self.radiusX = self.width / 2;+ }+ if (self.radiusY > self.height / 2) {+ self.radiusY = self.height / 2;+ }+ + CGContextSetLineWidth(context, self.strokeWidth);+ CGContextSetStrokeColorWithColor(context, self.strokeColor);+ CGContextSetFillColorWithColor(context, self.fillColor);+ CGContextMoveToPoint(context, self.x+self.radiusX, self.y);+ CGContextAddLineToPoint(context, self.x + self.width - self.radiusX, self.y);+ CGContextAddQuadCurveToPoint(context, self.x + self.width, self.y, self.x + self.width, self.y+self.radiusY);+ CGContextAddLineToPoint(context, self.x+self.width, self.y+self.height-self.radiusY);+ CGContextAddQuadCurveToPoint(context, self.x + self.width, self.y + self.height, self.x + self.width - self.radiusX, self.y + self.height);+ CGContextAddLineToPoint(context, self.x + self.radiusX, self.y + self.height);+ CGContextAddQuadCurveToPoint(context, self.x, self.y + self.height, self.x, self.y + self.height - self.radiusY);+ CGContextAddLineToPoint(context, self.x, self.y + self.radiusY);+ CGContextAddQuadCurveToPoint(context, self.x, self.y, self.x + self.radiusX, self.y);+ CGContextDrawPath(context, kCGPathFillStroke); +}++(void)drawWithContext:(CGContextRef)context andX:(CGFloat)x andY:(CGFloat)y andRadiusX:(CGFloat)rx andRadiusY:(CGFloat)ry andWidth:(CGFloat)w andHeight:(CGFloat)h andStrokeWidth:(CGFloat)sw andStrokeColor:(CGColorRef)sc {+ if (rx > (w/2)) {+ rx = w/2;+ }+ if (ry > (h/2)) {+ ry = h/2;+ }+ CGContextSetLineWidth(context, sw);+ CGContextSetStrokeColorWithColor(context, sc);+ // 1. top left corner+ CGContextMoveToPoint(context, x+rx, y);+ // 2. line to right corner+ CGContextAddLineToPoint(context, x + w - rx, y);+ // 3. top right rounded corner+ CGContextAddQuadCurveToPoint(context, x + w, y, x + w, y+ry);+ // 4. line down the right+ CGContextAddLineToPoint(context, x + w, y + h - ry);+ // 5. lower right corner+ CGContextAddQuadCurveToPoint(context, x + w, y + h, x + w - rx, y + h);+ // 6. lower line to left corner+ CGContextAddLineToPoint(context, x + rx, y + h);+ // 7. lower left corner+ CGContextAddQuadCurveToPoint(context, x, y+h, x, y + h - ry);+ // 8. line from lower left to upper left+ CGContextAddLineToPoint(context, x, y+ry);+ // 9. upper left corner+ CGContextAddQuadCurveToPoint(context, x, y, x+rx, y);+ + CGContextStrokePath(context); +}+++(void)drawWithContext:(CGContextRef)context andX:(CGFloat)x andY:(CGFloat)y andRadiusX:(CGFloat)rx andRadiusY:(CGFloat)ry andWidth:(CGFloat)w andHeight:(CGFloat)h andStrokeWidth:(CGFloat)sw andStrokeColor:(CGColorRef)sc andFillColor:(CGColorRef) fc {+ if (rx > (w/2)) {+ rx = w/2;+ }+ if (ry > (h/2)) {+ ry = h/2;+ }+ CGContextSetLineWidth(context, sw);+ CGContextSetStrokeColorWithColor(context, sc);+ CGContextSetFillColorWithColor(context, fc);+ // 1. top left corner+ CGContextMoveToPoint(context, x+rx, y);+ // 2. line to right corner+ CGContextAddLineToPoint(context, x + w - rx, y);+ // 3. top right rounded corner+ CGContextAddQuadCurveToPoint(context, x + w, y, x + w, y+ry);+ // 4. line down the right+ CGContextAddLineToPoint(context, x + w, y + h - ry);+ // 5. lower right corner+ CGContextAddQuadCurveToPoint(context, x + w, y + h, x + w - rx, y + h);+ // 6. lower line to left corner+ CGContextAddLineToPoint(context, x + rx, y + h);+ // 7. lower left corner+ CGContextAddQuadCurveToPoint(context, x, y+h, x, y + h - ry);+ // 8. line from lower left to upper left+ CGContextAddLineToPoint(context, x, y+ry);+ // 9. upper left corner+ CGContextAddQuadCurveToPoint(context, x, y, x+rx, y);+ + CGContextDrawPath(context, kCGPathFillStroke);+ +}++@end++@implementation QText++@synthesize strokeColor, strokeWidth, fillColor, fontSize, text, x, y;++-(void) drawWithContext:(CGContextRef)context {+ CGContextSetLineWidth(context, self.strokeWidth);+ CGContextSetStrokeColorWithColor(context, self.strokeColor);+ CGContextSetFillColorWithColor(context, self.fillColor);+ CGContextSetTextMatrix(context, CGAffineTransformMakeScale(1, -1));+ CGContextSetTextDrawingMode(context, kCGTextFillStroke);+ CGContextSelectFont(context, "Helvetica", self.fontSize, kCGEncodingMacRoman);+ CGContextShowTextAtPoint(context, self.x, self.y, [self.text UTF8String], [self.text length]);+ CGContextSetTextMatrix(context, CGAffineTransformMakeScale(1, -1));++}++@end