module Translate where import Data.Generics.Aliases (orElse) import Helpers (split) import Data.List (find) import Text.XML.Light.Types as XML 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 createGraphicsFromContent :: Content -> Maybe GraphicsElement createGraphicsFromContent (Elem e) = Just $ fromXML e createGraphicsFromContent _ = Nothing 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 _ = "" fromXML :: XML.Element -> GraphicsElement fromXML 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 -- 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 = let x' = concatMap idTable x in toLower (head x') : tail x' idTable :: Char -> String idTable '@' = "At" idTable ':' = "Colon" idTable '-' = "Dash" idTable '.' = "Dot" idTable ',' = "Comma" idTable c = [c] 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