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