Commits

Sébastien Ferré committed c246f2f

Initial revision

  • Participants
  • Parent commits d4ce9a3

Comments (0)

Files changed (1)

+(*
+#load "lSet.cmo";;
+#load "cis.cmo";;
+#load "intmap.cmo";;
+#load "intset.cmo";;
+*)
+
+module type T =
+  sig
+    module R1 : Intset.T
+
+    module R2 : sig
+      type t
+      val empty : t
+      val is_empty : t -> bool
+      val cardinal : t -> int
+      val mem : int * int -> t -> bool
+      val domain_mem : int -> t -> bool
+      val range_mem : int -> t -> bool
+      val singleton : int * int -> t
+      val add : int * int -> t -> t
+      val remove : int * int -> t -> t
+      val domain : t -> R1.t
+      val range : t -> R1.t
+      val forward : t -> R1.t -> R1.t
+      val backward : t -> R1.t -> R1.t
+      val domain_inter : R1.t -> t -> t
+      val domain_diff : R1.t -> t -> t
+      val range_inter : R1.t -> t -> t
+      val range_diff : R1.t -> t -> t
+      val union : t -> t -> t
+      val inter : t -> t -> t
+      val diff : t -> t -> t
+      val union_r : t list -> t
+      val inter_r : t list -> t
+      val fold : ('a -> int * int -> 'a) -> 'a -> t -> 'a
+      val memory_size : t -> int
+    end
+  end
+
+module Map : T =
+  struct
+    module R1 = Intset.Set
+
+    module R2 =
+      struct
+	module M = Map.Make (struct type t = int let compare = Pervasives.compare end)
+
+	type t = R1.t M.t
+
+	let empty = M.empty
+
+	let is_empty = M.is_empty
+
+	let cardinal p = M.fold (fun x ran res -> res + R1.cardinal ran) p 0
+
+	let mem (x,y) p = try R1.mem y (M.find x p) with Not_found -> false
+
+	let domain_mem x p = M.mem x p
+
+	let range_mem y p = M.fold (fun x ran res -> res || R1.mem y ran) p false
+
+	let singleton (x,y) = M.add x (R1.singleton y) empty
+
+	let add (x,y) p = M.add x (R1.add y (try M.find x p with Not_found -> R1.empty)) p
+
+	let remove (x,y) p =
+	  try
+	    let ran' = R1.remove y (M.find x p) in
+	    if R1.is_empty ran'
+	    then M.remove x p
+	    else M.add x ran' p
+	  with Not_found -> p
+
+	let domain p = M.fold (fun x ran res -> R1.add x res) p R1.empty
+
+	let range p = M.fold (fun x ran res -> R1.union ran res) p R1.empty
+
+	let domain_inter a p = M.fold (fun x ran res -> if R1.mem x a then M.add x ran res else res) p M.empty
+
+	let domain_diff a p = M.fold (fun x ran res -> if R1.mem x a then res else M.add x ran res) p M.empty
+
+	let range_inter b p = M.fold (fun x ran res -> let ran' = R1.inter ran b in if R1.is_empty ran' then res else M.add x ran' res) p M.empty
+
+	let range_diff b p = M.fold (fun x ran res -> let ran' = R1.diff ran b in if R1.is_empty ran' then res else M.add x ran' res) p M.empty
+
+	let forward p a = M.fold (fun x ran res -> if R1.mem x a then R1.union ran res else res) p R1.empty
+
+	let backward p b = M.fold (fun x ran res -> if R1.is_empty (R1.inter ran b) then res else R1.add x res) p R1.empty
+
+	let union p1 p2 =
+	  M.fold
+	    (fun x ran p ->
+	      let ran' = try R1.union ran (M.find x p) with Not_found -> ran in
+	      M.add x ran' p)
+	    p1 p2
+
+	let inter p1 p2 =
+	  M.fold
+	    (fun x ran p ->
+	      let ran' = try R1.inter ran (M.find x p2) with Not_found -> R1.empty in
+	      if not (R1.is_empty ran')
+	      then M.add x ran' p
+	      else p)
+	    p1 empty
+
+	let diff p1 p2 =
+	  M.fold
+	    (fun x ran p ->
+	      let ran' = try R1.diff ran (M.find x p2) with Not_found -> ran in
+	      if not (R1.is_empty ran')
+	      then M.add x ran' p
+	      else p)
+	    p1 empty
+
+	let union_r l = List.fold_left (fun res set -> union res set) empty l
+
+	let inter_r = function
+	  | [] -> raise (Invalid_argument "Intrel.Map.R2.inter_r : empty list of sets")
+	  | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+
+	let fold f init p = M.fold (fun x ran res -> R1.fold (fun res' y -> f res' (x, y)) res ran) p init
+
+	let memory_size p = M.fold (fun x ran res -> 5 + R1.memory_size ran + res) p 1 (* 1 for root reference *)
+      end
+  end
+
+module Intmap : T =
+  struct
+    module M = Intmap.M
+
+    module R1 = Intset.Intmap
+
+    module R2 =
+      struct
+	type t = R1.t M.t
+
+	let empty = M.empty
+
+	let is_empty = M.is_empty
+
+	let cardinal p = M.fold (fun res x ran -> res + R1.cardinal ran) 0 p
+
+	let mem (x,y) p = try R1.mem y (M.get x p) with Not_found -> false
+
+	let domain_mem x p = M.mem x p
+
+	let range_mem y p = M.fold (fun res x ran -> res || R1.mem y ran) false p
+
+	let singleton (x,y) = M.set x (R1.singleton y) M.empty
+
+	let add (x,y) p = M.set x (R1.add y (try M.get x p with Not_found -> R1.empty)) p
+
+	let remove (x,y) p =
+	  try
+	    let ran' = R1.remove y (M.get x p) in
+	    if R1.is_empty ran'
+	    then M.remove x p
+	    else M.set x ran' p
+	  with Not_found -> p
+
+	let domain p = M.domain p
+
+	let range p = M.fold (fun res x ran -> R1.union res ran) R1.empty p
+
+	let domain_inter a p =
+	  M.map (fun x ran -> if R1.mem x a then Some ran else None) p
+	  (* M.map_inter (fun x _ ran -> Some ran) a p *)
+
+	let domain_diff a p = M.map (fun x ran -> if R1.mem x a then None else Some ran) p
+
+	let range_inter b p = M.map (fun x ran -> let ran' = R1.inter ran b in if R1.is_empty ran' then None else Some ran') p
+
+	let range_diff b p = M.map (fun x ran -> let ran' = R1.diff ran b in if R1.is_empty ran' then None else Some ran') p
+
+	let forward p a =
+	  M.fold (fun res x ran -> if R1.mem x a then R1.union res ran else res) R1.empty p
+	  (* range (M.map_inter (fun x ran _ -> Some ran) p a) *) (* M.map_inter looks buggy *)
+	  (* should be: M.fold_inter (fun res x ran _ -> R1.union res ran) R1.empty p a) *)
+
+	let backward p b = M.domain ~filter:(fun x ran -> let ran' = R1.inter ran b in not (R1.is_empty ran')) p
+
+	let inter =
+	  M.map_inter
+	    (fun x ran1 ran2 ->
+	      let ran = R1.inter ran1 ran2 in
+	      if R1.is_empty ran
+	      then None
+	      else Some ran)
+(*
+	  M.map_filter
+	    (fun x ran ->
+	      try
+		let ran' = R1.inter ran (M.get x q) in
+		if R1.is_empty ran' then None else Some ran'
+	      with Not_found ->
+		None)
+	    p
+*)
+
+	let union =
+	  M.map_union
+	    (fun x ran1_opt ran2_opt ->
+	      match ran1_opt, ran2_opt with
+	      | None, None -> None
+	      | Some _, None -> ran1_opt
+	      | None, Some _ -> ran2_opt
+	      | Some ran1, Some ran2 -> Some (R1.union ran1 ran2))
+(*
+	  let n1, n2 = M.cardinal p1, M.cardinal p2 in
+	  let p_big, p_small = if n1 > n2 then p1, p2 else p2, p1 in
+	  M.fold
+	    (fun p x ran ->
+	      let ran' = try R1.union ran (M.get x p) with Not_found -> ran in
+	      M.set x ran' p)
+	    p_big
+	    p_small
+*)
+
+	let diff =
+	  M.map_diff
+	    (fun x ran1 ran2_opt ->
+	      match ran2_opt with
+	      | None -> Some ran1
+	      | Some ran2 -> Some (R1.diff ran1 ran2))
+(*
+	  M.fold
+	    (fun p x ran1 ->
+	      let ran' = try R1.diff ran1 (M.get x p2) with Not_found -> ran1 in
+	      if not (R1.is_empty ran')
+	      then M.set x ran' p
+	      else p)
+	    empty
+	    p1
+*)
+
+	let union_r l = List.fold_left (fun res set -> union res set) empty l
+
+	let inter_r = function
+	  | [] -> raise (Invalid_argument "Intrel.Intmap.R2.inter_r : empty list of sets")
+	  | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+
+	let fold f init p = M.fold (fun res x ran -> R1.fold (fun res' y -> f res' (x, y)) res ran) init p
+
+	let memory_size p = M.memory_size ~f:R1.memory_size p
+      end
+  end
+
+module Test (X : T) =
+  struct
+    module R1 = X.R1
+    module R2 = X.R2
+
+    let list p = R2.fold (fun res (x,y) -> (x,y) :: res) [] p
+
+    let card p = R2.cardinal p
+
+    let mem p = R2.memory_size p
+
+    let triangle n =
+      let res = ref R2.empty in
+      for i = 1 to n do
+	for j = i to n do
+	  res := R2.add (i,j) !res
+	done
+      done;
+      !res
+
+    let random n k =
+      let res = ref R2.empty in
+      for i = 1 to n do
+	for j = 1 to k do
+	  res := R2.add (i,Random.int n) !res
+	done
+      done;
+      !res
+
+  end
+
+module A = Test (Map)
+module B = Test (Intmap)
+