implementation module GinSVG import StdInt import StdGeneric import StdList import StdString import Maybe import XML, HTML, TUIDefinition from iTasks import ::JSONNode, ::VerSt, ::UpdateMask, ::USt, ::UpdateMode, ::VSt, :: StaticVisualizationMode from iTasks import class iTask, generic gVisualizeText, generic gVisualizeHtml, generic gVisualizeEditor, generic gUpdate, generic gDefaultMask, generic gVerify, generic JSONEncode, generic JSONDecode, generic gEq derive class iTask SVGPosX, SVGPosY, SVGElement, SVGStyle, SVGShape derive class iTask XMLDoc, XMLNode, XMLAttr, XMLQName derive bimap Maybe, (,) 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