(* $Id: typeddotutil.sml 11 2007-11-02 05:30:42Z tbourke $ *)
|
(* $Id: typeddotutil.sml 62 2008-08-20 11:20:33Z tbourke $
|
|
*
|
|
* Copyright (c) 2008 Timothy Bourke (University of NSW and NICTA)
|
|
* All rights reserved.
|
|
*
|
|
* This program is free software; you can redistribute it and/or modify it
|
|
* under the terms of the "BSD License" which is distributed with the
|
|
* software in the file LICENSE.
|
|
*
|
|
* This program is distributed in the hope that it will be useful, but
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the BSD
|
|
* License for more details.
|
|
*)
|
|
|
structure TypedDotUtil :
|
structure TypedDotUtil :
|
sig
|
sig
|
structure Dot : DOT
|
structure Dot : DOT
|
and GraphAtt : GRAPH_ATTRIBUTE
|
and GraphAtt : GRAPH_ATTRIBUTE
|
and NodeAtt : NODE_ATTRIBUTE
|
and NodeAtt : NODE_ATTRIBUTE
|
and EdgeAtt : EDGE_ATTRIBUTE
|
and EdgeAtt : EDGE_ATTRIBUTE
|
|
|
val augmentGraph : Dot.subgraph * Dot.node list * Dot.edge list
|
val augmentGraph : Dot.subgraph * Dot.node list * Dot.edge list
|
-> Dot.subgraph
|
-> Dot.subgraph
|
|
|
(* Create a path from pinned, invisible, intermediate nodes at the given
|
(* Create a path from pinned, invisible, intermediate nodes at the given
|
* coordinates. The intermediate node names are prefixed: '__nailed:'.
|
* coordinates. The intermediate node names are prefixed: '__nailed:'.
|
* The first path segment has additional attributes given by labelatts. *)
|
* The first path segment has additional attributes given by labelatts. *)
|
val nailPath : EdgeAtt.arrowType ->
|
val nailPath : EdgeAtt.arrowType ->
|
{graph: Dot.subgraph, src: Dot.anchor, dst: Dot.anchor,
|
{graph: Dot.subgraph, src: Dot.anchor, dst: Dot.anchor,
|
nails: NodeAtt.pointf list, atts: EdgeAtt.t list,
|
nails: NodeAtt.pointf list, atts: EdgeAtt.t list,
|
labelatts: EdgeAtt.t list} -> Dot.subgraph
|
labelatts: EdgeAtt.t list} -> Dot.subgraph
|
end
|
end
|
=
|
=
|
struct
|
struct
|
structure Dot = TypedDot
|
structure Dot = TypedDot
|
and GraphAtt = TypedAttributes.Graph
|
and GraphAtt = TypedAttributes.Graph
|
and NodeAtt = TypedAttributes.Node
|
and NodeAtt = TypedAttributes.Node
|
and EdgeAtt = TypedAttributes.Edge
|
and EdgeAtt = TypedAttributes.Edge
|
|
|
fun augmentGraph (Dot.Subgraph {name, attributes, nodeAtts, edgeAtts, nodes,
|
fun augmentGraph (Dot.Subgraph {name, attributes, nodeAtts, edgeAtts, nodes,
|
subgraphs, edges}, newnodes, newedges)
|
subgraphs, edges}, newnodes, newedges)
|
= Dot.Subgraph {name=name, attributes=attributes,
|
= Dot.Subgraph {name=name, attributes=attributes,
|
nodeAtts=nodeAtts, edgeAtts=edgeAtts, subgraphs=subgraphs,
|
nodeAtts=nodeAtts, edgeAtts=edgeAtts, subgraphs=subgraphs,
|
nodes=newnodes @ nodes, edges=newedges @ edges}
|
nodes=newnodes @ nodes, edges=newedges @ edges}
|
|
|
local
|
local
|
val pathId = ref 0
|
val pathId = ref 0
|
fun freshPathPre () = (String.concat ["__nailed:",
|
fun freshPathPre () = (String.concat ["__nailed:",
|
Int.toString (!pathId), ":"])
|
Int.toString (!pathId), ":"])
|
before (pathId := (!pathId) + 1)
|
before (pathId := (!pathId) + 1)
|
in
|
in
|
fun nailPath ah {graph, src, dst, nails=[], atts, labelatts} = augmentGraph
|
fun nailPath ah {graph, src, dst, nails=[], atts, labelatts} = augmentGraph
|
(graph,[],[Dot.Edge {src=src, dst=dst,
|
(graph,[],[Dot.Edge {src=src, dst=dst,
|
atts=labelatts @ EdgeAtt.ArrowHead ah::atts}])
|
atts=labelatts @ EdgeAtt.ArrowHead ah::atts}])
|
|
|
| nailPath ah {graph, src, dst, nails, atts, labelatts} = let
|
| nailPath ah {graph, src, dst, nails, atts, labelatts} = let
|
val pre = freshPathPre ()
|
val pre = freshPathPre ()
|
fun anchor i = Dot.NodeId
|
fun anchor i = Dot.NodeId
|
(valOf (Dot.Id.fromString (pre^Int.toString i)))
|
(valOf (Dot.Id.fromString (pre^Int.toString i)))
|
|
|
val nailatts =[NodeAtt.NoShape, NodeAtt.PlainLabel "",
|
val nailatts =[NodeAtt.NoShape, NodeAtt.PlainLabel "",
|
NodeAtt.FixedSize, NodeAtt.Pin]
|
NodeAtt.FixedSize, NodeAtt.Pin]
|
fun makeNail (Dot.NodeId id, p) = Dot.Node
|
fun makeNail (Dot.NodeId id, p) = Dot.Node
|
{id=id, atts=NodeAtt.Pos p::nailatts}
|
{id=id, atts=NodeAtt.Pos p::nailatts}
|
| makeNail _ = raise Fail "bad makeNail call."
|
| makeNail _ = raise Fail "bad makeNail call."
|
|
|
val noArrowAtts = EdgeAtt.ArrowHead EdgeAtt.None::atts
|
val noArrowAtts = EdgeAtt.ArrowHead EdgeAtt.None::atts
|
val (clTail, clHead) = (EdgeAtt.NoTailClip, EdgeAtt.NoHeadClip)
|
val (clTail, clHead) = (EdgeAtt.NoTailClip, EdgeAtt.NoHeadClip)
|
|
|
val nailanchors = List.tabulate (length nails, anchor)
|
val nailanchors = List.tabulate (length nails, anchor)
|
val newnodes = ListPair.map makeNail (nailanchors, nails)
|
val newnodes = ListPair.map makeNail (nailanchors, nails)
|
|
|
val newedges = [Dot.Edge {src=src, dst=hd nailanchors,
|
val newedges = [Dot.Edge {src=src, dst=hd nailanchors,
|
atts=(labelatts @ clHead::noArrowAtts)},
|
atts=(labelatts @ clHead::noArrowAtts)},
|
Dot.Path {stops=nailanchors,
|
Dot.Path {stops=nailanchors,
|
atts=clTail::clHead::noArrowAtts},
|
atts=clTail::clHead::noArrowAtts},
|
Dot.Edge {src=List.last nailanchors, dst=dst,
|
Dot.Edge {src=List.last nailanchors, dst=dst,
|
atts=EdgeAtt.ArrowHead ah::clTail::atts}]
|
atts=EdgeAtt.ArrowHead ah::clTail::atts}]
|
|
|
in augmentGraph (graph, newnodes, newedges) end
|
in augmentGraph (graph, newnodes, newedges) end
|
end
|
end
|
|
|
end
|
end
|
|
|
|
|