implementation module iTasks.Gin.SVG import StdInt import StdGeneric import StdList import StdString import StdBool import Data.Maybe import Text.XML, Text.HTML import iTasks.Framework.UIDefinition from iTasks.Gin.Types import generic gEq, generic JSONDecode, generic JSONEncode, generic gVerify, generic gUpdate, generic gDefault, generic gGridRows, generic gHeaders, generic gVisualizeText, generic gVisualizeEditor from iTasks.Gin.Types import :: JSONNode, :: InteractionMask, :: VerifyMask, :: VerifyOptions, :: ConsPos, :: StaticVisualizationMode, :: VSt, :: VisualizationResult, :: GTypeExpression, :: GTypeDefinition from iTasks.Gin.Types import printGTypeDefinition, typeIsDefined, printGTypeExpression from iTasks.Gin.Printer import class Printer from iTasks import class iTask derive class iTask SVGPosX, SVGPosY, SVGElement, SVGStyle, SVGShape derive class iTask XMLDoc, XMLNode, XMLAttr, XMLQName instance toString SVGShape where toString {width, height, defs, magnets, elements} = toString doc where doc :: XMLDoc doc = XMLDoc (Just "http://www.w3.org/2000/svg") [ ("svg","http://www.w3.org/2000/svg") , ("oryx","http://www.b3mn.org/oryx") , ("xlink", "http://www.w3.org/1999/xlink") ] (XMLElem (uname "svg") [ XMLAttr (uname "width") (toString width) , XMLAttr (uname "height") (toString height) ] ([defs`] ++ magnets` ++ [group])) defs` :: XMLNode defs` = XMLElem (uname "defs") [] defs magnets` :: [XMLNode] magnets` = if (not magnets) [] [ XMLElem (qname "oryx" "magnets") [] [ magnet 1 (height / 2) "anchor" "left" , magnet (width / 2) height "anchor" "bottom" , magnet width (height / 2) "anchor" "right" , magnet (width / 2) 1 "anchor" "top" , magnet (width / 2) (height / 2) "default" "yes" ] ] magnet :: Int Int String String -> XMLNode magnet cx cy type value = XMLElem (qname "oryx" "magnet") [ XMLAttr (qname "oryx" "cx") (toString cx) , XMLAttr (qname "oryx" "cy" ) (toString cy) , XMLAttr (qname "oryx" type) value ] [] group :: XMLNode group = XMLElem (uname "g") [XMLAttr (uname "pointer-events") "fill"] (map (elementToXMLNode width height) elements) elementToXMLNode :: Int Int SVGElement -> XMLNode elementToXMLNode width height node = case node of (SVGRect sid bounds rx ry styles) = XMLElem (uname "rect") ( getID sid ++ getBoundsWidth bounds ++ [ XMLAttr (uname "rx") (toString ry) , XMLAttr (uname "ry") (toString ry) ] ++ map styleToXMLAttr styles ) [] (SVGEllipse sid ((x1,y1),(x2,y2)) styles) = XMLElem (uname "ellipse") ( getID sid ++ [ XMLAttr (uname "cx") (toString ((getX x1 + getX x2) / 2)) , XMLAttr (uname "cy") (toString ((getY y1 + getY y2) / 2)) , XMLAttr (uname "rx") (toString ((getX x2 - getX x1) / 2)) , XMLAttr (uname "ry") (toString ((getY y2 - getY y1) / 2)) ] ++ map styleToXMLAttr styles ) [] (SVGLine sid ((x1,y1),(x2,y2)) styles) = XMLElem (uname "line") ( getID sid ++ [ XMLAttr (uname "x1") (toString (getX x1)) , XMLAttr (uname "y1") (toString (getY y1)) , XMLAttr (uname "x2") (toString (getX x2)) , XMLAttr (uname "y2") (toString (getY y2)) ] ++ map styleToXMLAttr styles ) [] (SVGPolygon sid points styles) = XMLElem (uname "polygon") ( getID sid ++ [ XMLAttr (uname "points") (foldr (+++) "" (map (\(x,y) -> toString (getX x) +++ "," +++ toString (getY y) +++ " ") points)) ] ++ map styleToXMLAttr styles ) [] (SVGPath sid d styles) = XMLElem (uname "path") ( getID sid ++ [ XMLAttr (uname "d") d ] ++ map styleToXMLAttr styles ) [] (SVGText sid (x,y) text styles) = XMLElem (uname "text") ( getID sid ++ [ XMLAttr (uname "x") (toString (getX x)) , XMLAttr (uname "y") (toString (getY y)) ] ++ map styleToXMLAttr styles ) [XMLText text] (SVGImage sid bounds image styles) = XMLElem (uname "image") ( getID sid ++ getBoundsWidth bounds ++ [ XMLAttr (qname "xlink" "href") image ] ++ map styleToXMLAttr styles ) [] (SVGGroup sid elements) = XMLElem (uname "g") (getID sid) (map (elementToXMLNode width height) elements) where getID :: SVGId -> [XMLAttr] getID Nothing = [] getID (Just sid) = [XMLAttr (uname "id") sid] getBoundsWidth :: SVGBounds -> [XMLAttr] getBoundsWidth ((x1,y1),(x2,y2)) = [ XMLAttr (uname "x") (toString (getX x1)) , XMLAttr (uname "y") (toString (getY y1)) , XMLAttr (uname "width") (toString (getX x2 - getX x1)) , XMLAttr (uname "height") (toString (getY y2 - getY y1)) ] getX :: SVGPosX -> Int getX XLeft = 0 getX XRight = width getX (XAbs x) = x getX (XPct p) = (p * width / 100) getY :: SVGPosY -> Int getY YTop = 0 getY YBottom = height getY (YAbs y) = y getY (YPct p) = (p * height / 100) styleToXMLAttr :: SVGStyle -> XMLAttr styleToXMLAttr (SVGStroke s) = XMLAttr (uname "stroke") s styleToXMLAttr (SVGFill s) = XMLAttr (uname "fill") s styleToXMLAttr (SVGStrokeWidth w) = XMLAttr (uname "stroke-width") (toString w) styleToXMLAttr (SVGStrokeDashArray a) = XMLAttr (uname "stroke-dasharray") (toString a) styleToXMLAttr (SVGStrokeLineCap s) = XMLAttr (uname "stroke-linecap") s styleToXMLAttr (SVGStrokeLineJoin s) = XMLAttr (uname "stroke-linejoin") s styleToXMLAttr (SVGStrokeMiterLimit l) = XMLAttr (uname "stroke-miterlimit") (toString l) styleToXMLAttr (SVGMarkerEnd m) = XMLAttr (uname "marker-end") m styleToXMLAttr (SVGFontWeight w) = XMLAttr (uname "font-weight") w styleToXMLAttr (SVGAlign s) = XMLAttr (qname "oryx" "align") s styleToXMLAttr (SVGAnchors s) = XMLAttr (qname "oryx" "anchors") s styleToXMLAttr (SVGEdgePosition s) = XMLAttr (qname "oryx" "edgePosition") s styleToXMLAttr (SVGResize s) = XMLAttr (qname "oryx" "resize") s