Source

ocaml-lib / intrel.ml

(*
#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 domain_inter : R1.t -> t -> R1.t
      val range : t -> R1.t
      val range_inter : R1.t -> t -> R1.t
      val forward : t -> R1.t -> R1.t
      val backward : t -> R1.t -> R1.t
      val inter_domain : t -> R1.t -> t
      val diff_domain : t -> R1.t -> t
      val inter_range : t -> R1.t -> t
      val diff_range : t -> R1.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

(*
    module R : sig
      type 'a t
      val dim : 'a t -> int
      val empty : 'a t
      val cardinal : 'a t -> int
      val mem : 'a -> 'a t -> bool
      val add : 'a -> 'a t -> 'a t
      val union : 'a t -> 'a t -> 'a t
    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 domain_inter a p = M.fold (fun x ran res -> if R1.mem x a then R1.add x res else res) p R1.empty

	let range p = M.fold (fun x ran res -> R1.union ran res) p R1.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 R1.union ran' res else res) p R1.empty

	let inter_domain p a = M.fold (fun x ran res -> if R1.mem x a then M.add x ran res else res) p M.empty

	let diff_domain p a = M.fold (fun x ran res -> if R1.mem x a then res else M.add x ran res) p M.empty

	let inter_range p b = 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 diff_range p b = 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 domain_inter a p = M.domain_inter a p

	let range p = M.fold (fun res x ran -> R1.union res ran) R1.empty p

	let range_inter b p = M.fold (fun res x ran -> let ran' = R1.inter ran b in if R1.is_empty ran' then res else R1.union res ran') R1.empty p

	let inter_domain p a =
	  (* M.map (fun x ran -> if R1.mem x a then Some ran else None) p *)
	  M.map_inter (fun x ran _ -> Some ran) p a

	let diff_domain p a =
	  (* M.map (fun x ran -> if R1.mem x a then None else Some ran) p *)
	  M.map_diff (fun x ran -> function None -> Some ran | Some _ -> None) p a

	let inter_range p b = M.map (fun x ran -> let ran' = R1.inter ran b in if R1.is_empty ran' then None else Some ran') p

	let diff_range p b = 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_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)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.