+108

src/cycles.ml

··· 330 330 331 331 end 332 332 333 333 + module type G = sig 334 334 + type t 335 335 + module V : Sig.COMPARABLE 336 336 + val nb_vertex : t -> int 337 337 + val iter_vertex : (V.t -> unit) -> t -> unit 338 338 + val iter_succ : (V.t -> unit) -> t -> V.t -> unit 339 339 + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a 340 340 + end 341 341 + 342 342 + 343 343 + module Johnson (G: G) : sig 344 344 + 345 345 + val iter_cycles : (G.V.t list -> unit) -> G.t -> unit 346 346 + 347 347 + val fold_cycles : (G.V.t list -> 'a -> 'a) -> G.t -> 'a -> 'a 348 348 + 349 349 + end = struct 350 350 + 351 351 + module VMap = struct 352 352 + module VH = Hashtbl.Make(G.V) 353 353 + 354 354 + let create = VH.create 355 355 + let find = VH.find 356 356 + let add = VH.add 357 357 + let iter = VH.iter 358 358 + end 359 359 + 360 360 + (* The algorithm visits each vertex. 361 361 + For each vertex, it does a depth-first search to find all paths back to 362 362 + the same vertex. *) 363 363 + 364 364 + type vinfo = { 365 365 + (* records whether the vertex has been visited *) 366 366 + mutable visited : bool; 367 367 + 368 368 + (* [blocked] and [blist are used to avoid uselessly iterating over a 369 369 + subgraph from which a cycle can (no longer) be found. *) 370 370 + mutable blocked : bool; 371 371 + mutable blist : G.V.t list; 372 372 + } 373 373 + 374 374 + (* map each vertex to the information above *) 375 375 + let find tbl key = 376 376 + try 377 377 + VMap.find tbl key 378 378 + with Not_found -> 379 379 + let info = { visited = false; blocked = false; blist = [] } in 380 380 + VMap.add tbl key info; 381 381 + info 382 382 + 383 383 + let iter_cycles f_cycle g = 384 384 + let info = VMap.create (G.nb_vertex g) in 385 385 + 386 386 + (* recursively unblock a subgraph *) 387 387 + let rec unblock vi = 388 388 + if vi.blocked then begin 389 389 + vi.blocked <- false; 390 390 + List.iter (fun w -> unblock (find info w)) vi.blist; 391 391 + vi.blist <- []; 392 392 + end 393 393 + in 394 394 + 395 395 + let cycles_from_vertex s = 396 396 + 397 397 + let rec circuit path v vi = 398 398 + 399 399 + let check_succ w cycle_found = 400 400 + if G.V.equal w s (* a cycle is found *) 401 401 + then (f_cycle path; true) 402 402 + else (* keep looking *) 403 403 + let wi = find info w in 404 404 + if not (wi.blocked || wi.visited) then circuit (w::path) w wi 405 405 + else cycle_found 406 406 + in 407 407 + 408 408 + (* v should be unblocked if any of its successors are, since a cycle 409 409 + from v may be found via a newly unblocked successor. *) 410 410 + let unblock_on w = 411 411 + let wi = find info w in 412 412 + wi.blist <- v :: wi.blist 413 413 + in 414 414 + 415 415 + (* not (yet) interested in cycles back to v that do not pass via s *) 416 416 + vi.blocked <- true; 417 417 + if G.fold_succ check_succ g v false (* DFS on successors *) 418 418 + (* if we found a cycle through v then unblock it *) 419 419 + then (unblock vi; true) 420 420 + (* otherwise there's no reason to try again unless something changes *) 421 421 + else (G.iter_succ unblock_on g v; false) 422 422 + in 423 423 + 424 424 + VMap.iter (fun _ info -> 425 425 + info.blocked <- false; 426 426 + info.blist <- []) info; 427 427 + let si = find info s in 428 428 + (* look for elementary cycles back to s *) 429 429 + ignore (circuit [s] s si); 430 430 + si.visited <- true 431 431 + in 432 432 + G.iter_vertex cycles_from_vertex g 433 433 + 434 434 + let fold_cycles f g i = 435 435 + let acc = ref i in 436 436 + iter_cycles (fun cycle -> acc := f cycle !acc) g; 437 437 + !acc 438 438 + 439 439 + end 440 440 +

+33

src/cycles.mli

··· 69 69 val feedback_arc_set : GB.G.t -> GB.G.edge list 70 70 end 71 71 72 72 + (** Minimal graph signature required by {!Johnson}. 73 73 + Sub-signature of {!Sig.G}. *) 74 74 + module type G = sig 75 75 + type t 76 76 + module V : Sig.COMPARABLE 77 77 + val nb_vertex : t -> int 78 78 + val iter_vertex : (V.t -> unit) -> t -> unit 79 79 + val iter_succ : (V.t -> unit) -> t -> V.t -> unit 80 80 + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a 81 81 + end 82 82 + 83 83 + (** Implementation of Johnson's 1975 algoirthm for "Finding all the Elementary 84 84 + Cycles of a Directed Graph". It does not do any preprocessing, i.e., no 85 85 + removal of self-loops and no dissection into strongly connected 86 86 + components. 87 87 + 88 88 + Be aware that a graph with n verticies may contain an exponential number 89 89 + of elementary cycles. *) 90 90 + module Johnson (G: G) : sig 91 91 + 92 92 + (** Calls the callback function for every elemental cycle in the given 93 93 + graph. The argument is the list of vertexes in the cycle in {b reverse 94 94 + order} with no duplicates. For each generated list of vertexes 95 95 + [v0; ...; vi; vj; ...; vn], there exist edges for all [vj] to [vi], 96 96 + and also from [v0] back to [vn]. Use {!Sig.G.find_edge} to recover 97 97 + the edges. *) 98 98 + val iter_cycles : (G.V.t list -> unit) -> G.t -> unit 99 99 + 100 100 + (** A functional interface to [iter_cycles]. *) 101 101 + val fold_cycles : (G.V.t list -> 'a -> 'a) -> G.t -> 'a -> 'a 102 102 + 103 103 + end 104 104 +

+32

tests/test_cycles.expected

··· 1 1 + 2 2 + g1 cycles = 3 3 + cycle 0: 1, 3, 2 4 4 + cycle 1: 2, 4, 3 1 5 cycles1 = { 3 -> 2 } (cycles to no cycles) 6 6 + 7 7 + g1' cycles = 8 8 + 9 9 + g2 cycles = 10 10 + cycle 0: 1, 2, 3 11 11 + cycle 1: 1, 2, 4, 8, 6, 7, 5, 3 12 12 + cycle 2: 1, 2, 4, 8, 7, 5, 3 13 13 + cycle 3: 5, 6, 7 2 14 cycles2 = { 7 -> 5, 3 -> 1 } (cycles to no cycles) 15 15 + 16 16 + g2' cycles = 17 17 + 18 18 + g3 cycles = 19 19 + cycle 0: 1, 2, 6, 4, 3 20 20 + cycle 1: 1, 5, 3 21 21 + cycle 2: 1, 5, 6, 4, 3 22 22 + cycle 3: 2, 6, 4 3 23 cycles3 = { 4 -> 2, 3 -> 1 } (cycles to no cycles) 24 24 + 25 25 + g3' cycles = 26 26 + 27 27 + cycle_5 cycles = 28 28 + cycle 0: 0, 1, 2, 3, 4 29 29 + 30 30 + cycle_10 cycles = 31 31 + cycle 0: 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 32 32 + |full_5| = 84 33 33 + |full_5 (with self loops)| = 89 34 34 + |full_6| = 409 35 35 + |grid_5,5| = 0

+42

tests/test_cycles.ml

··· 13 13 14 14 let pp_comma p () = Format.(pp_print_char p ','; pp_print_space p ()) 15 15 let pp_edge p (s, d) = Format.fprintf p "%d -> %d" s d 16 16 + let pp_vertex p v = Format.fprintf p "%d" v 17 17 + let pp_cycle p i cycle = 18 18 + Format.(fprintf p "@[<hv 2>cycle %d: %a@]@," i 19 19 + (pp_print_list ~pp_sep:pp_comma pp_vertex) 20 20 + (List.rev cycle)) 16 21 17 22 module GP = Persistent.Digraph.Concrete(Int) 18 23 19 24 module GPDFS = Traverse.Dfs (GP) 20 25 26 26 + module GPJ = Cycles.Johnson (GP) 27 27 + 28 28 + module GPC = Classic.P (GP) 29 29 + 21 30 let pp_has_cycles p g = 22 31 if GPDFS.has_cycle g 23 32 then Format.pp_print_string p "cycles" 24 33 else Format.pp_print_string p "no cycles" 25 34 35 35 + let pp_cycles g_name g = 36 36 + Format.printf "@\n%s cycles =@\n@[<v>" g_name; 37 37 + ignore (GPJ.fold_cycles 38 38 + (fun c i -> pp_cycle Format.std_formatter i c; i + 1) g 0); 39 39 + Format.printf "@]" 40 40 + 26 41 module FW = Cycles.Fashwo(struct 27 42 include Builder.P(GP) 28 43 let weight _ = Cycles.Normal 1 ··· 41 56 let cycles1 = FW.feedback_arc_set g1 42 57 let g1' = List.fold_left (fun g (s, d) -> GP.remove_edge g s d) g1 cycles1 43 58 59 59 + let _ = pp_cycles "g1" g1 60 60 + 44 61 let () = 45 62 Format.(printf "cycles1 = @[<hv 2>{ %a }@] (%a to %a)@." 46 63 (pp_print_list ~pp_sep:pp_comma pp_edge) cycles1 47 64 pp_has_cycles g1 48 65 pp_has_cycles g1') 66 66 + 67 67 + let _ = pp_cycles "g1'" g1' 49 68 50 69 (* Eades and Linh, "A Heuristic for the Feedback Arc Set Problem", Fig. 5 *) 51 70 let g2 = ··· 67 86 let g2' = List.fold_left 68 87 (fun g (s, d) -> GP.add_edge (GP.remove_edge g s d) d s) 69 88 g2 cycles2 89 89 + 90 90 + let _ = pp_cycles "g2" g2 70 91 71 92 let () = 72 93 Format.(printf "cycles2 = @[<hv 2>{ %a }@] (%a to %a)@." ··· 74 95 pp_has_cycles g2 75 96 pp_has_cycles g2') 76 97 98 98 + let _ = pp_cycles "g2'" g2' 99 99 + 77 100 (* Eades and Linh, "A Heuristic for the Feedback Arc Set Problem", Fig. 6 *) 78 101 let g3 = 79 102 List.fold_left (fun g (s, d) -> GP.add_edge g s d) GP.empty ··· 92 115 (fun g (s, d) -> GP.add_edge (GP.remove_edge g s d) d s) 93 116 g3 cycles3 94 117 118 118 + let _ = pp_cycles "g3" g3 119 119 + 95 120 let () = 96 121 Format.(printf "cycles3 = @[<hv 2>{ %a }@] (%a to %a)@." 97 122 (pp_print_list ~pp_sep:pp_comma pp_edge) cycles3 98 123 pp_has_cycles g3 99 124 pp_has_cycles g3') 100 125 126 126 + let _ = pp_cycles "g3'" g3' 127 127 + 128 128 + let _ = pp_cycles "cycle_5" (fst (GPC.cycle 5)) 129 129 + let _ = pp_cycles "cycle_10" (fst (GPC.cycle 10)) 130 130 + 131 131 + let _ = Format.printf "|full_5| = %d@." 132 132 + (GPJ.fold_cycles (fun _ -> (+) 1) (GPC.full ~self:false 5) 0) 133 133 + 134 134 + let _ = Format.printf "|full_5 (with self loops)| = %d@." 135 135 + (GPJ.fold_cycles (fun _ -> (+) 1) (GPC.full ~self:true 5) 0) 136 136 + 137 137 + let _ = Format.printf "|full_6| = %d@." 138 138 + (GPJ.fold_cycles (fun _ -> (+) 1) (GPC.full ~self:false 6) 0) 139 139 + 140 140 + let _ = Format.printf "|grid_5,5| = %d@." 141 141 + (GPJ.fold_cycles (fun _ -> (+) 1) (fst (GPC.grid ~n:5 ~m:5)) 0) 142 142 +