Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/MLRISC/graphs/digraph.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/graphs/digraph.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 545 - (view) (download)

1 : monnier 245 (*
2 :     * Directed graph in adjacency list format.
3 :     *
4 : monnier 411 * -- Allen
5 : monnier 245 *)
6 :    
7 : george 545 functor DirectedGraph(A : ARRAY) :
8 : monnier 411 sig include GRAPH_IMPLEMENTATION
9 :    
10 :     type 'e adjlist = 'e Graph.edge list A.array
11 :     type 'n nodetable = 'n option A.array
12 :    
13 :     (* This function exposes the internal representation! *)
14 :     val newGraph :
15 :     { name : string,
16 :     info : 'g,
17 :     succ : 'e adjlist,
18 :     pred : 'e adjlist,
19 :     nodes : 'n nodetable
20 :     } -> ('n,'e,'g) Graph.graph
21 :     end =
22 : monnier 245 struct
23 :    
24 :     structure G = Graph
25 :     structure A = A
26 :    
27 : monnier 411 type 'e adjlist = 'e Graph.edge list A.array
28 :     type 'n nodetable = 'n option A.array
29 :    
30 :     fun newGraph{name,info,succ,pred,nodes} =
31 :     let val node_count = ref 0
32 : monnier 245 val edge_count = ref 0
33 :     val entries = ref []
34 :     val exits = ref []
35 :     val new_nodes = ref []
36 :     val garbage_nodes = ref []
37 :     fun new_id() = case ! new_nodes of [] => A.length nodes
38 :     | h::t => (new_nodes := t; h)
39 :     fun garbage_collect () =
40 :     (new_nodes := (!new_nodes) @ (!garbage_nodes); garbage_nodes := [])
41 :     fun get_nodes() =
42 :     A.foldri(fn(i,SOME n,l) =>(i,n)::l|(_,_,l) => l) [] (nodes,0,NONE)
43 : monnier 411 fun get_edges() = List.concat(A.foldr op:: [] succ)
44 : monnier 245 fun order() = !node_count
45 :     fun size() = !edge_count
46 :     fun capacity() = A.length nodes
47 :     fun add_node(i,n) =
48 :     (case A.sub(nodes,i)
49 :     of NONE => node_count := 1 + !node_count
50 :     | _ => ();
51 :     A.update(nodes,i,SOME n)
52 :     )
53 :     fun add_edge(e as (i,j,info)) =
54 :     (A.update(succ,i,e :: A.sub(succ,i));
55 :     A.update(pred,j,e :: A.sub(pred,j));
56 :     edge_count := 1 + !edge_count)
57 :    
58 :     fun set_out_edges(i,edges) =
59 :     let fun removePred([],j,es') = A.update(pred,j,es')
60 :     | removePred((e as (i',_,_))::es,j,es') =
61 :     removePred(es,j,if i' = i then es' else e::es')
62 :     fun removeEdge(i',j,_) =
63 :     (if i <> i' then raise G.Graph "set_out_edges" else ();
64 :     removePred(A.sub(pred,j),j,[]))
65 :     fun addPred(e as (_,j,_)) = A.update(pred,j,e :: A.sub(pred,j))
66 :     val old_edges = A.sub(succ,i)
67 :     in app removeEdge old_edges;
68 :     A.update(succ,i,edges);
69 :     app addPred edges;
70 :     edge_count := !edge_count + length edges - length old_edges
71 :     end
72 :    
73 :     fun set_in_edges(j,edges) =
74 :     let fun removeSucc([],i,es') = A.update(succ,i,es')
75 :     | removeSucc((e as (_,j',_))::es,i,es') =
76 :     removeSucc(es,i,if j' = j then es' else e::es')
77 :     fun removeEdge(i,j',_) =
78 :     (if j <> j' then raise G.Graph "set_in_edges" else ();
79 :     removeSucc(A.sub(succ,i),i,[]))
80 :     fun addSucc(e as (i,_,_)) = A.update(succ,i,e :: A.sub(succ,i))
81 :     val old_edges = A.sub(pred,j)
82 :     in app removeEdge old_edges;
83 :     A.update(pred,j,edges);
84 :     app addSucc edges;
85 :     edge_count := !edge_count + length edges - length old_edges
86 :     end
87 :    
88 :     fun remove_node i =
89 :     case A.sub(nodes,i) of
90 :     NONE => ()
91 :     | SOME _ => (set_out_edges(i,[]);
92 :     set_in_edges(i,[]);
93 :     A.update(nodes,i,NONE);
94 :     node_count := !node_count - 1;
95 :     garbage_nodes := i :: !garbage_nodes)
96 :    
97 :     fun remove_nodes ns = app remove_node ns
98 :     fun set_entries ns = entries := ns
99 :     fun set_exits ns = exits := ns
100 :     fun get_entries() = !entries
101 :     fun get_exits() = !exits
102 :     fun out_edges n = A.sub(succ,n)
103 :     fun in_edges n = A.sub(pred,n)
104 :     fun get_succ n = map #2 (A.sub(succ,n))
105 :     fun get_pred n = map #1 (A.sub(pred,n))
106 :     fun has_edge(i,j) = List.exists (fn (_,k,_) => j = k) (A.sub(succ,i))
107 :     fun has_node n = case A.sub(nodes,n) of
108 :     SOME _ => true | NONE => false
109 :     fun node_info n = case A.sub(nodes,n) of
110 :     SOME x => x
111 :     | NONE => raise G.NotFound
112 :     fun forall_nodes f =
113 :     A.appi (fn (i,SOME x) => f(i,x) | _ => ()) (nodes,0,NONE)
114 :     fun forall_edges f = A.app (List.app f) succ
115 :    
116 :     in G.GRAPH {
117 :     name = name,
118 : monnier 411 graph_info = info,
119 : monnier 245 new_id = new_id,
120 :     add_node = add_node,
121 :     add_edge = add_edge,
122 :     remove_node = remove_node,
123 :     set_in_edges = set_in_edges,
124 :     set_out_edges = set_out_edges,
125 :     set_entries = set_entries,
126 :     set_exits = set_exits,
127 :     garbage_collect = garbage_collect,
128 :     nodes = get_nodes,
129 :     edges = get_edges,
130 :     order = order,
131 :     size = size,
132 :     capacity = capacity,
133 :     out_edges = out_edges,
134 :     in_edges = in_edges,
135 :     succ = get_succ,
136 :     pred = get_pred,
137 :     has_edge = has_edge,
138 :     has_node = has_node,
139 :     node_info = node_info,
140 :     entries = get_entries,
141 :     exits = get_exits,
142 :     entry_edges = fn _ => [],
143 :     exit_edges = fn _ => [],
144 :     forall_nodes = forall_nodes,
145 :     forall_edges = forall_edges
146 :     }
147 :     end
148 :    
149 : monnier 411 fun graph(name,info,n) =
150 :     let val succ = A.array(n,[])
151 :     val pred = A.array(n,[])
152 :     val nodes = A.array(n,NONE)
153 :     in newGraph{name=name,info=info,nodes=nodes,succ=succ,pred=pred} end
154 : monnier 245 end
155 :    
156 : george 545 structure DirectedGraph = DirectedGraph(DynArray)
157 : monnier 245

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0