simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 03:05:28 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

updated LazyGraph to use Sequence rather than Gen (simpler)

Browse source
This commit is contained in:
Simon Cruanes 2013-10-03 21:21:34 +02:00
parent 7fa9ddfbcf
commit d828eca3f6
5 changed files with 193 additions and 257 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -4,7 +4,7 @@ IMPLEMENTATION_FILES = $(shell find -name '*.ml')
TARGETS_LIB = containers.cmxa containers.cma TARGETS_LIB = containers.cmxa containers.cma
TARGETS_DOC = containers.docdir/index.html TARGETS_DOC = containers.docdir/index.html
EXAMPLES = examples/mem_size.native examples/collatz.native examples/crawl.native EXAMPLES = examples/mem_size.native examples/collatz.native # examples/crawl.native
OPTIONS = -use-ocamlfind OPTIONS = -use-ocamlfind

2
examples/collatz.ml
View file

@ -10,7 +10,7 @@ let collatz n filename =
Format.printf "print graph to %s@." filename; Format.printf "print graph to %s@." filename;
let out = open_out filename in let out = open_out filename in
let fmt = Format.formatter_of_out_channel out in let fmt = Format.formatter_of_out_channel out in
LazyGraph.Dot.pp ~name:"collatz" g fmt (Gen.singleton n); LazyGraph.Dot.pp ~name:"collatz" g fmt (Sequence.singleton n);
Format.pp_print_flush fmt (); Format.pp_print_flush fmt ();
close_out out close_out out

18
examples/mem_size.ml
View file

@ -1,17 +1,17 @@
(** Compute the memory footprint of a value (and its subvalues). Reference is (** Compute the memory footprint of a value (and its subvalues). Reference is
http://rwmj.wordpress.com/2009/08/05/ocaml-internals-part-2-strings-and-other-types/ *) http://rwmj.wordpress.com/2009/08/05/ocaml-internals-part-2-strings-and-other-types/ *)
open Gen.Infix open Sequence.Infix
(** A graph vertex is an Obj.t value *) (** A graph vertex is an Obj.t value *)
let graph = let graph =
let force x = let force x =
if Obj.is_block x if Obj.is_block x
then then
let children = Gen.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in let children = Sequence.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in
LazyGraph.Node (x, Obj.tag x, children) LazyGraph.Node (x, Obj.tag x, children)
else else
LazyGraph.Node (x, Obj.obj x, Gen.empty) LazyGraph.Node (x, Obj.obj x, Sequence.empty)
in LazyGraph.make ~eq:(==) force in LazyGraph.make ~eq:(==) force
let word_size = Sys.word_size / 8 let word_size = Sys.word_size / 8
@ -24,13 +24,13 @@ let size x =
let compute_size x = let compute_size x =
let o = Obj.repr x in let o = Obj.repr x in
let vertices = LazyGraph.bfs graph o in let vertices = LazyGraph.bfs graph o in
Gen.fold (fun sum (o',_,_) -> size o' + sum) 0 vertices Sequence.fold (fun sum (o',_,_) -> size o' + sum) 0 vertices
let print_val fmt x = let print_val fmt x =
let o = Obj.repr x in let o = Obj.repr x in
let graph' = LazyGraph.map ~edges:(fun i -> [`Label (string_of_int i)]) let graph' = LazyGraph.map ~edges:(fun i -> [`Label (string_of_int i)])
~vertices:(fun v -> [`Label (string_of_int v); `Shape "box"]) graph in ~vertices:(fun v -> [`Label (string_of_int v); `Shape "box"]) graph in
LazyGraph.Dot.pp ~name:"value" graph' fmt (Gen.singleton o) LazyGraph.Dot.pp ~name:"value" graph' fmt (Sequence.singleton o)
let print_val_file filename x = let print_val_file filename x =
let out = open_out filename in let out = open_out filename in
@ -46,7 +46,7 @@ let process_val ~name x =
module ISet = Set.Make(struct type t = int let compare = compare end) module ISet = Set.Make(struct type t = int let compare = compare end)
let mk_circ n = let mk_circ n =
let start = Gen.to_list (1--n) in let start = Sequence.to_list (1--n) in
(* make the end of the list point to its beginning *) (* make the end of the list point to its beginning *)
let rec cycle l = match l with let rec cycle l = match l with
| [] -> assert false | [] -> assert false
@ -57,10 +57,10 @@ let mk_circ n =
start start
let _ = let _ =
let s = Gen.fold (fun s x -> ISet.add x s) ISet.empty (1--100) in let s = Sequence.fold (fun s x -> ISet.add x s) ISet.empty (1--100) in
process_val ~name:"foo" s; process_val ~name:"foo" s;
let l = Gen.to_list (Gen.map (fun i -> Gen.to_list (i--(i+42))) let l = Sequence.to_list (Sequence.map (fun i -> Sequence.to_list (i--(i+42)))
(Gen.of_list [0;100;1000])) in (Sequence.of_list [0;100;1000])) in
process_val ~name:"bar" l; process_val ~name:"bar" l;
let l' = mk_circ 100 in let l' = mk_circ 100 in
process_val ~name:"baaz" l'; process_val ~name:"baaz" l';

395
lazyGraph.ml
View file

@ -41,7 +41,7 @@ type ('id, 'v, 'e) t = {
other vertices, or to Empty if the identifier is not part of the graph. *) other vertices, or to Empty if the identifier is not part of the graph. *)
and ('id, 'v, 'e) node = and ('id, 'v, 'e) node =
| Empty | Empty
| Node of 'id * 'v * ('e * 'id) Gen.t | Node of 'id * 'v * ('e * 'id) Sequence.t
(** A single node of the graph, with outgoing edges *) (** A single node of the graph, with outgoing edges *)
and ('id, 'e) path = ('id * 'e * 'id) list and ('id, 'e) path = ('id * 'e * 'id) list
(** A reverse path (from the last element of the path to the first). *) (** A reverse path (from the last element of the path to the first). *)
@ -56,7 +56,7 @@ let empty =
let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label = let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label =
let force v' = let force v' =
if eq v v' then Node (v, label, Gen.empty) else Empty in if eq v v' then Node (v, label, Sequence.empty) else Empty in
{ force; eq; hash; } { force; eq; hash; }
let make ?(eq=(=)) ?(hash=Hashtbl.hash) force = let make ?(eq=(=)) ?(hash=Hashtbl.hash) force =
@ -69,7 +69,7 @@ let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f =
let force v = let force v =
match f v with match f v with
| None -> Empty | None -> Empty
| Some (l, edges) -> Node (v, l, Gen.of_list edges) in | Some (l, edges) -> Node (v, l, Sequence.of_list edges) in
{ eq; hash; force; } { eq; hash; force; }
(** {2 Polymorphic map} *) (** {2 Polymorphic map} *)
@ -113,7 +113,7 @@ module Mutable = struct
let map = mk_map ~eq ~hash in let map = mk_map ~eq ~hash in
let force v = let force v =
try let node = map.map_get v in try let node = map.map_get v in
Node (v, node.mut_v, Gen.of_list node.mut_outgoing) Node (v, node.mut_v, Sequence.of_list node.mut_outgoing)
with Not_found -> Empty in with Not_found -> Empty in
let graph = { eq; hash; force; } in let graph = { eq; hash; force; } in
map, graph map, graph
@ -157,116 +157,115 @@ module Full = struct
| [] -> false | [] -> false
let bfs_full graph vertices = let bfs_full graph vertices =
fun () -> Sequence.from_iter (fun k ->
let explored = mk_map ~eq:graph.eq ~hash:graph.hash in let explored = mk_map ~eq:graph.eq ~hash:graph.hash in
let id = ref 0 in let id = ref 0 in
let q = Queue.create () in (* queue of nodes to explore *) let q = Queue.create () in (* queue of nodes to explore *)
Gen.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices; Sequence.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices;
let rec next () = while not (Queue.is_empty q) do
if Queue.is_empty q then raise Gen.EOG else match Queue.pop q with
match Queue.pop q with | FullEnter (v', path) ->
| FullEnter (v', path) -> if not (explored.map_mem v')
if explored.map_mem v' then next () then begin match graph.force v' with
else begin match graph.force v' with | Empty -> ()
| Empty -> next () | Node (_, label, edges) ->
| Node (_, label, edges) -> explored.map_add v' ();
explored.map_add v' (); (* explore neighbors *)
(* explore neighbors *) Sequence.iter
Gen.iter (fun (e,v'') ->
(fun (e,v'') -> let path' = (v'',e,v') :: path in
let path' = (v'',e,v') :: path in Queue.push (FullFollowEdge path') q)
Queue.push (FullFollowEdge path') q) edges;
edges; (* exit node afterward *)
(* exit node afterward *) Queue.push (FullExit v') q;
Queue.push (FullExit v') q; (* return this vertex *)
(* return this vertex *) let i = !id in
let i = !id in incr id;
incr id; k (EnterVertex (v', label, i, path))
EnterVertex (v', label, i, path) end
end | FullExit v' -> k (ExitVertex v')
| FullExit v' -> ExitVertex v' | FullFollowEdge [] -> assert false
| FullFollowEdge [] -> assert false | FullFollowEdge (((v'', e, v') :: path) as path') ->
| FullFollowEdge (((v'', e, v') :: path) as path') -> (* edge path .... v' --e--> v'' *)
(* edge path .... v' --e--> v'' *) if explored.map_mem v''
if explored.map_mem v'' then if mem_path ~eq:graph.eq path v''
then if mem_path ~eq:graph.eq path v'' then k (MeetEdge (v'', e, v', EdgeBackward))
then MeetEdge (v'', e, v', EdgeBackward) else k (MeetEdge (v'', e, v', EdgeTransverse))
else MeetEdge (v'', e, v', EdgeTransverse) else begin
else begin (* explore this edge *)
(* explore this edge *) Queue.push (FullEnter (v'', path')) q;
Queue.push (FullEnter (v'', path')) q; k (MeetEdge (v'', e, v', EdgeForward))
MeetEdge (v'', e, v', EdgeForward) end
end done)
in next
let dfs_full graph vertices = let dfs_full graph vertices =
fun () -> Sequence.from_iter (fun k ->
let explored = mk_map ~eq:graph.eq ~hash:graph.hash in let explored = mk_map ~eq:graph.eq ~hash:graph.hash in
let id = ref 0 in let id = ref 0 in
let s = Stack.create () in (* stack of nodes to explore *) let s = Stack.create () in (* stack of nodes to explore *)
Gen.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices; Sequence.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices;
let rec next () = while not (Stack.is_empty s) do
if Stack.is_empty s then raise Gen.EOG else match Stack.pop s with
match Stack.pop s with | FullExit v' -> k (ExitVertex v')
| FullExit v' -> ExitVertex v' | FullEnter (v', path) ->
| FullEnter (v', path) -> if not (explored.map_mem v')
if explored.map_mem v' then next () (* explore the node now *)
(* explore the node now *) then begin match graph.force v' with
else begin match graph.force v' with | Empty ->()
| Empty -> next () | Node (_, label, edges) ->
| Node (_, label, edges) -> explored.map_add v' ();
explored.map_add v' (); (* prepare to exit later *)
(* prepare to exit later *) Stack.push (FullExit v') s;
Stack.push (FullExit v') s; (* explore neighbors *)
(* explore neighbors *) Sequence.iter
Gen.iter (fun (e,v'') ->
(fun (e,v'') -> Stack.push (FullFollowEdge ((v'', e, v') :: path)) s)
Stack.push (FullFollowEdge ((v'', e, v') :: path)) s) edges;
edges; (* return this vertex *)
(* return this vertex *) let i = !id in
let i = !id in incr id;
incr id; k (EnterVertex (v', label, i, path))
EnterVertex (v', label, i, path) end
end | FullFollowEdge [] -> assert false
| FullFollowEdge [] -> assert false | FullFollowEdge (((v'', e, v') :: path) as path') ->
| FullFollowEdge (((v'', e, v') :: path) as path') -> (* edge path .... v' --e--> v'' *)
(* edge path .... v' --e--> v'' *) if explored.map_mem v''
if explored.map_mem v'' then if mem_path ~eq:graph.eq path v''
then if mem_path ~eq:graph.eq path v'' then k (MeetEdge (v'', e, v', EdgeBackward))
then MeetEdge (v'', e, v', EdgeBackward) else k (MeetEdge (v'', e, v', EdgeTransverse))
else MeetEdge (v'', e, v', EdgeTransverse) else begin
else begin (* explore this edge *)
(* explore this edge *) Stack.push (FullEnter (v'', path')) s;
Stack.push (FullEnter (v'', path')) s; k (MeetEdge (v'', e, v', EdgeForward))
MeetEdge (v'', e, v', EdgeForward) end
end done)
in next
end end
let bfs graph v = let bfs graph v =
Gen.filterMap Sequence.fmap
(function (function
| Full.EnterVertex (v, l, i, _) -> Some (v, l, i) | Full.EnterVertex (v, l, i, _) -> Some (v, l, i)
| _ -> None) | _ -> None)
(Full.bfs_full graph (Gen.singleton v)) (Full.bfs_full graph (Sequence.singleton v))
let dfs graph v = let dfs graph v =
Gen.filterMap Sequence.fmap
(function (function
| Full.EnterVertex (v, l, i, _) -> Some (v, l, i) | Full.EnterVertex (v, l, i, _) -> Some (v, l, i)
| _ -> None) | _ -> None)
(Full.dfs_full graph (Gen.singleton v)) (Full.dfs_full graph (Sequence.singleton v))
(** {3 Mutable heap (taken from heap.ml to avoid dependencies)} *) (** {3 Mutable heap} *)
module Heap = struct module Heap = struct
(** Implementation from http://en.wikipedia.org/wiki/Skew_heap *)
type 'a t = { type 'a t = {
mutable tree : 'a tree; mutable tree : 'a tree;
cmp : 'a -> 'a -> int; cmp : 'a -> 'a -> int;
} (** A splay tree heap with the given comparison function *) } (** A pairing tree heap with the given comparison function *)
and 'a tree = and 'a tree =
| Empty | Empty
| Node of ('a tree * 'a * 'a tree) | Node of 'a * 'a tree * 'a tree
(** A splay tree containing values of type 'a *)
let empty ~cmp = { let empty ~cmp = {
tree = Empty; tree = Empty;
@ -278,56 +277,22 @@ module Heap = struct
| Empty -> true | Empty -> true
| Node _ -> false | Node _ -> false
(** Partition the tree into (elements <= pivot, elements > pivot) *) let rec union ~cmp t1 t2 = match t1, t2 with
let rec partition ~cmp pivot tree = | Empty, _ -> t2
match tree with | _, Empty -> t1
| Empty -> Empty, Empty | Node (x1, l1, r1), Node (x2, l2, r2) ->
| Node (a, x, b) -> if cmp x1 x2 <= 0
if cmp x pivot <= 0 then Node (x1, union ~cmp t2 r1, l1)
then begin else Node (x2, union ~cmp t1 r2, l2)
match b with
| Empty -> (tree, Empty)
| Node (b1, y, b2) ->
if cmp y pivot <= 0
then
let small, big = partition ~cmp pivot b2 in
Node (Node (a, x, b1), y, small), big
else
let small, big = partition ~cmp pivot b1 in
Node (a, x, small), Node (big, y, b2)
end else begin
match a with
| Empty -> (Empty, tree)
| Node (a1, y, a2) ->
if cmp y pivot <= 0
then
let small, big = partition ~cmp pivot a2 in
Node (a1, y, small), Node (big, x, b)
else
let small, big = partition ~cmp pivot a1 in
small, Node (big, y, Node (a2, x, b))
end
(** Insert the element in the tree *)
let insert h x = let insert h x =
let small, big = partition ~cmp:h.cmp x h.tree in h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree
let tree' = Node (small, x, big) in
h.tree <- tree'
(** Get minimum value and remove it from the tree *) let pop h = match h.tree with
let pop h =
let rec delete_min tree = match tree with
| Empty -> raise Not_found | Empty -> raise Not_found
| Node (Empty, x, b) -> x, b | Node (x, l, r) ->
| Node (Node (Empty, x, b), y, c) -> h.tree <- union ~cmp:h.cmp l r;
x, Node (b, y, c) (* rebalance *) x
| Node (Node (a, x, b), y, c) ->
let m, a' = delete_min a in
m, Node (a', x, Node (b, y, c))
in
let m, tree' = delete_min h.tree in
h.tree <- tree';
m
end end
(** Node used to rebuild a path in A* algorithm *) (** Node used to rebuild a path in A* algorithm *)
@ -357,7 +322,7 @@ let a_star graph
?(distance=(fun v1 e v2 -> 1.)) ?(distance=(fun v1 e v2 -> 1.))
~goal ~goal
start = start =
fun () -> Sequence.from_iter (fun k ->
(* map node -> 'came_from' cell *) (* map node -> 'came_from' cell *)
let nodes = mk_map ~eq:graph.eq ~hash:graph.hash in let nodes = mk_map ~eq:graph.eq ~hash:graph.hash in
(* priority queue for nodes to explore *) (* priority queue for nodes to explore *)
@ -367,51 +332,8 @@ let a_star graph
let start_cell = let start_cell =
{cf_explored=false; cf_cost=0.; cf_node=start; cf_prev=CFStart; } in {cf_explored=false; cf_cost=0.; cf_node=start; cf_prev=CFStart; } in
nodes.map_add start start_cell; nodes.map_add start start_cell;
(* generator *)
let rec next () =
if Heap.is_empty h then raise Gen.EOG else
(* next vertex *)
let dist, v' = Heap.pop h in
(* data for this vertex *)
let cell = nodes.map_get v' in
if (not cell.cf_explored) || ignore v' then begin
(* 'explore' the node *)
on_explore v';
cell.cf_explored <- true;
match graph.force v' with
| Empty -> next ()
| Node (_, label, edges) ->
(* explore neighbors *)
Gen.iter
(fun (e,v'') ->
let cost = dist +. distance v' e v'' +. heuristic v'' in
let cell' =
try nodes.map_get v''
with Not_found ->
(* first time we meet this node *)
let cell' = {cf_cost=cost; cf_explored=false;
cf_node=v''; cf_prev=CFEdge (e, cell); } in
nodes.map_add v'' cell';
cell'
in
if not cell'.cf_explored
then Heap.insert h (cost, v'') (* new node *)
else if cost < cell'.cf_cost
then begin (* put the node in [h] with a better cost *)
Heap.insert h (cost, v'');
cell'.cf_cost <- cost; (* update best cost/path *)
cell'.cf_prev <- CFEdge (e, cell);
end)
edges;
(* check whether the node we just explored is a goal node *)
if goal v'
then (* found a goal node! yield it *)
dist, mk_path nodes [] v'
else next () (* continue exploring *)
end
else next () (* node already explored *)
(* re_build the path from [v] to [start] *) (* re_build the path from [v] to [start] *)
and mk_path nodes path v = let rec mk_path nodes path v =
let node = nodes.map_get v in let node = nodes.map_get v in
match node.cf_prev with match node.cf_prev with
| CFStart -> path | CFStart -> path
@ -419,7 +341,48 @@ let a_star graph
let v' = node'.cf_node in let v' = node'.cf_node in
let path' = (v', e, v) :: path in let path' = (v', e, v) :: path in
mk_path nodes path' v' mk_path nodes path' v'
in next in
(* explore nodes in the heap order *)
while not (Heap.is_empty h) do
(* next vertex *)
let dist, v' = Heap.pop h in
(* data for this vertex *)
let cell = nodes.map_get v' in
if (not cell.cf_explored) || ignore v' then begin
(* 'explore' the node *)
on_explore v';
cell.cf_explored <- true;
match graph.force v' with
| Empty -> ()
| Node (_, label, edges) ->
(* explore neighbors *)
Sequence.iter
(fun (e,v'') ->
let cost = dist +. distance v' e v'' +. heuristic v'' in
let cell' =
try nodes.map_get v''
with Not_found ->
(* first time we meet this node *)
let cell' = {cf_cost=cost; cf_explored=false;
cf_node=v''; cf_prev=CFEdge (e, cell); } in
nodes.map_add v'' cell';
cell'
in
if not cell'.cf_explored
then Heap.insert h (cost, v'') (* new node *)
else if cost < cell'.cf_cost
then begin (* put the node in [h] with a better cost *)
Heap.insert h (cost, v'');
cell'.cf_cost <- cost; (* update best cost/path *)
cell'.cf_prev <- CFEdge (e, cell);
end)
edges;
(* check whether the node we just explored is a goal node *)
if goal v'
(* found a goal node! yield it *)
then k (dist, mk_path nodes [] v')
end
done)
(** Shortest path from the first node to the second one, according (** Shortest path from the first node to the second one, according
to the given (positive!) distance function. The path is reversed, to the given (positive!) distance function. The path is reversed,
@ -428,24 +391,24 @@ let dijkstra graph ?on_explore ?(ignore=fun v -> false)
?(distance=fun v1 e v2 -> 1.) v1 v2 = ?(distance=fun v1 e v2 -> 1.) v1 v2 =
let paths = let paths =
a_star graph ?on_explore ~ignore ~distance ~heuristic:(fun _ -> 0.) a_star graph ?on_explore ~ignore ~distance ~heuristic:(fun _ -> 0.)
~goal:(fun v -> graph.eq v v2) v1 in ~goal:(fun v -> graph.eq v v2) v1
let paths = Gen.start paths in in
try match Sequence.to_list (Sequence.take 1 paths) with
Gen.Gen.next paths | [] -> raise Not_found
with Gen.EOG -> | [x] -> x
raise Not_found | _ -> assert false
(** Is the subgraph explorable from the given vertex, a Directed (** Is the subgraph explorable from the given vertex, a Directed
Acyclic Graph? *) Acyclic Graph? *)
let is_dag graph v = let is_dag graph v =
Gen.for_all Sequence.for_all
(function (function
| Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false
| _ -> true) | _ -> true)
(Full.dfs_full graph (Gen.singleton v)) (Full.dfs_full graph (Sequence.singleton v))
let is_dag_full graph vs = let is_dag_full graph vs =
Gen.for_all Sequence.for_all
(function (function
| Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false
| _ -> true) | _ -> true)
@ -458,28 +421,6 @@ let rev_path p =
| (v,e,v')::p' -> rev ((v',e,v)::acc) p' | (v,e,v')::p' -> rev ((v',e,v)::acc) p'
in rev [] p in rev [] p
(** [limit_depth g depth start] returns the same graph as [graph], but
keeping only nodes that are at distance at most [depth] from
some vertex in [start] (which must be finite). *)
let limit_depth g depth start =
assert (depth >= 0);
(* compute set of vertices which are within the required distance *)
let set = mk_map ~eq:g.eq ~hash:g.hash in
let open Gen.Infix in
Full.bfs_full g start
|> Gen.takeWhile
(function
| Full.EnterVertex (id, _, _, path) -> List.length path <= depth
| _ -> true)
|> Gen.iter
(function
| Full.EnterVertex (id, _, _, _) -> set.map_add id ()
| _ -> ());
let force v =
if not (set.map_mem v) then Empty
else g.force v
in {g with force=force; }
(** {2 Lazy transformations} *) (** {2 Lazy transformations} *)
let union ?(combine=fun x y -> x) g1 g2 = let union ?(combine=fun x y -> x) g1 g2 =
@ -489,7 +430,7 @@ let union ?(combine=fun x y -> x) g1 g2 =
| ((Node _) as n), Empty -> n | ((Node _) as n), Empty -> n
| Empty, ((Node _) as n) -> n | Empty, ((Node _) as n) -> n
| Node (_, l1, e1), Node (_, l2, e2) -> | Node (_, l1, e1), Node (_, l2, e2) ->
Node (v, combine l1 l2, Gen.append e1 e2) Node (v, combine l1 l2, Sequence.append e1 e2)
in { eq=g1.eq; hash=g1.hash; force; } in { eq=g1.eq; hash=g1.hash; force; }
let map ~vertices ~edges g = let map ~vertices ~edges g =
@ -497,7 +438,7 @@ let map ~vertices ~edges g =
match g.force v with match g.force v with
| Empty -> Empty | Empty -> Empty
| Node (_, l, edges_enum) -> | Node (_, l, edges_enum) ->
let edges_enum' = Gen.map (fun (e,v') -> (edges e), v') edges_enum in let edges_enum' = Sequence.map (fun (e,v') -> (edges e), v') edges_enum in
Node (v, vertices l, edges_enum') Node (v, vertices l, edges_enum')
in { eq=g.eq; hash=g.hash; force; } in { eq=g.eq; hash=g.hash; force; }
@ -508,9 +449,9 @@ let flatMap f g =
match g.force v with match g.force v with
| Empty -> Empty | Empty -> Empty
| Node (_, l, edges_enum) -> | Node (_, l, edges_enum) ->
let edges_enum' = Gen.flatMap let edges_enum' = Sequence.flatMap
(fun (e, v') -> (fun (e, v') ->
Gen.map (fun v'' -> e, v'') (f v')) Sequence.map (fun v'' -> e, v'') (f v'))
edges_enum in edges_enum in
Node (v, l, edges_enum') Node (v, l, edges_enum')
in { eq=g.eq; hash=g.hash; force; } in { eq=g.eq; hash=g.hash; force; }
@ -521,7 +462,7 @@ let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g =
| Empty -> Empty | Empty -> Empty
| Node (_, l, edges_enum) when vertices v l -> | Node (_, l, edges_enum) when vertices v l ->
(* filter out edges *) (* filter out edges *)
let edges_enum' = Gen.filter (fun (e,v') -> edges v e v') edges_enum in let edges_enum' = Sequence.filter (fun (e,v') -> edges v e v') edges_enum in
Node (v, l, edges_enum') Node (v, l, edges_enum')
| Node _ -> Empty (* filter out this vertex *) | Node _ -> Empty (* filter out this vertex *)
in { eq=g.eq; hash=g.hash; force; } in { eq=g.eq; hash=g.hash; force; }
@ -533,8 +474,8 @@ let product g1 g2 =
| _, Empty -> Empty | _, Empty -> Empty
| Node (_, l1, edges1), Node (_, l2, edges2) -> | Node (_, l1, edges1), Node (_, l2, edges2) ->
(* product of edges *) (* product of edges *)
let edges = Gen.product edges1 edges2 in let edges = Sequence.product edges1 edges2 in
let edges = Gen.map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in let edges = Sequence.map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in
Node ((v1,v2), (l1,l2), edges) Node ((v1,v2), (l1,l2), edges)
and eq (v1,v2) (v1',v2') = and eq (v1,v2) (v1',v2') =
g1.eq v1 v1' && g2.eq v2 v2' g1.eq v1 v1' && g2.eq v2 v2'
@ -585,17 +526,17 @@ module Dot = struct
(* print preamble *) (* print preamble *)
Format.fprintf formatter "@[<v2>digraph %s {@;" name; Format.fprintf formatter "@[<v2>digraph %s {@;" name;
(* traverse *) (* traverse *)
Gen.iter Sequence.iter
(function (function
| Full.EnterVertex (v, attrs, _, _) -> | Full.EnterVertex (v, attrs, _, _) ->
Format.fprintf formatter " @[<h>%a [%a];@]@." pp_vertex v Format.fprintf formatter " @[<h>%a [%a];@]@." pp_vertex v
(Gen.pp ~sep:"," print_attribute) (Gen.of_list attrs) (Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attrs)
| Full.ExitVertex _ -> () | Full.ExitVertex _ -> ()
| Full.MeetEdge (v2, attrs, v1, _) -> | Full.MeetEdge (v2, attrs, v1, _) ->
Format.fprintf formatter " @[<h>%a -> %a [%a];@]@." Format.fprintf formatter " @[<h>%a -> %a [%a];@]@."
pp_vertex v1 pp_vertex v2 pp_vertex v1 pp_vertex v2
(Gen.pp ~sep:"," print_attribute) (Sequence.pp_seq ~sep:"," print_attribute)
(Gen.of_list attrs)) (Sequence.of_list attrs))
events; events;
(* close *) (* close *)
Format.fprintf formatter "}@]@;@?"; Format.fprintf formatter "}@]@;@?";
@ -619,20 +560,20 @@ let divisors_graph =
if i > 2 if i > 2
then then
let l = divisors [] 2 i in let l = divisors [] 2 i in
let edges = Gen.map (fun i -> (), i) (Gen.of_list l) in let edges = Sequence.map (fun i -> (), i) (Sequence.of_list l) in
Node (i, i, edges) Node (i, i, edges)
else else
Node (i, i, Gen.empty) Node (i, i, Sequence.empty)
in make force in make force
let collatz_graph = let collatz_graph =
let force i = let force i =
if i mod 2 = 0 if i mod 2 = 0
then Node (i, i, Gen.singleton ((), i / 2)) then Node (i, i, Sequence.singleton ((), i / 2))
else Node (i, i, Gen.singleton ((), i * 3 + 1)) else Node (i, i, Sequence.singleton ((), i * 3 + 1))
in make force in make force
let heap_graph = let heap_graph =
let force i = let force i =
Node (i, i, Gen.of_list [(), 2*i; (), 2*i+1]) Node (i, i, Sequence.of_list [(), 2*i; (), 2*i+1])
in make force in make force

33
lazyGraph.mli
View file

@ -44,7 +44,7 @@ type ('id, 'v, 'e) t = {
other vertices, or to Empty if the identifier is not part of the graph. *) other vertices, or to Empty if the identifier is not part of the graph. *)
and ('id, 'v, 'e) node = and ('id, 'v, 'e) node =
| Empty | Empty
| Node of 'id * 'v * ('e * 'id) Gen.t | Node of 'id * 'v * ('e * 'id) Sequence.t
(** A single node of the graph, with outgoing edges *) (** A single node of the graph, with outgoing edges *)
and ('id, 'e) path = ('id * 'e * 'id) list and ('id, 'e) path = ('id * 'e * 'id) list
(** A reverse path (from the last element of the path to the first). *) (** A reverse path (from the last element of the path to the first). *)
@ -70,8 +70,8 @@ val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
(** Build a graph from the [force] function *) (** Build a graph from the [force] function *)
val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
vertices:('id * 'v) Gen.t -> vertices:('id * 'v) Sequence.t ->
edges:('id * 'e * 'id) Gen.t -> edges:('id * 'e * 'id) Sequence.t ->
('id, 'v, 'e) t ('id, 'v, 'e) t
(** Concrete (eager) representation of a Graph (XXX not implemented)*) (** Concrete (eager) representation of a Graph (XXX not implemented)*)
@ -112,21 +112,21 @@ module Full : sig
| EdgeBackward (* toward the current trail *) | EdgeBackward (* toward the current trail *)
| EdgeTransverse (* toward a totally explored part of the graph *) | EdgeTransverse (* toward a totally explored part of the graph *)
val bfs_full : ('id, 'v, 'e) t -> 'id Gen.t -> val bfs_full : ('id, 'v, 'e) t -> 'id Sequence.t ->
('id, 'v, 'e) traverse_event Gen.t ('id, 'v, 'e) traverse_event Sequence.t
(** Lazy traversal in breadth first from a finite set of vertices *) (** Lazy traversal in breadth first from a finite set of vertices *)
val dfs_full : ('id, 'v, 'e) t -> 'id Gen.t -> val dfs_full : ('id, 'v, 'e) t -> 'id Sequence.t ->
('id, 'v, 'e) traverse_event Gen.t ('id, 'v, 'e) traverse_event Sequence.t
(** Lazy traversal in depth first from a finite set of vertices *) (** Lazy traversal in depth first from a finite set of vertices *)
end end
(** The traversal functions assign a unique ID to every traversed node *) (** The traversal functions assign a unique ID to every traversed node *)
val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Gen.t val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Sequence.t
(** Lazy traversal in breadth first *) (** Lazy traversal in breadth first *)
val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Gen.t val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Sequence.t
(** Lazy traversal in depth first *) (** Lazy traversal in depth first *)
val a_star : ('id, 'v, 'e) t -> val a_star : ('id, 'v, 'e) t ->
@ -136,7 +136,7 @@ val a_star : ('id, 'v, 'e) t ->
?distance:('id -> 'e -> 'id -> float) -> ?distance:('id -> 'e -> 'id -> float) ->
goal:('id -> bool) -> goal:('id -> bool) ->
'id -> 'id ->
(float * ('id, 'e) path) Gen.t (float * ('id, 'e) path) Sequence.t
(** Shortest path from the first node to nodes that satisfy [goal], according (** Shortest path from the first node to nodes that satisfy [goal], according
to the given (positive!) distance function. The distance is also returned. to the given (positive!) distance function. The distance is also returned.
[ignore] allows one to ignore some vertices during exploration. [ignore] allows one to ignore some vertices during exploration.
@ -161,17 +161,12 @@ val is_dag : ('id, _, _) t -> 'id -> bool
(** Is the subgraph explorable from the given vertex, a Directed (** Is the subgraph explorable from the given vertex, a Directed
Acyclic Graph? *) Acyclic Graph? *)
val is_dag_full : ('id, _, _) t -> 'id Gen.t -> bool val is_dag_full : ('id, _, _) t -> 'id Sequence.t -> bool
(** Is the Graph reachable from the given vertices, a DAG? See {! is_dag} *) (** Is the Graph reachable from the given vertices, a DAG? See {! is_dag} *)
val rev_path : ('id, 'e) path -> ('id, 'e) path val rev_path : ('id, 'e) path -> ('id, 'e) path
(** Reverse the path *) (** Reverse the path *)
val limit_depth : ('id, 'v, 'e) t -> int -> 'id Gen.t -> ('id, 'v, 'e) t
(** [limit_depth g depth start] returns the same graph as [graph], but
keeping only nodes that are at distance at most [depth] from
some vertex in [start] (which must be finite). *)
(** {2 Lazy transformations} *) (** {2 Lazy transformations} *)
val union : ?combine:('v -> 'v -> 'v) -> val union : ?combine:('v -> 'v -> 'v) ->
@ -184,7 +179,7 @@ val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) ->
('id, 'v, 'e) t -> ('id, 'v2, 'e2) t ('id, 'v, 'e) t -> ('id, 'v2, 'e2) t
(** Map vertice and edge labels *) (** Map vertice and edge labels *)
val flatMap : ('id -> 'id Gen.t) -> val flatMap : ('id -> 'id Sequence.t) ->
('id, 'v, 'e) t -> ('id, 'v, 'e) t ->
('id, 'v, 'e) t ('id, 'v, 'e) t
(** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], (** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn],
@ -219,12 +214,12 @@ module Dot : sig
val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
name:string -> Format.formatter -> name:string -> Format.formatter ->
('id,attribute list,attribute list) Full.traverse_event Gen.t -> ('id,attribute list,attribute list) Full.traverse_event Sequence.t ->
unit unit
val pp : name:string -> ('id, attribute list, attribute list) t -> val pp : name:string -> ('id, attribute list, attribute list) t ->
Format.formatter -> Format.formatter ->
'id Gen.t -> unit 'id Sequence.t -> unit
(** Pretty print the given graph (starting from the given set of vertices) (** Pretty print the given graph (starting from the given set of vertices)
to the channel in DOT format *) to the channel in DOT format *)
end end