SVG2Q-0.3: Translate.hs
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