graphml_to_tikz.hs

-- Forked from http://stackoverflow.com/a/21246951
	{-# LANGUAGE Arrows #-}
	import Text.XML.HXT.Core
	import qualified Data.Map.Strict as M

-- data types
	type Color = String
	type Coord = (Double,Double,Double,Double) -- (x,y,w,h)
	type Visual = (String,Maybe Color,Stroke) -- (glyph,fill,stroke)
	type Stroke = (Maybe Color,Double) -- (color,width)
	type NodeId = String
	type Node = (NodeId,Coord,Visual)
	type EdgeId = String
	type EdgeArrow = String
	type Edge = ((NodeId,NodeId),(EdgeArrow,EdgeArrow),Stroke) -- ((source,target),type,stroke)
	type Label = String

	data Graph = Graph {
			graphId :: String,
			meta :: [String],
			nodes :: M.Map NodeId Node,
			edges :: M.Map EdgeId Edge,
			nodeLabels :: M.Map NodeId Label,
			edgeLabels :: M.Map EdgeId Label
		} deriving (Show, Eq)

-- tree navigation
	atTag tag = atTagPath [tag]
	atDeepTag tag = atDeepTagPath [tag]
	atTagPath [] = returnA
	atTagPath (tag:ts) = getChildren >>> isElem >>> hasName tag >>> atTagPath ts
	atDeepTagPath ts = deep (atTagPath ts)

-- graphml parsing
	readColor :: String -> Color
	readColor = id

	parseGraph = atDeepTag "graph" >>>
		proc g -> do
			graphId' <- g >- getAttrValue "id"
			meta'    <- g >- listA $ atTag "data" >>> getChildren >>> getText
			nodes'   <- g >- listA parseNodes
			edges'   <- g >- listA parseEdges
			nodeL    <- g >- listA parseNodeLabels
			edgeL    <- g >- listA parseEdgeLabels
			returnA  -< Graph {
				graphId=graphId', 
				meta = meta', 
				nodes=M.fromList nodes', 
				edges=M.fromList edges', 
				nodeLabels=M.fromList nodeL,
				edgeLabels=M.fromList edgeL
			}

	parseNodeLabels = atDeepTag "node" >>> getAttrValue "id" &&& (
		atDeepTagPath ["y:NodeLabel"] >>> getChildren >>. take 1 >>> hasText (any (not.(`elem` " \t\n"))) >>> getText)

	parseEdgeLabels = atDeepTag "edge" >>> getAttrValue "id" &&& (
		atDeepTagPath ["y:EdgeLabel"] >>> getChildren >>. take 1 >>> hasText (any (not.(`elem` " \t\n"))) >>> getText)

	parseNodes = atDeepTag "node" >>>
		proc n -> do
			(nodeId,shape) <- n >- getAttrValue "id" &&& atTagPath ["data","y:ShapeNode"]
			geom  <- shape >- atTag "y:Geometry"
			x     <- geom  >- getAttrValue "x"
			y     <- geom  >- getAttrValue "y"
			w     <- geom  >- getAttrValue "width"
			h     <- geom  >- getAttrValue "height"
			glyph <- shape >- atTag "y:Shape" >>> getAttrValue "type"
			fill  <- shape >- atTag "y:Fill"  >>> 
				(getAttrValue "hasColor" >>> isA (=="false") >>> constA Nothing)`orElse`(getAttrValue "color" >>> arr Just)
			(borderCol, borderWidth) <- shape >- atTag "y:BorderStyle" >>> 
				(getAttrValue "hasColor" >>> isA (=="false") >>> constA Nothing)`orElse`(getAttrValue "color" >>> arr Just) &&& 
				getAttrValue "width"
			returnA -< (nodeId, (
				nodeId,
				(read x,read y,read w,read h),
				(glyph,fmap readColor fill,(fmap readColor borderCol, read borderWidth))))

	parseEdges = atDeepTag "edge" >>> 
		proc e -> do
			eid <- e >- getAttrValue "id"
			(s,t) <- e >- getAttrValue "source" &&& getAttrValue "target"
			(se,te) <- e >- atDeepTag "y:Arrows" >>> getAttrValue "source" &&& getAttrValue "target"
			(c,w) <- e >- atDeepTag "y:LineStyle" >>> getAttrValue "color" &&& getAttrValue "width"
			returnA -< (eid,((s,t),(se,te),(Just $ readColor c,read w)))

-- tikz generation
	color :: Color -> String
	color "" = "FFFFFF"
	color p = tail p

	tikzGraph :: Graph -> String
	tikzGraph g = concat [
		"\\begin{tikzpicture}[x=1pt,y=1pt,font=\\fontsize{120}{144}\\selectfont]\n",
		concat $ meta g,"\n",
		M.foldr (++) "" $ M.map tikzNode $ nodes g,
		M.foldr (++) "" $ M.map tikzEdge $ edges g,
		M.foldr (++) "" $ M.mapWithKey (tikzLabel g) $ nodeLabels g,
		M.foldr (++) "" $ M.mapWithKey (tikzEdgeLabel g) $ edgeLabels g,
		"\\end{tikzpicture}\n"
		]

	tikzLabel :: Graph -> NodeId -> Label -> String
	tikzLabel _ nid l = concat [
		"\\node at (",nid,") {",l,"};\n"
		]

	tikzEdgeLabel :: Graph -> EdgeId -> Label -> String
	tikzEdgeLabel g eid l = concat [
		"\\node at (",show ((x1+w1/2+x2+w2/2)/2),",",show (-(y1+h1/2+y2+h2/2)/2),") {",l,"};\n"
		]
		where {
			Just ((fid,tid),_,_)   = M.lookup eid (edges g);
			Just (_,(x1,y1,w1,h1),_) = M.lookup fid (nodes g);
			Just (_,(x2,y2,w2,h2),_) = M.lookup tid (nodes g)
		}

	tikzNode :: Node -> String
	tikzNode (name,(x,y,w,h),(glyph,maybeFill,(maybeBorder,width))) = concat [
			"{\n",
			maybe "" (\border -> concat ["\t\\definecolor{cdraw}{HTML}{",color border,"}\n"]) maybeBorder,
			maybe "" (\fill   -> concat ["\t\\definecolor{cfill}{HTML}{",color fill  ,"}\n"]) maybeFill,
			"\t\\node[",
				"fill=",maybe "none" (const "cfill") maybeFill,",",
				"draw=",maybe "none" (const "cdraw") maybeBorder,",",
				case glyph of
					"roundrectangle" -> "rounded corners"
					"triangle" -> "regular polygon,regular polygon sides=3"
					"hexagon" -> "regular polygon,regular polygon sides=6"
					"octagon" -> "regular polygon,regular polygon sides=8"
					g -> g
				,
				",",
				"line width=",show width,",",
				"minimum width=",show w,",",
				"minimum height=",show h,"]\n",
			"\t\t(",name,") at (",show (x+w/2),",",show (-(y+h/2)),") {};\n",
			"}\n"
		]

	tikzEdge :: Edge -> String
	tikzEdge ((f,t),(se,te),(maybeBorder,width)) = 
		maybe "" (\border -> concat [
			"{\n",
			"\t\\definecolor{cdraw}{HTML}{",color border,"}\n",
			"\t\\draw[",edgeType,",cdraw,line width=",show width,"] (",f,") -- (",t,");\n",
			"}\n"
		]) maybeBorder
		where edgeType = 
			if ((se,te)==("none","none"))
				then ""
				else concat ["{",tikzArrow se,"}-{",tikzArrow te,"}"]

	tikzArrow :: EdgeArrow -> String
	tikzArrow e = case e of
		"none" -> ""
		"standard" -> "stealth"
		"delta" -> "triangle 45"
		"short" -> "triangle 90"
		"white_delta" -> "open triangle 45"
		"t_shape" -> "|"
		"transparent_circle" -> "o"
		"circle" -> "*"
		"white_diamond" -> "open diamond"
		"plain" -> "angle 45"
		_ -> e

-- entry point
	main :: IO()
	main = do
		graphs <- runX (readDocument [withValidate no] "" >>> parseGraph)
		putStr.concat $ fmap tikzGraph graphs
		return ()