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 /MLRISC/trunk/graphs/m.sml
ViewVC logotype

Annotation of /MLRISC/trunk/graphs/m.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 429 - (view) (download)
Original Path: sml/branches/SMLNJ/src/MLRISC/graphs/m.sml

1 : monnier 409 (*
2 :     * Graph minor.
3 :     * Allows contraction of nodes.
4 :     *
5 :     * -- Allen
6 :     *)
7 :     signature GRAPH_MINOR =
8 :     sig
9 :    
10 :     val minor : ('n,'e,'g) Graph.graph ->
11 :     { view : ('n,'e,'g) Graph.graph,
12 :     merge : Graph.node_id list * 'n -> unit,
13 :     == : Graph.node_id * Graph.node_id -> bool,
14 :     partition : Graph.node_id -> Graph.node_id list
15 :     }
16 :    
17 :     end
18 :    
19 :     structure GraphMinor : GRAPH_MINOR =
20 :     struct
21 :    
22 : monnier 429 structure G = Graph
23 :     structure H = HashArray
24 :     structure SL = SortedList
25 : monnier 409
26 :     fun minor (G.GRAPH G : ('n,'e,'g) Graph.graph) =
27 :     let exception NotThere
28 :     val uptree = H.array'(13,fn _ => raise NotThere)
29 :     fun look n = #1(H.sub(uptree,n)) handle _ => n
30 :     fun edge(i,j,e) = (look i,look j,e)
31 :     fun set_in_edges(i,e) = #set_in_edges G (look i,e)
32 :     fun set_out_edges(i,e) = #set_out_edges G (look i,e)
33 :     fun all f n =
34 :     let val (_,nodes,_,_) = H.sub(uptree,n)
35 :     in List.foldr (fn (i,l) => f i @ l) [] nodes
36 :     end handle NotThere => f n
37 :     fun in_edges i = map edge (all (#in_edges G) i)
38 :     fun out_edges i = map edge (all (#out_edges G) i)
39 :     fun pred i = map (look o #1) (all (#in_edges G) i)
40 :     fun succ i = map (look o #2) (all (#out_edges G) i)
41 :     fun entry_edges i = map edge (all (#entry_edges G) i)
42 :     fun exit_edges i = map edge (all (#exit_edges G) i)
43 :     fun has_node n =
44 :     let val (_,_,_,x) = H.sub(uptree,n)
45 :     in x end handle NotThere => #has_node G n
46 :     fun node_info n =
47 :     let val (_,_,n',x) = H.sub(uptree,n)
48 :     in if x then n' else raise G.NotFound
49 :     end handle NotThere => #node_info G n
50 :     fun nodes() =
51 :     List.foldr (fn (node as (n,_),ns) =>
52 :     let val (n,_,n',x) = H.sub(uptree,n)
53 :     in if x then (n,n')::ns else ns
54 :     end handle NotThere => node::ns) [] (#nodes G ())
55 :     fun edges() =
56 :     List.foldr (fn (node as (n,_),es) =>
57 :     let val (n,_,n',x) = H.sub(uptree,n)
58 :     in if x then map edge (#out_edges G n)@es else es
59 :     end handle NotThere => map edge(#out_edges G n)@es) []
60 :     (#nodes G ())
61 :     fun order() = length(nodes())
62 :     fun size() = length(edges())
63 : monnier 429 fun entries() = SL.uniq(map look (#entries G ()))
64 :     fun exits() = SL.uniq(map look (#exits G ()))
65 : monnier 409 fun forall_nodes f = app f (nodes ())
66 :     fun forall_edges f = app f (edges ())
67 :     fun merge([],_) = ()
68 :     | merge(nodes as n::ns,n') =
69 :     let val info = (n,nodes,n',true)
70 :     val info' = (n,nodes,n',false)
71 :     in H.update(uptree,n,info);
72 :     app (fn i => H.update(uptree,i,info')) ns
73 :     end
74 :     fun ==(a,b) = look a = look b
75 :     fun partition n = #2(H.sub(uptree,n)) handle NotThere => [n]
76 :     val view =
77 :     G.GRAPH
78 :     { name = #name G,
79 :     graph_info = #graph_info G,
80 :     new_id = #new_id G,
81 :     add_node = #add_node G,
82 :     add_edge = #add_edge G,
83 :     remove_node = #remove_node G,
84 :     set_in_edges = set_in_edges,
85 :     set_out_edges = set_out_edges,
86 :     set_entries = #set_entries G,
87 :     set_exits = #set_exits G,
88 :     garbage_collect = #garbage_collect G,
89 :     nodes = nodes,
90 :     edges = edges,
91 :     order = order,
92 :     size = size,
93 :     capacity = #capacity G,
94 :     in_edges = in_edges,
95 :     out_edges = out_edges,
96 :     pred = pred,
97 :     succ = succ,
98 :     has_edge = #has_edge G,
99 :     has_node = has_node,
100 :     node_info = node_info,
101 :     entries = entries,
102 :     exits = exits,
103 :     entry_edges = entry_edges,
104 :     exit_edges = exit_edges,
105 :     forall_nodes = forall_nodes,
106 :     forall_edges = forall_edges
107 :     }
108 :     in { view = view,
109 :     merge = merge,
110 :     == = ==,
111 :     partition = partition
112 :     }
113 :     end
114 :     end
115 :    

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