## graphtree-g.pkg
#
# See overview comments in
# src/lib/std/graphtree/graphtree.api#
# Nodes are identified by unique integer ids.
# Edges are identified by the ordered pair of nodes they connect.
#
# We maintain three balanced trees, each indexed by node number:
# o node_id -> node
# o node_id -> in-edges for node.
# o node_id -> out-edges for node.
#
# We support subgraphs and supergraphs where
# every node and edge in a graph must also
# be in all of its supergraphs. We (only)
# support explicit creation of a subgraph of
# given graph, so the graphs form a tree with
# the original graph as root.
# Compiled by:
# src/lib/std/standard.lib# This generic package gets compile-time expanded in:
# src/lib/std/graphtree/traitful-graphtree-g.pkg # Graphtree is from src/lib/std/graphtree/graphtree.apigeneric package graphtree_g (
Graph_Info; # Application-specific per-graph record.
Edge_Info; # Application-specific per-edge record.
Node_Info; # Application-specific per-node record.
)
: (weak) Graphtree
{
exception GRAPHTREE_ERROR String;
Graph_Info = Graph_Info; # Re-export these.
Edge_Info = Edge_Info;
Node_Info = Node_Info;
# Key is from src/lib/src/key.api package int_key {
#
Key = Int;
#
fun compare (i: Int, j)
=
if (i < j) LESS;
elif (i == j) EQUAL;
else GREATER;
fi;
};
# Map is from src/lib/src/map.api package im # "im" == "int_map". Used to map node and edge ids to matching records.
=
red_black_map_g( int_key ); # red_black_map_g is from src/lib/src/red-black-map-g.pkg fun set (nodes, id, n) # 'nodes' is graph.nodes.
=
nodes := im::set (*nodes, id, n);
Next_Id_Counters # State used to issue sequential node and edge ID numbers.
=
{ next_node_id: Ref( Int ),
next_edge_id: Ref( Int )
};
Graph = GRAPH
{
root: Null_Or( Graph ), # Root graph in graphtree; same for all graphs in graphtree.
next_id_counters: Next_Id_Counters, # Same for all graphs in graphtree.
#
subgraphs: Ref( List(Graph) ), # All immediate subgraphs of this graph.
supgraphs: Ref( List(Graph) ), # Parent graph. Empty list for root graph, singleton list otherwise.
#
nodes: Ref( im::Map( Node ) ), # Maps a node ID to its Node record.
in_edges: Ref( im::Map( List(Edge) ) ), # Maps a node ID to the list of edges entering that node.
out_edges: Ref( im::Map( List(Edge) ) ), # Maps a node ID to the list of edges leaving that node.
#
info: Graph_Info
}
also
Edge = EDGE { id: Int, # Of the edges in this graphtree, only this edge has this id.
head: Node, # Edge leads from this graph node.
tail: Node, # Edge leads to this graph node.
info: Edge_Info # Arbitrary application-specific edge-associated information.
}
also
Node = NODE { id: Int, # Of the nodes in this graphtree, only this node has this id.
root: Graph, # Root graph of graphtree containing node.
info: Node_Info # Arbitrary application-specific node-associated information.
};
fun eq_graph
( GRAPH { nodes => n, ... },
GRAPH { nodes => n', ... }
)
=
n == n';
fun eq_node
( NODE { root=>r, id=>id, ... },
NODE { root=>r', id=>id', ... }
)
=
id == id' and
eq_graph (r, r');
fun eq_edge
( EDGE { head=>NODE { root=>r, ... }, id=>id, ... },
EDGE { head=>NODE { root=>r', ... }, id=>id', ... }
)
=
id == id' and
eq_graph (r, r');
fun root_of_node (NODE { root, ... } )
=
root;
fun root_of_edge (EDGE { head=>NODE { root, ... }, ... } )
=
root;
fun root_of_graph (g as GRAPH { root=>NULL, ... } ) => g;
root_of_graph ( GRAPH { root=>THE g, ... } ) => g;
end;
fun is_root (GRAPH { root=>NULL, ... } ) => TRUE;
is_root _ => FALSE;
end;
fun graph_info_of (GRAPH { info, ... } ) = info;
fun node_info_of (NODE { info, ... } ) = info;
fun edge_info_of (EDGE { info, ... } ) = info;
fun make_graph info
=
GRAPH
{
root => NULL,
next_id_counters
=>
{ next_node_id => REF 0,
next_edge_id => REF 0
},
info,
#
subgraphs => REF [],
supgraphs => REF [],
#
nodes => REF (im::empty),
in_edges => REF (im::empty),
out_edges => REF (im::empty)
};
fun make_subgraph (g as GRAPH { next_id_counters, subgraphs, ... }, info)
=
subgraph
where
subgraph
=
GRAPH
{
root => THE (root_of_graph g),
next_id_counters,
info,
#
subgraphs => REF [],
supgraphs => REF [g],
#
nodes => REF (im::empty),
in_edges => REF (im::empty),
out_edges => REF (im::empty)
};
subgraphs := subgraph ! *subgraphs;
end;
fun node_count (GRAPH { nodes, ... } )
=
im::vals_count *nodes;
fun edge_count (GRAPH { in_edges, ... } )
=
im::fold_backward
(\\ (l, a) = a+(length l))
0
*in_edges;
# Put an existing node into a graph.
# Used to populate subgraphs with nodes
# from the root graph.
#
# To preserve the invariant that a graph
# contains all nodes present in any of its
# subgraphs, we also insert the node in
# all ancestor graphs, as needed:
#
fun put_node (g, n as NODE { id, root, ... } )
=
{ fun put (g as GRAPH { nodes, supgraphs, ... } )
=
case (im::get (*nodes, id))
#
NULL => { set (nodes, id, n);
apply put *supgraphs;
};
_ => ();
esac;
eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
## #
?? put g # Yes.
:: (raise exception GRAPHTREE_ERROR "graphtree::put_node"); # No.
};
fun make_node (g as GRAPH { next_id_counters => { next_node_id, ... }, nodes, ... }, info)
=
{ id = *next_node_id;
n = NODE { root => root_of_graph g, info, id };
put_node' (id, n) g;
next_node_id := *next_node_id + 1;
n;
}
where
fun put_node' (i as (id, n)) (GRAPH { nodes, supgraphs, ... } )
=
{ set (nodes, id, n);
apply (put_node' i) *supgraphs;
};
end;
fun drop_node (g, NODE { root, id, ... } )
=
{ eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
##
?? rec_rm_node g
:: (raise exception GRAPHTREE_ERROR "graphtree::drop_node");
}
where
fun eq_predicate id (EDGE { id=>eid, ... } )
=
eid == id;
fun foldout
( EDGE { head=>NODE { id=>hid, ... },
tail=>NODE { id=>tid, ... },
id,
...
},
d
)
=
hid == tid ?? d
:: im::set (d, hid, list::remove_first (eq_predicate id) (the (im::get (d, hid))));
fun foldin
( EDGE { head=>NODE { id=>hid, ... },
tail=>NODE { id=>tid, ... },
id,
...
},
d
)
=
hid == tid ?? d
:: im::set (d, tid, list::remove_first (eq_predicate id) (the (im::get (d, tid))));
fun rm_edges (el1, el2, foldfn)
=
case (im::get_and_drop (el1, id))
#
(el1', THE elist) => (el1', list::fold_backward foldfn el2 elist);
_ => (el1, el2);
esac;
fun rm_node (g as GRAPH { nodes, in_edges, out_edges, ... } )
=
{ nodes' = im::drop (*nodes, id);
#
(rm_edges (*out_edges, *in_edges, foldout)) -> (oe, ie);
(rm_edges (ie, oe, foldin )) -> (ie, oe);
in_edges := ie;
out_edges := oe;
nodes := nodes';
TRUE;
}
except
NOT_FOUND = FALSE;
fun rec_rm_node (g as GRAPH { subgraphs, ... } )
=
if (rm_node g)
#
apply rec_rm_node *subgraphs;
fi;
end;
fun nodes (GRAPH { nodes, ... } )
=
im::fold_backward
(\\ (n, l) = n ! l)
[]
*nodes;
fun nodes_fold fldf (GRAPH { nodes, ... } ) seed
=
im::fold_backward
(\\ (n, b) = fldf (n, b))
seed
*nodes;
fun nodes_apply f (GRAPH { nodes, ... } )
=
im::apply
(\\ n = f n)
*nodes;
# Add an edge to a graph.
# Used to populate both root graph
# and subgraphs.
#
# To preserve the invariant that a graph
# contains all edges present in any of its
# subgraphs, we also insert the edge in
# all ancestor graphs, as needed:
#
fun make_edge
{ graph,
info,
#
tail => tail as NODE { root=>tr, id=>tid, ... },
head => head as NODE { root=>hr, id=>hid, ... }
}
=
if (eq_graph (root_of_graph graph, hr)
and eq_graph (hr, tr))
graph -> GRAPH { next_id_counters => { next_edge_id, ... }, ... };
id = *next_edge_id;
edge = EDGE { info, id, head, tail };
put_edge (edge, hid, tid) graph;
next_edge_id := *next_edge_id + 1;
edge;
else
raise exception GRAPHTREE_ERROR "graphtree::make_edge";
fi
where
fun put_edge
(i as (e, hid, tid))
(GRAPH { in_edges, out_edges, supgraphs, ... })
=
{ il = the (im::get (*in_edges, hid)) except _ = []; # "il" == "in_list"
ol = the (im::get (*out_edges, tid)) except _ = []; # "ol" == "out_list"
in_edges := im::set (*in_edges, hid, e ! il);
out_edges := im::set (*out_edges, tid, e ! ol);
apply (put_edge i) *supgraphs;
};
end;
exception NOT_FOUND;
fun drop_edge (g, EDGE { head=>NODE { root, id=>hid, ... }, tail=>NODE { id=>tid, ... }, id, ... } )
=
{
fun remove []
=>
raise exception NOT_FOUND;
remove ((e as EDGE { id=>eid, ... } ) ! rest)
=>
eid == id ?? rest
:: e ! (remove rest);
end;
fun update (edge_dict, id)
=
case (im::get (*edge_dict, id))
#
NULL => FALSE;
THE l =>
{ edge_dict := im::set( *edge_dict, id, remove l);
TRUE;
}
except
NOT_FOUND = FALSE;
esac;
fun rm_edge (GRAPH { out_edges, in_edges, ... } )
=
update (in_edges, hid) and
update (out_edges, tid);
fun rec_rm_edge (g as GRAPH { subgraphs, ... } ) # "rec" may be "recursive" here.
=
if (rm_edge g)
#
apply rec_rm_edge *subgraphs;
fi;
eq_graph (root_of_graph g, root) # Check that edge belongs to this graphtree.
##
?? rec_rm_edge g
:: (raise exception GRAPHTREE_ERROR "graphtree::drop_edge");
};
fun in_edges (g as GRAPH { in_edges, ... }, NODE { root, id, ... } )
=
eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
##
?? (the (im::get (*in_edges, id)) except _ = [])
:: (raise exception GRAPHTREE_ERROR "graphtree::in_edges");
fun out_edges (g as GRAPH { out_edges, ... }, NODE { root, id, ... } )
=
eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
##
?? (the (im::get (*out_edges, id)) except _ = [])
:: (raise exception GRAPHTREE_ERROR "graphtree::out_edges");
fun in_edges_apply f (g as GRAPH { in_edges, ... }, NODE { root, id, ... } )
=
eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
##
?? apply f (the (im::get (*in_edges, id)) except _ = [])
:: (raise exception GRAPHTREE_ERROR "graphtree::apply_in_edges");
fun out_edges_apply f (g as GRAPH { out_edges, ... }, NODE { root, id, ... } )
=
eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
##
?? apply f (the (im::get (*out_edges, id)) except _ = [])
:: (raise exception GRAPHTREE_ERROR "graphtree::apply_out_edges");
fun edges g
=
nodes_fold
(\\ (n, l) = (out_edges (g, n))@l)
g
[];
fun head (EDGE { head, ... } ) = head;
fun tail (EDGE { tail, ... } ) = tail;
fun nodes_of (EDGE { tail, head, ... } )
=
{ head, tail };
fun has_node (g as GRAPH { nodes, ... }, NODE { root, id, ... } )
=
eq_graph (root_of_graph g, root) # Check that node belongs to this graphtree.
and
case (im::get (*nodes, id))
#
NULL => FALSE;
_ => TRUE;
esac;
fun has_edge
(g as GRAPH { nodes, in_edges, ... },
EDGE { id, head => NODE { root, id=>hid, ... }, tail, ... }
)
=
{ fun eq_predicate (EDGE { id=>eid, ... } )
=
eid == id;
eq_graph (root_of_graph g, root) # Check that edge belongs to this graphtree.
and
case (im::get (*in_edges, hid))
#
NULL => FALSE ;
THE el => case (list::find eq_predicate el)
#
NULL => FALSE;
_ => TRUE;
esac;
esac;
};
}; # generic package graphtree_g
## COPYRIGHT (c) 1994 AT&T Bell Laboratories.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.