diff --git a/Color.hs b/Color.hs new file mode 100644 --- /dev/null +++ b/Color.hs @@ -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 "" + diff --git a/Helpers.hs b/Helpers.hs new file mode 100644 --- /dev/null +++ b/Helpers.hs @@ -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) == "" diff --git a/Output.hs b/Output.hs new file mode 100644 --- /dev/null +++ b/Output.hs @@ -0,0 +1,106 @@ +module Output where + +import System.IO +import Types +import Translate (createCode, mkSynthList, prettyCode, mkPropTypes, mkInitVals) +import Data.Maybe (mapMaybe, catMaybes) +import Text.PrettyPrint.HughesPJ +import Language.C.Pretty +import Language.C.Syntax.AST +import Debug.Trace(trace) +import Helpers(split) +import Data.List (isPrefixOf) + +mkImplementation :: [Maybe GraphicsElement] -> String -> IO () +mkImplementation graphics file = + let code = mapMaybe createCode (catMaybes graphics) + con = imFileStart file graphics + ++ drawRect (prettyCode code) + ++ imFileEnd + in do + fun <- readFile "functions.c" + writeFile (file++".m") (fileHeader++"\n\n"++fun++"\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.2.\n\ + \\tPlease feel free to report any bugs. */\n\n\n" + + +imInit :: [Maybe GraphicsElement] -> String +imInit ge = let a = mapMaybe mkInitVals (catMaybes ge) + in + prettyCode a + + + +imFileStart :: String -> [Maybe GraphicsElement] -> String +imFileStart file graphics= + "#include \""++file++".h\"\n\n\ + \@implementation "++file++"\n\n"++ + imSynths (mkSynthList graphics) ++"\n\n\ + \- (id)initWithFrame:(CGRect) frame {\ + \\n\tself = [super initWithFrame:frame];\ + \\n\t if (self) {\ + \\n\t\t // init code.\n"++ + imInit graphics ++ + "\n\t}\ + \\n\treturn self;\ + \\n}\n\n" + +imFileEnd :: String +imFileEnd = imScale++"- (void) dealloc {\n\t\ + \[super dealloc];\n\ + \}\n\n\ + \@end\n" + +drawRect :: String -> String +drawRect c = "- (void) drawRect: (CGRect) rect {\n" + ++ c ++ "}\n\n" + +imSynths :: [String] -> String +imSynths = foldr (\y x -> x++"@synthesize "++y++";\n") "" + +hFileStart :: String -> String +hFileStart file = fileHeader++ + "#import ;\n\n\ + \@interface "++file++" : UIView {\n" + + +hFileEnd :: String +hFileEnd = "\n\n@end\n" + +hProperties :: [Maybe GraphicsElement] -> String +hProperties xs = let ge = catMaybes xs -- [GraphicsElement] + sl = map mkPropTypes ge -- [[String]] + sl' = concat sl -- [String] + pl = map hProp sl' -- [String] + in + foldr (++) "" pl + +hProp :: String -> String +hProp s + | isPrefixOf "NS" s = "\t@property(nonatomic, retain) "++s++";\n" + | otherwise = "\t@property(nonatomic, assign) "++s++";\n" + +hMem :: String -> String +hMem x= "\t"++x++";\n" + +hMembers :: [Maybe GraphicsElement] -> String +hMembers xs = let ge = catMaybes xs + sl = map mkPropTypes ge + sl' = concat sl + pl = map hMem sl' + in + foldr (++) "" pl++"\n\n\n" + +imScale :: String +imScale = "- (void) redraw {\ + \\n\t[self drawRect: [self frame]];\ + \\n}\n\n" diff --git a/PathCommand.hs b/PathCommand.hs new file mode 100644 --- /dev/null +++ b/PathCommand.hs @@ -0,0 +1,116 @@ +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 + 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 +createCmds s@(c:_) (a0:a1:a2:a3:a4:a5:a6: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 (PathMoveTo x) (PathClosePath:[]) = [PathLineTo x] +optimizePath _ (x:[]) = [x] +optimizePath _ [] = [] +optimizePath c (PathMoveTo x0:PathMoveTo x1: xs) = + optimizePath c (PathMoveTo x1:xs) +optimizePath c (x@(PathCurveTo c1 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 diff --git a/Point.hs b/Point.hs new file mode 100644 --- /dev/null +++ b/Point.hs @@ -0,0 +1,39 @@ +module Point where + +import Helpers (replace) +import Debug.Trace (trace) + +data Point = Point { + x :: Float + , y :: 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 numbers, how am i supposed to\ + \ make points? 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)) diff --git a/SVG2Q.cabal b/SVG2Q.cabal new file mode 100644 --- /dev/null +++ b/SVG2Q.cabal @@ -0,0 +1,21 @@ +Name: SVG2Q +Version: 0.3 +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 a Objective C Class from a SVG file which shows the SVG. The Class offers methods to set attributes of those SVG elements that have ids. +build-type: Simple +stability: alpha +tested-with: GHC ==6.12.3 +extra-source-files: functions.c, *.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: . diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +import Distribution.Simple +main = defaultMain diff --git a/TextElement.hs b/TextElement.hs new file mode 100644 --- /dev/null +++ b/TextElement.hs @@ -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) diff --git a/Translate.hs b/Translate.hs new file mode 100644 --- /dev/null +++ b/Translate.hs @@ -0,0 +1,810 @@ +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) +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 + +contextSetup :: [CBlockItem] +contextSetup = [CBlockDecl (cDecl "CGContextRef" "context"), + assign (var "context") + (call "UIGraphicsGetCurrentContext" [])] + +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] + + +createCode :: GraphicsElement -> Maybe CBlockItem +-- GraphicsElements without id first: +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 (contextSetup ++ color + ++ drawRoundedRect ("context":(map show + [x + ,y + ,width + ,height + ,rx + ,ry + ,strokeWidth] + ++ ["strokeColor"]))) + else Just $ createComp (contextSetup ++ color + ++ drawRoundedRect ("context":map show + [x + ,y + ,width + ,height + ,rx + ,ry + ,strokeWidth] + ++ ["strokeColor" + ,"fillColor"])) + +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 (contextSetup + ++ color + ++ cbl ++ tail str + ++ drawEmpty + ++ release ["stroke"]) + else Just $createComp (contextSetup + ++ 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 (contextSetup + ++ color + ++ cbl ++ tail str + ++ drawEmpty + ++ release ["stroke"]) + else Just $ createComp (contextSetup + ++ 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 (contextSetup++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 (contextSetup + ++ color + ++ tail stroke + ++ drawEmpty + ++ release ["stroke"]) + else Just $ createComp (contextSetup + ++ 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 (contextSetup + ++ color + ++ a) +-- Those with id now: +createCode (Rect (Point x y) + width + height + rx + ry + fill + strokeWidth + stroke + id) = + let id' = convertId id + stroke = drawRoundedRect ("context":(map (id'++) + ["X" + ,"Y" + ,"Width" + ,"Height" + ,"Rx" + ,"Ry" + ,"StrokeWidth" + ,"StrokeColor" + ,"FillColor"])) + in Just $ createComp (contextSetup++stroke) + +createCode (Path pc + id + _ + _ + _) = + let id' = convertId id + stroke = map createBlStmt + ([setFillColor (id'++"Fill"), + setLineWidth' (id'++"StrokeWidth"), + setStrokeColor (id'++"Stroke")]++ + pathCommands pc) + in Just $createComp (contextSetup + ++ stroke + ++ draw) + +createCode (Ellipse _ + _ + _ + _ + _ + _ + id) = + let + x = (id'++"X - "++id'++"RadiusX") + y = (id'++"Y - "++id'++"RadiusY") + id' = convertId id + cbl = [CBlockDecl (cDecl "CGRect" "rect"), + assign (var "rect") + (call "CGRectMake" + [x + , y + , id'++"RadiusX * 2" + , id'++"RadiusY * 2"])] + str = map createBlStmt + [setFillColor (id'++"Fill"), + setStrokeColor (id'++"Stroke"), + call "CGContextAddEllipseInRect" ["context", "rect"], + setLineWidth' (id'++"StrokeWidth")] + in + Just $ createComp (contextSetup++ cbl ++ str + ++ draw) + +createCode (Circle _ + _ + _ + _ + _ + id) = + let + id' = convertId id + x' = id'++"X - "++r' + y' = id'++"Y - "++r' + r' = id'++"Radius" + cbl = [CBlockDecl (cDecl "CGRect" "rect"), + assign (var "rect") + (call "CGRectMake" + [x' + , y' + , r'++" * 2" + , r'++" * 2"])] + str = map createBlStmt + [setFillColor (id'++"Fill"), + setStrokeColor (id'++"Stroke"), + call "CGContextAddEllipseInRect" ["context", "rect"], + setLineWidth' (id'++"StrokeWidth")] + in + Just $ createComp (contextSetup ++ cbl ++ str ++ draw) + +createCode (Line _ + _ + _ + _ + id) = + let id' = convertId id + x1 = id'++"X1" + x2 = id' ++ "X2" + y1 = id' ++ "Y1" + y2 = id'++"Y2" + stroke = map createBlStmt + [setStrokeColor (id'++"Stroke"), + call "CGContextMoveToPoint" + ["context", x1, y1], + call "CGContextAddLineToPoint" + ["context", x2, y2], + setLineWidth' (id'++"StrokeWidth")] + in + Just $ createComp (contextSetup++stroke++draw) + +createCode (TextElement elem id) = + let id' = convertId id + str = map createBlStmt ([setFillColor (id'++"Fill") + ,setLineWidth' (id'++"StrokeWidth") + ,setStrokeColor (id'++"Stroke") + ,call "CGContextSetTextMatrix" + ["context" + ,"CGAffineTransformMakeScale(1,-1)"] + ,call "CGContextSetTextDrawingMode" + ["context" + ,"kCGTextFillStroke"] + ,setFont' (Just "Helvetica") (id'++"FontSize") + ,varTextAtPoint (start elem) (id'++"Text")]) + in + Just $ createComp (contextSetup++str) + +-- and our special guests +createCode (Group xs id) = Just (createComp (mapMaybe createCode xs)) +createCode Description = Nothing +createCode e = trace ("Note: createCode: Not yet implemented: "++show e) 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 x = error ("pathCommands: not yet implemented: "++show x) + + +mkSynthList :: [Maybe GraphicsElement] -> [String] +mkSynthList [] = [] +mkSynthList (Just Description:xs) = mkSynthList xs +mkSynthList (Just Definition:xs) = mkSynthList xs +mkSynthList (Nothing:xs) = mkSynthList xs +mkSynthList (Just x:xs) + | id x == Nothing = mkSynthList xs + | otherwise = mkSynthNames x ++ mkSynthList xs + +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 = [] + +mkSynthNames :: GraphicsElement -> [String] +mkSynthNames (Rect {Types.id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + map (s++) ["X", "Y", "Width", "Height", "Rx" + , "Ry", "FillColor", "StrokeColor", "StrokeWidth"] + +mkSynthNames (Circle {Types.id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + map (s++) ["X", "Y", "Radius", "FillColor", "StrokeColor", "StrokeWidth"] + +mkSynthNames (Ellipse {Types.id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + map (s++) ["X", "Y", "RadiusX", "RadiusY", "FillColor", "StrokeColor" + , "StrokeWidth"] + +mkSynthNames (Line {Types.id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + map (s++) ["X1", "Y1", "X2", "Y2", "StrokeColor", "StrokeWidth"] +mkSynthNames (Group _ _) = [] +mkSynthNames (Description) = [] +mkSynthNames (Definition) = [] +mkSynthNames (Path {id = mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + map (s++) ["FillColor", "StrokeColor", "StrokeWidth"] +mkSynthNames (TextElement {id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + map (s++) ["Text", "FillColor", "StrokeColor", "StrokeWidth", "FontSize"] + + +mkPropTypes :: GraphicsElement -> [String] +mkPropTypes (Group _ _ ) = [] +mkPropTypes (Description) = [] +mkPropTypes Definition = [] +mkPropTypes (Rect {Types.id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + ["CGFloat "++s++"X" + , "CGFloat "++s++"Y" + , "CGFloat "++s++"Width" + , "CGFloat "++s++"Height" + , "CGFloat "++s++"Ry" + , "CGFloat "++s++"Rx" + , "CGColorRef "++s++"FillColor" + , "CGColorRef "++s++"StrokeColor" + , "CGFloat "++s++"StrokeWidth"] +mkPropTypes (Circle {id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + ["CGFloat "++s++"X" + , "CGFloat "++s++"Y" + , "CGFloat "++s++"Radius" + , "CGColorRef "++s++"FillColor" + , "CGColorRef "++s++"StrokeColor" + , "CGFloat "++s++"StrokeWidth"] +mkPropTypes (Ellipse {id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + ["CGFloat "++s++"X" + , "CGFloat "++s++"Y" + , "CGFloat "++s++"RadiusY" + , "CGFloat "++s++"RadiusX" + , "CGColorRef "++s++"FillColor" + , "CGColorRef "++s++"StrokeColor" + , "CGFloat "++s++"StrokeWidth"] +mkPropTypes (Line {id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + ["CGFloat "++s++"X1" + , "CGFloat "++s++"Y1" + , "CGFloat "++s++"X2" + , "CGFloat "++s++"Y2" + , "CGColorRef "++s++"StrokeColor" + , "CGFloat "++s++"StrokeWidth"] +mkPropTypes (Path {id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + ["CGColorRef "++s++"FillColor" + , "CGColorRef "++s++"StrokeColor" + , "CGFloat "++s++"StrokeWidth"] + +mkPropTypes (TextElement {id=mid}) + | mid == Nothing = [] + | otherwise = + let s = convertId mid + in + ["NSString* "++s++"Text" + ,"CGColorRef "++s++"FillColor" + ,"CGColorRef "++s++"StrokeColor" + ,"CGFloat "++s++"StrokeWidth" + , "int "++s++"FontSize"] + + +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 (convertId id++s1)) (var s2) + in + Just $ createComp (color ++ [ f "X" (show x) + , f "Y" (show y) + , f "Width" (show width) + , f "Height" (show height) + , f "Rx" (show rx) + , f "Ry" (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 (convertId id++s1)) (var s2) + in + Just $ createComp (color ++ [ f "X" (show x) + , f "Y" (show y) + , f "Width" (show width) + , f "Height" (show height) + , f "Rx" (show rx) + , f "Ry" (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 (convertId id++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 (convertId id++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 (convertId id++s1)) (var s2) + l = color ++ [f "X" (show x) + ,f "Y" (show y) + ,f "Radius" (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 (convertId id++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 (convertId id++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))] + 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 + + diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,104 @@ +module Types where + +import Text.XML.Light.Types +import Data.List (groupBy) +import Debug.Trace (trace) +import Color +import Helpers (replace, clean) +import TextElement +import Point +import PathCommand +import Data.List (find) +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 diff --git a/functions.c b/functions.c new file mode 100644 --- /dev/null +++ b/functions.c @@ -0,0 +1,62 @@ +void drawRoundedRect(CGContextRef context, CGFloat x, CGFloat y, CGFloat width, CGFloat height, CGFloat rx, CGFloat ry, CGFloat strokeWidth, CGColorRef stroke) { + if (rx > (width/2)) { + rx = width/2; + } + if (ry > (height/2)) { + ry = height/2; + } + CGContextSetLineWidth(context, strokeWidth); + CGContextSetStrokeColorWithColor(context, stroke); + // 1. top left corner + CGContextMoveToPoint(context, x+rx, y); + // 2. line to right corner + CGContextAddLineToPoint(context, x + width - rx, y); + // 3. top right rounded corner + CGContextAddQuadCurveToPoint(context, x + width, y, x + width, y+ry); + // 4. line down the right + CGContextAddLineToPoint(context, x + width, y + height - ry); + // 5. lower right corner + CGContextAddQuadCurveToPoint(context, x + width, y + height, x + width - rx, y + height); + // 6. lower line to left corner + CGContextAddLineToPoint(context, x + rx, y + height); + // 7. lower left corner + CGContextAddQuadCurveToPoint(context, x, y+height, x, y + height - 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 drawRoundedRectFill(CGContextRef context, CGFloat x, CGFloat y, CGFloat width, CGFloat height, CGFloat rx, CGFloat ry, CGFloat strokeWidth, CGColorRef stroke, CGColorRef fill) { + if (rx > (width/2)) { + rx = width/2; + } + if (ry > (height/2)) { + ry = height/2; + } + CGContextSetLineWidth(context, strokeWidth); + CGContextSetStrokeColorWithColor(context, stroke); + CGContextSetFillColorWithColor(context, fill); + // 1. top left corner + CGContextMoveToPoint(context, x+rx, y); + // 2. line to right corner + CGContextAddLineToPoint(context, x + width - rx, y); + // 3. top right rounded corner + CGContextAddQuadCurveToPoint(context, x + width, y, x + width, y+ry); + // 4. line down the right + CGContextAddLineToPoint(context, x + width, y + height - ry); + // 5. lower right corner + CGContextAddQuadCurveToPoint(context, x + width, y + height, x + width - rx, y + height); + // 6. lower line to left corner + CGContextAddLineToPoint(context, x + rx, y + height); + // 7. lower left corner + CGContextAddQuadCurveToPoint(context, x, y+height, x, y + height - 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); +} diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -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. diff --git a/main.hs b/main.hs new file mode 100644 --- /dev/null +++ b/main.hs @@ -0,0 +1,178 @@ +module Main ( main ) where +import Data.SVG.SVG +import Data.Maybe (catMaybes, fromJust, mapMaybe) +import System( getArgs ) +import Text.XML.Light.Types +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 = do + args <- getArgs + if or [null args, null (tail args)] + then + putStrLn "usage: svg2q " + else do + contents <- readFile $ head args + let graphics = map createGraphicsFromContent (extractSVGContent contents) + -- let code = mapMaybe createCode (catMaybes graphics) + mkImplementation graphics (args !! 1) + mkHeader graphics (args!!1) + -- printCode code + +extractSVGContent :: String -> [Content] +extractSVGContent = elContent . getSVGElement . fromJust . parseSVG + +createGraphicsFromContent :: Content -> Maybe GraphicsElement +createGraphicsFromContent (Elem e) = Just $ cgfe e +createGraphicsFromContent _ = Nothing + +cgfe :: 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 e = Description + +createDefinition :: Element -> GraphicsElement +createDefinition e = 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) + 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:xs) = cdData x +getText (_:xs) = getText xs +getText _ = ""