1(* 2 * gr_t.sml -- graph implementations based on balanced binary search tress 3 * 4 * COPYRIGHT (c) 1997 by Martin Erwig. See COPYRIGHT file for details. 5 *) 6 7(* 8 structures and functors defined: 9 10 Graph, 11 UnlabGraph: 12 A graph is represented by pair (t,m) where t is a search tree 13 storing labels, predecessors, and successors, and m is 14 the maximum node value in the domain of t. 15 16 GraphFwd, 17 UnlabGraphFwd: 18 Only successors are stored. This speeds up the operations 19 "suc" and "anySuc" that do not access the full context 20 21 Employed utilities: 22 UTuple: 23 p1 (x,y) = x 24 P2 f (x,y) = (x,f y) 25 UList: 26 cons x l = x::l 27 select f p l = map f (filter p l) 28*) 29 30 31local (* local scope for auxiliary definitions *) 32 33(* 34 auxiliary structures: 35 36 AdjUtil utilities on adjacency structures, just the definitions 37 shared by MapUtil and MapUtilFwd 38 MapUtil utilities for (node->context) maps 39 MapUtilFwd utilities for maps, for forward represenation 40 41 ShareAll function definitions shared by all implementations 42 ShareFwd function definitions shared by forward implementations 43*) 44 45structure AdjUtil = 46struct 47 (* 48 updAdj (t,l,f) repeatedly updates the context entries for 49 each node in l by adding either a successor or 50 a predecessor as specified by f 51 updLabAdj ... similar for labeled graphs 52 remFrom (t,v,l,Fi) remove v from the successor or predecessor lists of 53 all nodes in l. 54 T2 : pred in full tree 55 T3 : suc in full tree 56 P2 : suc in fwd tree --> is not used 57 remFromLab ... similar in labeled graphs 58 any selects arbitrary node and apply match or matchFwd 59 *) 60 structure M = IntBinaryMapUpd 61 open GraphExceptions UTuple UGeneral 62 63 fun updAdj (t,[],f) = t 64 | updAdj (t,v::l,f) = updAdj (M.update (t,v,f),l,f) 65 handle Binaryset.NotFound => raise Edge 66 fun updLabAdj (t,[],f) = t 67 | updLabAdj (t,(lab,v)::l,f) = updLabAdj (M.update (t,v,f lab),l,f) 68 handle Binaryset.NotFound => raise Edge 69 fun remFrom (t,v,[],F) = t 70 | remFrom (t,v,x::l,F) = 71 remFrom (M.update (t,x,F (List.filter (neq v))),v,l,F) 72 fun remFromLab (t,v,[],F) = t 73 | remFromLab (t,v,(_,x)::l,F) = 74 remFromLab (M.update (t,x,F (List.filter (neq v o p2))),v,l,F) 75 fun any proj (g as (t,m)) = proj (#1 (valOf (M.findSome t)),g) 76 handle Option => raise Match 77end 78 79structure MapUtil = 80struct 81 (* 82 addSuc, addPred add a node to successor/predecessor list 83 (functions to be passed as arguments to M.update) 84 addLabSuc, 85 addLabPred ... similar for labeled graphs 86 mkContext rearranges map entry to a context value 87 *) 88 open AdjUtil 89 fun addSuc v (l,p,s) = (l,p,v::s) 90 fun addPred v (l,p,s) = (l,v::p,s) 91 fun addLabSuc v lab (l,p,s) = (l,p,(lab,v)::s) 92 fun addLabPred v lab (l,p,s) = (l,(lab,v)::p,s) 93 fun mkContext (n,(l,p,s)) = (p,n,l,s) handle Option => raise Match 94 fun mkFwdAdj (l,p,s) = (l,s) handle Option => raise Match 95 fun mkBwdAdj (l,p,s) = (l,p) handle Option => raise Match 96end 97 98structure MapUtilFwd = 99struct 100 open AdjUtil 101 fun addSuc v (l,s) = (l,v::s) 102 fun addLabSuc v lab (l,s) = (l,(lab,v)::s) 103 fun mkFwd (n,(t,(l,s)),m:int) = ((l,s),(t,if m=n then m-1 else m)) 104end 105 106 107(* 108 shared implementations 109*) 110structure ShareAll = 111struct 112 structure M = IntBinaryMapUpd 113 114 val empty = (M.empty,0) 115 fun isEmpty (t,_) = case (M.findSome t) of NONE=>true | _=>false 116 fun nodes (t,_) = map UTuple.p1 (M.listItemsi t) 117 fun noNodes (t,_) = M.numItems t 118 fun newNodes i (_,m) = UGeneral.to (m+1,m+i) 119end 120 121 122structure ShareFwd = 123struct 124 structure M = IntBinaryMapUpd 125 open GraphExceptions 126 127 fun match _ = raise NotImplemented 128 fun matchAny _ = raise NotImplemented 129 fun matchFwd _ = raise NotImplemented (* must scan all edges to ... *) 130 fun matchAnyFwd _ = raise NotImplemented (* ... remove n from suc-lists *) 131 fun context _ = raise NotImplemented 132 fun bwd _ = raise NotImplemented 133 fun pred _ = raise NotImplemented 134 fun ufold _ _ _ = raise NotImplemented 135 fun gfold _ _ _ _ _ _ = raise NotImplemented 136 fun fwd (n,(t,_)) = valOf (M.find (t,n)) handle Option => raise Match 137 fun labNodes (t,_) = map (UTuple.P2 UTuple.p1) (M.listItemsi t) 138end 139 140 141in (* scope of auxiliary definitions *) 142 143 144structure Graph : GRAPH = 145struct 146 structure M = IntBinaryMapUpd 147 open GraphNode GraphExceptions MapUtil UTuple 148 149 type ('a,'b) graph = ('a * ('b * node) list * ('b * node) list) M.map * int 150 151 structure Types = GraphTypes (struct type ('a,'b) graph=('a,'b) graph end) 152 open Types 153 154 (* exported functions *) 155 156 open ShareAll 157 158 fun embed ((pred,n,l,suc),(t,m)) = 159 case M.find (t,n) of NONE => 160 let val t1 = M.insert (t,n,(l,pred,suc)) 161 val t2 = updLabAdj (t1,pred,addLabSuc n) 162 val t3 = updLabAdj (t2,suc,addLabPred n) 163 in 164 (t3,Int.max (n,m)) 165 end 166 | _ => raise Node 167 168 fun match (n,(t,m)) = 169 let val (t1,(l,p,s)) = M.remove (t,n) 170 val p' = List.filter (neq n o p2) p 171 val s' = List.filter (neq n o p2) s 172 val t2 = remFromLab (t1,n,s',T2) (* rem. n from each pred-list of s *) 173 val t3 = remFromLab (t2,n,p',T3) (* rem. n from each suc-list of p *) 174 in ((p',n,l,s),(t3,if m=n then m-1 else m)) end 175(* 176 handle Binaryset.NotFound => raise Match 177*) 178 handle Binaryset.NotFound => 179 (print ("match "^Int.toString n^" in graph:\n"); 180 map (fn x=>print (Int.toString x^",")) (nodes (t,m)); 181 raise Match) 182 183 fun matchFwd n_g = P1 q34 (match n_g) 184 fun matchAny g = any match g 185 fun matchAnyFwd g = any matchFwd g 186 (* 187 fun matchOrd (n,l,l',g) = let val ((p,_,lab,s),g') = match (n,g) 188 in ((SortEdges.labsort (l,p),n,lab,SortEdges.labsort (l',s)),g') end 189 fun matchOrdFwd (n,l,g) = let val ((lab,s),g') = matchFwd (n,g) 190 in ((lab,SortEdges.labsort (l,s)),g') end 191 *) 192 193 fun context (n,(t,_)) = mkContext (n,valOf (M.find (t,n))) 194 fun fwd (n,(t,_)) = mkFwdAdj (valOf (M.find (t,n))) 195 fun bwd (n,(t,_)) = mkBwdAdj (valOf (M.find (t,n))) 196 fun suc g = map p2 (p2 (fwd g)) 197 fun pred g = map p2 (p2 (bwd g)) 198 fun labNodes (t,_) = map (P2 t1) (M.listItemsi t) 199 200 fun ufold f u g = if isEmpty g then u else 201 let val (c,g') = matchAny g 202 in f (c,ufold f u g') end 203 204 fun gfold f d b u l g = if isEmpty g then u else 205 let fun gfold1 v g = 206 let val (c as (_,_,l,_),g1) = match (v,g) 207 val (r,g2) = gfoldn (f c) g1 208 in (d (l,r),g2) end 209 and gfoldn [] g = (u,g) 210 | gfoldn (v::l) g = 211 let val (x,g1) = gfold1 v g 212 val (y,g2) = gfoldn l g1 213 in (b (x,y),g2) end 214 handle Match => gfoldn l g 215 in 216 #1 (gfoldn l g) 217 end 218 219 fun mkgr (nl,el) = 220 let fun insNodes (t,i,[]) = t 221 | insNodes (t,i,v::l) = insNodes (M.insert (t,i,(v,[],[])),i+1,l) 222 fun insEdges (t,[]) = t 223 | insEdges (t,(v,w,l)::el) = 224 let val t1 = M.update (t,v,addLabSuc w l) 225 val t2 = M.update (t1,w,addLabPred v l) 226 in insEdges (t2,el) end 227 handle Binaryset.NotFound => raise Edge 228 in 229 (insEdges (insNodes (M.empty,0,nl),el),length nl-1) 230 end 231 fun adj (t,_) = map (fn (v,(l,p,s))=>(v,(l,s))) (M.listItemsi t) 232end (* structure Graph *) 233 234 235structure UnlabGraph : UNLAB_GRAPH = 236struct 237 structure M = IntBinaryMapUpd 238 open GraphNode GraphExceptions MapUtil UTuple 239 240 type 'a graph = ('a * node list * node list) M.map * int 241 242 structure Types = UnlabGraphTypes (struct type 'a graph='a graph end) 243 open Types 244 245 (* exported functions *) 246 247 open ShareAll 248 249 fun embed ((pred,n,l,suc),(t,m)) = 250 case M.find (t,n) of NONE => 251 let val t1 = M.insert (t,n,(l,pred,suc)) 252 val t2 = updAdj (t1,pred,addSuc n) 253 val t3 = updAdj (t2,suc,addPred n) 254 in (t3,Int.max (n,m)) end 255 | _ => raise Node 256 257 fun match (n,(t,m)) = 258 let val (t1,(l,p,s)) = M.remove (t,n) 259 val p' = List.filter (neq n) p 260 val s' = List.filter (neq n) s 261 val t2 = remFrom (t1,n,s',T2) (* rem. n from each pred-list of s *) 262 val t3 = remFrom (t2,n,p',T3) (* rem. n from each suc-list of p *) 263 in ((p',n,l,s),(t3,if m=n then m-1 else m)) end 264 handle Binaryset.NotFound => raise Match 265 266 fun matchFwd n_g = P1 q34 (match n_g) 267 fun matchAny g = any match g 268 fun matchAnyFwd g = any matchFwd g 269 fun context (n,(t,_)) = mkContext (n,valOf (M.find (t,n))) 270 fun fwd (n,(t,_)) = mkFwdAdj (valOf (M.find (t,n))) 271 fun bwd (n,(t,_)) = mkBwdAdj (valOf (M.find (t,n))) 272 fun suc g = p2 (fwd g) 273 fun pred g = p2 (bwd g) 274 fun labNodes (t,_) = map (P2 t1) (M.listItemsi t) 275 276 fun ufold f u g = if isEmpty g then u else 277 let val (c,g') = matchAny g 278 in f (c,ufold f u g') end 279 280 fun gfold f d b u l g = if isEmpty g then u else 281 let fun gfold1 v g = 282 let val (c as (_,_,l,_),g1) = match (v,g) 283 val (r,g2) = gfoldn (f c) g1 284 in (d (l,r),g2) end 285 and gfoldn [] g = (u,g) 286 | gfoldn (v::l) g = 287 let val (x,g1) = gfold1 v g 288 val (y,g2) = gfoldn l g1 289 in (b (x,y),g2) end 290 handle Match => gfoldn l g 291 in 292 #1 (gfoldn l g) 293 end 294 295 fun mkgr (nl,el) = 296 let fun insNodes (t,_,[]) = t 297 | insNodes (t,i,v::l) = insNodes (M.insert (t,i,(v,[],[])),i+1,l) 298 fun insEdges (t,[]) = t 299 | insEdges (t,(v,w)::el) = 300 let val t1 = M.update (t,v,addSuc w) 301 val t2 = M.update (t1,w,addPred v) 302 in insEdges (t2,el) end 303 handle Binaryset.NotFound => raise Edge 304 in 305 (insEdges (insNodes (M.empty,0,nl),el),length nl-1) 306 end 307 fun adj (t,_) = map (fn (v,(l,p,s))=>(v,(l,s))) (M.listItemsi t) 308end (* structure UnlabGraph *) 309 310 311structure GraphFwd : GRAPH = 312struct 313 structure M = IntBinaryMapUpd 314 open GraphExceptions MapUtilFwd UTuple 315 316 type ('a,'b) graph = ('a * ('b * GraphNode.node) list) M.map * int 317 318 structure Types = GraphTypes (struct type ('a,'b) graph=('a,'b) graph end) 319 open Types 320 321 (* exported functions *) 322 323 open ShareAll 324 open ShareFwd 325 326 fun embed ((pred,n,l,suc),(t,m)) = 327 case M.find (t,n) of NONE => 328 let val t1 = M.insert (t,n,(l,suc)) 329 val t2 = updLabAdj (t1,pred,addLabSuc n) 330 in 331 (t2,Int.max (n,m)) 332 end 333 | _ => raise Node 334 335 fun matchOrd _ = raise NotImplemented 336 fun matchOrdFwd _ = raise NotImplemented 337 fun suc g = map p2 (p2 (fwd g)) 338 339 fun mkgr (nl,el) = 340 let fun insNodes (t,i,[]) = t 341 | insNodes (t,i,v::l) = insNodes (M.insert (t,i,(v,[])),i+1,l) 342 fun insEdges (t,[]) = t 343 | insEdges (t,(v,w,l)::el) = insEdges (M.update (t,v,addLabSuc w l),el) 344 handle Binaryset.NotFound => raise Edge 345 in 346 (insEdges (insNodes (M.empty,0,nl),el),length nl-1) 347 end 348 fun adj (t,_) = M.listItemsi t 349end (* structure GraphFwd *) 350 351 352structure UnlabGraphFwd : UNLAB_GRAPH = 353struct 354 structure M = IntBinaryMapUpd 355 open GraphNode GraphExceptions MapUtilFwd UTuple 356 357 type 'a graph = ('a * node list) M.map * int 358 359 structure Types = UnlabGraphTypes (struct type 'a graph='a graph end) 360 open Types 361 362 (* exported functions *) 363 364 open ShareAll 365 open ShareFwd 366 367 fun embed ((pred,n,l,suc),(t,m)) = 368 case M.find (t,n) of NONE => 369 let val t1 = M.insert (t,n,(l,suc)) 370 val t2 = updAdj (t1,pred,addSuc n) 371 in 372 (t2,Int.max (n,m)) 373 end 374 | _ => raise Node 375 376 fun suc g = p2 (fwd g) 377 378 fun mkgr (nl,el) = 379 let fun insNodes (t,_,[]) = t 380 | insNodes (t,i,v::l) = insNodes (M.insert (t,i,(v,[])),i+1,l) 381 fun insEdges (t,[]) = t 382 | insEdges (t,(v,w)::el) = insEdges (M.update (t,v,addSuc w),el) 383 handle Binaryset.NotFound => raise Edge 384 in 385 (insEdges (insNodes (M.empty,0,nl),el),length nl-1) 386 end 387 fun adj (t,_) = M.listItemsi t 388end (* structure UnlabGraphFwd *) 389 390end (* of local scope *) 391