Source

ocaml-lib / intset.ml

Diff from to

intset.ml

     val is_empty : t -> bool
     val cardinal : t -> int
     val mem : int -> t -> bool
+    val choose : t -> int (* may raise Not_found *)
     val singleton : int -> t
     val add : int -> t -> t
     val remove : int -> t -> t
     val compl : t -> t
   end
 
+module Set : T =
+  struct
+    module S = Set.Make (struct type t = int let compare x y = Pervasives.compare y x end)
+    type t = S.t
+    let empty = S.empty
+    let is_empty = S.is_empty
+    let cardinal = S.cardinal
+    let mem = S.mem
+    let choose = S.choose
+    let singleton = S.singleton
+    let add = S.add
+    let remove = S.remove
+    let subset = S.subset
+    let union = S.union
+    let inter = S.inter
+    let diff = S.diff
+    let union_r l = List.fold_left (fun res set -> union res set) empty l
+    let inter_r = function
+      | [] -> raise (Invalid_argument "Intset.Set.inter_r : empty list of sets")
+      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+    let fold f s init = S.fold (fun x res -> f res x) init s
+    let iter = S.iter
+    let map f s = S.fold (fun x res -> f x :: res) s []
+    let filter = S.filter
+    let elements = S.elements
+    let memory_size s = 1 + 4 * S.cardinal s
+  end
+
 module Cis : T =
 (* Cis implementation of extents *)
   struct
     let is_empty = Cis.is_empty
     let cardinal = Cis.cardinal
     let mem = Cis.mem
+    let choose = Cis.choose
     let singleton = Cis.singleton
     let add = Cis.add
     let remove = Cis.remove
     let is_empty = LSet.is_empty
     let cardinal = LSet.cardinal
     let mem = LSet.mem
+    let choose = List.hd
     let singleton = LSet.singleton
     let add = LSet.add
     let remove = LSet.remove
     let map = List.map
     let filter = List.filter
     let elements l = l
-    let memory_size l = 1 + (4 * LSet.cardinal l)
+    let memory_size l = 1 + (3 * LSet.cardinal l)
+  end
+
+module Bitmap1 : T_BOUNDED =
+  struct
+    let bound = 1
+
+    type t = bool
+
+    let cardinal i = if i then 1 else 0
+
+    let empty = false
+
+    let is_empty i = not i
+
+    let full = true
+
+    let is_full i = i
+
+    let choose i = if i then 0 else raise Not_found
+
+    let mem x i = i
+
+    let singleton x =
+      assert (x < bound);
+      true
+
+    let add x i =
+      assert (x < bound);
+      true
+
+    let remove x i =
+      false
+
+    let subset i1 i2 =  (not i1) || i2
+
+    let compl i = not i
+
+    let union i1 i2 = i1 || i2
+
+    let inter i1 i2 = i1 && i2
+
+    let diff i1 i2 = i1 && (not i2)
+
+    let union_r l = List.fold_left (fun res set -> union res set) empty l
+
+    let inter_r = function
+      | [] -> raise (Invalid_argument "Intset.Bitmap31.inter_r : empty list of sets")
+      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+
+    let fold f init i = f init 0
+
+    let iter f i = f 0
+
+    let map f e = fold (fun res x -> f x::res) [] e
+	
+    let filter p i = i && (p 0)
+	  
+    let elements e =
+      List.rev (fold (fun res x -> x::res) [] e)
+
+    let memory_size e = 1
   end
 
 module Bitmap31 : T_BOUNDED = (* intsets on [0..31[ *)
     let mem x i =
       (i lsr x) land 1 <> 0
 
+    let choose i =
+      if i = 0
+      then raise Not_found
+      else begin
+	let x = ref 0 in
+	while not (mem !x i) do
+	  incr x
+	done;
+	!x end
+
     let singleton x =
       assert (x < bound);
       (1 lsl x)
   end
 
 
+module Intmap : T with type t = unit Intmap.M.t =
+  struct
+    module M = Intmap.M
+    type t = unit M.t
+    let empty = M.empty
+    let is_empty = M.is_empty
+    let cardinal = M.cardinal
+    let mem = M.mem
+    let choose = M.choose
+    let singleton = M.singleton
+    let add = M.add
+    let remove = M.remove
+    let subset a b = M.subset a b
+    let union a b = M.domain_union a b
+(*
+      let insert a b = M.fold (fun res x _ -> M.add x res) b a in
+      let na, nb = M.cardinal a, M.cardinal b in
+      if na > nb
+      then insert b a
+      else insert a b
+*)
+    let inter a b = M.domain_inter a b
+(*
+      let select a b = M.domain_filter (fun x _ -> M.mem x a) b in
+      let na, nb = M.cardinal a, M.cardinal b in
+      if na > nb
+      then select a b
+      else select b a
+*)
+    let diff a b = M.domain_diff ~filter:(fun x v1 v2 -> v2 = None) a b
+(*
+      let na, nb = M.cardinal a, M.cardinal b in
+      if na > nb
+      then M.fold (fun res x _ -> M.remove x res) a b
+      else M.domain ~filter:(fun x _ -> not (M.mem x b)) a
+*)
+    let union_r l = List.fold_left (fun res set -> union res set) empty l
+    let inter_r = function
+      | [] -> raise (Invalid_argument "Intset.Bitmap961.inter_r : empty list of sets")
+      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+    let fold f = M.fold (fun res x (_ : unit) -> f res x)
+    let iter f = M.iter (fun x (_ : unit) -> f x)
+    let map f = M.fold (fun res x (_ : unit) -> f x :: res) []
+    let filter f = M.domain ~filter:(fun x (_ : unit) -> f x)
+    let elements = M.fold (fun res x (_ : unit) -> x :: res) []
+    let memory_size a = M.memory_size a
+  end
+
+
+(* deprecated
+
 module Bitmap (X : T_BOUNDED) : T_BOUNDED =
   struct
     let bound = 31 * X.bound
       assert (x < bound);
       Obj.repr x
 
-    let simpl e =
-      let e_mask = get_mask e in
-      if e_mask = 0
-      then empty
-      else
-	let n = cardinal_word e_mask in
-	if n = 1 && X.cardinal (get_field e 1) = 1
-	then singleton (List.hd (elements e))
-	else sub e 0 (1 + n) (* for removing extra words *)
-
     let add x e =
       assert (x < bound);
       match kind e with
 	    else e
 	  else e
 
+    let simpl e =
+      let e_mask = get_mask e in
+      if e_mask = 0
+      then empty
+      else
+	let n = cardinal_word e_mask in
+	if n = 1 && X.cardinal (get_field e 1) = 1
+	then singleton (List.hd (elements e))
+	else sub e 0 (1 + n) (* for removing extra words *)
+
 
     let subset e1 e2 =
       let subset_word i1 i2 = i1 land (lnot i2) = 0 in
 	  !res
   end
 
+deprecated *)
+
+
 (* for test *)
 (*
 module M = Bitmap (Bitmap (Bitmap31))
 
 let make l = List.fold_right M.add l M.empty
 *)
-
-(*
-module Bitmaprec (X : T_BOUNDED) : T_BOUNDED =
-  struct
-    let bound = 31 * X.bound
-
-    type t = Obj.t
-       (* empty set : -1 *)
-       (* full set : -2 *)
-       (* singleton : non-negative integer representing unique element *)
-       (* other sets : blocks *)
-	  (* tag indicates level *)
-	  (* field 0 is bitmap of non-empty subsets *)
-	  (* each 1-bit of field 0 refers to a subset *)
-	  (* the number of 1-bits in 'e.(0) lsr (x/X.bound)' gives the field containing the bit x *)
-
-    type kind = Empty | Full | Single of int | Other of Obj.t (* block *)
-
-    let kind e =
-      if Obj.is_int e
-      then
-	let i = (Obj.obj e : int) in
-	if i = -1 then Empty
-	else if i = -2 then Full
-	else Single i
-      else
-	Other e
-
-    (* computing efficiently number of 1-bits in bytes and words *)
-
-    let card_byte =
-      let t = Array.make 256 0 in
-      for i = 0 to 255 do
-	for j = 0 to 7 do
-	  if (i lsr j) land 1 <> 0
-	  then t.(i) <- t.(i) + 1
-	done
-      done;
-      t
-
-    let cardinal_word i =
-      card_byte.(i land 0xFF)
-	+ card_byte.((i lsr 8) land 0xFF)
-	+ card_byte.((i lsr 16) land 0xFF)
-	+ card_byte.((i lsr 24) land 0xFF)
-
-    (* low level access to representations as arrays *)
-	
-    let make m n = (* m is the initial mask, and n the number of fields, comprising the mask *)
-      assert (n > 0);
-      let e = Obj.new_block 0 n in
-      Obj.set_field e 0 (Obj.repr m);
-      e
-
-    let copy e = Obj.dup e
-
-    let sub e pos len =
-      let e' = Obj.new_block 0 len in
-      for i = 0 to len - 1 do
-	Obj.set_field e' i (Obj.field e (pos + i))
-      done;
-      e'
-
-    let length e = Obj.size e
-
-    let get_mask e = (Obj.obj (Obj.field e 0) : int)
-
-    let set_mask e m = Obj.set_field e 0 (Obj.repr m)
-
-    let get_field e i = (Obj.obj (Obj.field e i) : X.t)
-
-    let set_field e i s = Obj.set_field e i (Obj.repr s)
-
-
-    let get_i x1 e =
-      let b = (get_mask e) lsr x1 in
-      assert (b land 1 <> 0);
-      cardinal_word b
-
-    let get_subset x1 e =
-      let b = (get_mask e) lsr x1 in
-      if b land 1 = 0
-      then X.empty
-      else get_field e (cardinal_word b)
-
-    let get_index x e = (* returns coordinates of bit x in e *)
-      let x1, x2 = x / X.bound, x mod X.bound in
-      let b = (get_mask e) lsr x1 in
-      if b land 1 = 0
-      then (cardinal_word b + 1, x1, x2, false)
-      else (cardinal_word b, x1, x2, true)
-      
-    (* bitwise operations *)
-
-    let test i x2 =
-      (i lsr x2) land 1 <> 0
-
-    let set i x2 =
-      i lor (1 lsl x2)
-
-    let reset i x2 =
-      i land ((-1) - (1 lsl x2))
-
-    (* intset interface *)
-
-    let fold f init e =
-      match kind e with
-      | Empty -> init
-      | Full ->
-	  let res = ref init in
-	  for x = 0 to bound - 1 do
-	    res := f !res x
-	  done;
-	  !res
-      | Single x -> f init x
-      | Other e ->
-	  let e_mask = get_mask e in
-	  let res = ref init in
-	  for x1 = 0 to 31 - 1 do
-	    if test e_mask x1 then begin
-	      let i = get_subset x1 e in
-	      let x0 = X.bound * x1 in
-	      res := X.fold (fun res2 x2 -> f res2 (x0 + x2)) !res i
-	    end
-	  done;
-	  !res
-
-    let elements e =
-      List.rev (fold (fun res x -> x::res) [] e)
-
-    let empty = Obj.repr (-1)
-
-    let is_empty e =
-      match kind e with
-      | Empty -> true
-      | Full -> false
-      | Single _ -> false
-      | Other e -> get_mask e = 0
-
-    let full = Obj.repr (-2)
-(*
-      let n = 31 in
-      let e = make (-1) (n + 1) in
-      for i = 1 to n-1 do
-	set_field e i X.full
-      done;
-      e
-*)
-
-    let is_full e =
-      match kind e with
-      | Empty -> false
-      | Full -> true
-      | Single _ -> false
-      | Other e ->
-	  let n = length e in
-	  let res = ref (get_mask e = (-1)) in
-	  let i = ref 1 in
-	  while !res && !i < n do
-	    res := !res && X.is_full (get_field e !i);
-	    incr i
-	  done;
-	  !res
-
-    let cardinal e =
-      match kind e with
-      | Empty -> 0
-      | Full -> bound
-      | Single _ -> 1
-      | Other e ->
-	  let n = length e in
-	  let res = ref 0 in
-	  for i = 1 to n-1 do
-	    res := !res + X.cardinal (get_field e i)
-	  done;
-	  !res
-
-    let mem x e =
-      match kind e with
-      | Empty -> false
-      | Full -> x < bound
-      | Single y -> x = y
-      | Other e ->
-	  let i, _, x2, present = get_index x e in
-	  present && X.mem x2 (get_field e i)
-
-    let singleton x =
-      assert (x < bound);
-      Obj.repr x
-
-    let simpl e =
-      let e_mask = get_mask e in
-      if e_mask = 0
-      then empty
-      else
-	let n = cardinal_word e_mask in
-	if n = 1 && X.cardinal (get_field e 1) = 1
-	then singleton (List.hd (elements e))
-	else sub e 0 (1 + n) (* for removing extra words *)
-
-    let add x e =
-      assert (x < bound);
-      match kind e with
-      | Empty -> singleton x
-      | Full -> e
-      | Single y ->
-	  let x1, x2 = x / X.bound, x mod X.bound in
-	  let y1, y2 = y / X.bound, y mod X.bound in
-	  if x1 = y1
-	  then begin
-	    let e = make (1 lsl x1) 2 in
-	    set_field e 1 (X.add x2 (X.singleton y2));
-	    e end
-	  else begin
-	    let e = make ((1 lsl x1) lor (1 lsl y1)) 3 in
-	    let ix, iy = if x1 < y1 then 2, 1 else 1, 2 in
-	    set_field e ix (X.singleton x2);
-	    set_field e iy (X.singleton y2);
-	    e
-	  end
-      | Other e ->
-	  let i, x1, x2, present = get_index x e in
-	  if present
-	  then
-	    if X.mem x2 (get_field e i)
-	    then e
-	    else begin
-	      let e' = copy e in (* unsafe not to make a copy *)
-	      let e'_x1 = X.add x2 (get_field e' i) in
-	      set_field e' i e'_x1;
-	      if X.is_full e'_x1 && is_full e'
-	      then full
-	      else e'
-	    end
-	  else begin
-	    let n = length e in
-	    let e' = make (set (get_mask e) x1) (n+1) in
-	    for k = 1 to i-1 do
-	      Obj.set_field e' k (Obj.field e k)
-	      (* set_field e' k (get_field e k) *)
-	    done;
-	    for k = n downto i+1 do
-	      Obj.set_field e' k (Obj.field e (k-1))
-	      (* set_field e' k (get_field e (k-1)) *)
-	    done;
-	    set_field e' i (X.singleton x2);
-	    e' end
-
-    let remove x e =
-      match kind e with
-      | Empty -> e
-      | Full ->
-	  if x < bound
-	  then begin
-	    let x1, x2 = x / X.bound, x mod X.bound in
-	    let i = x1 + 1 in
-	    let n = 31 in
-	    let e' = make (-1) (n+1) in
-	    for k = 1 to i-1 do
-	      set_field e' k X.full
-	    done;
-	    set_field e' i (X.remove x2 X.full);
-	    for k = i+1 to n-1 do
-	      set_field e' k X.full
-	    done;
-	    e' end
-	  else e
-      | Single y ->
-	  if x = y
-	  then empty
-	  else e
-      | Other e ->
-	  let i, x1, x2, present = get_index x e in
-	  if present
-	  then
-	    if X.mem x2 (get_field e i)
-	    then
-	      let e'_i = X.remove x2 (get_field e i) in
-	      if X.is_empty e'_i
-	      then begin
-		let n' = length e - 1 in
-		let e' = make (reset (get_mask e) x1) n' in
-		for k = 1 to i-1 do
-		  Obj.set_field e' k (Obj.field e k)
-		  (* set_field e' k (get_field e k) *)
-		done;
-		for k = i to n'-1 do
-		  Obj.set_field e' k (Obj.field e (k+1))
-		  (* set_field e' k (get_field e (k+1)) *)
-		done;
-		if n' = 1
-		then empty
-		else
-		  if n' = 2 && X.cardinal (get_field e' 1) = 1
-		  then singleton (List.hd (elements e'))
-		  else e' end
-	      else begin
-		let e' = copy e in
-		set_field e' i e'_i;
-		e'
-	      end
-	    else e
-	  else e
-
-
-    let subset e1 e2 =
-      let subset_word i1 i2 = i1 land (lnot i2) = 0 in
-      match kind e1, kind e2 with
-      | Empty, _ -> true
-      | _, Full -> true
-      | _, Empty -> is_empty e1
-      | Full, _ -> is_full e2
-      | Single x1, _ -> mem x1 e2
-      | Other e1, Single y ->
-	  let y1, y2 = y / X.bound, y mod X.bound in
-	  if subset_word (get_mask e1) (1 lsl y1)
-	  then X.subset (get_subset y1 e1) (X.singleton y2)
-	  else false
-      | Other e1, Other e2 ->
-	  if not (subset_word (get_mask e1) (get_mask e2))
-	  then false
-	  else begin
-	    let res = ref true in
-	    let x1 = ref 0 in
-	    while !res && !x1 < 31 do
-	      res := not (test (get_mask e1) !x1) || X.subset (get_subset !x1 e1) (get_subset !x1 e2);
-	      incr x1
-	    done;
-	    !res
-	  end
-
-    let compl e1 =
-      match kind e1 with
-      | Empty -> full
-      | Full -> empty
-      | Single x -> remove x full
-      | Other e1 ->
-	  let e1_mask = get_mask e1 in
-	  if e1_mask = 0
-	  then full
-	  else begin
-	    let e = make (-1) (31+1) in
-	    for x1 = 31 - 1 downto 0 do
-	      if test e1_mask x1
-	      then
-		let e_x1 = X.compl (get_subset x1 e1) in
-		if X.is_empty e_x1
-		then set_mask e (reset (get_mask e) x1)
-		else set_field e (get_i x1 e) e_x1
-	      else set_field e (get_i x1 e) X.full
-	    done;
-	    simpl e
-	  end
-
-    let union e1 e2 =
-      let union_word i1 i2 = i1 lor i2 in
-      match kind e1, kind e2 with
-      | Empty, _ -> e2
-      | _, Empty -> e1
-      | Full, _
-      | _, Full -> full
-      | Single x, _ -> add x e2
-      | _, Single y -> add y e1
-      | Other e1, Other e2 ->
-	  let e_mask = union_word (get_mask e1) (get_mask e2) in
-	  let n = cardinal_word e_mask in
-	  let e = make e_mask (n+1) in
-	  for x1 = 0 to 31 - 1 do
-	    if test (get_mask e) x1
-	    then set_field e (get_i x1 e) (X.union (get_subset x1 e1) (get_subset x1 e2))
-	  done;
-	  e
-
-    let inter e1 e2 =
-      let inter_word i1 i2 = i1 land i2 in
-      match kind e1, kind e2 with
-      | Empty, _
-      | _, Empty -> empty
-      | Full, _ -> e2
-      | _, Full -> e1
-      | Single x, _ -> if mem x e2 then e1 else empty
-      | _, Single y -> if mem y e1 then e2 else empty
-      | Other e1, Other e2 ->
-	  let e_mask = inter_word (get_mask e1) (get_mask e2) in
-	  if e_mask = 0
-	  then empty
-	  else begin
-	    let n = cardinal_word e_mask in
-	    let e = make e_mask (n+1) in
-	    for x1 = 31 - 1 downto 0 do
-	      if test (get_mask e) x1
-	      then
-		let e_x1 = X.inter (get_subset x1 e1) (get_subset x1 e2) in
-		if X.is_empty e_x1
-		then set_mask e (reset (get_mask e) x1)
-		else set_field e (get_i x1 e) e_x1
-	    done;
-	    simpl e
-	  end
-
-    let diff e1 e2 =
-(*      let diff_word i1 i2 = i1 land (lnot i2) in *)
-      match kind e1, kind e2 with
-      | Empty, _ -> empty
-      | _, Empty -> e1
-      | Full, _ -> compl e2
-      | _, Full -> empty
-      | Single x, _ -> if mem x e2 then empty else e1
-      | _, Single y -> remove y e1
-      | Other e1, Other e2 ->
-	  let e_mask = get_mask e1 in
-	  let n = cardinal_word e_mask in
-	  let e = make e_mask (n+1) in
-	  for x1 = 31 - 1 downto 0 do
-	    if test (get_mask e) x1
-	    then
-	      let e_x1 = X.diff (get_subset x1 e1) (get_subset x1 e2) in
-	      if X.is_empty e_x1
-	      then set_mask e (reset (get_mask e) x1)
-	      else set_field e (get_i x1 e) e_x1
-	  done;
-	  simpl e
-
-    let union_r l = List.fold_left (fun res set -> union res set) empty l
-
-    let inter_r = function
-      | [] -> raise (Invalid_argument "Intset.Bitmap961.inter_r : empty list of sets")
-      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
-
-    let iter f e =
-      match kind e with
-      | Empty -> ()
-      | Full ->
-	  for x = 0 to bound - 1 do
-	    f x
-	  done
-      | Single x -> f x
-      | Other e ->
-	  let e_mask = get_mask e in
-	  for x1 = 0 to 31 - 1 do
-	    if test e_mask x1 then begin
-	      let i = get_subset x1 e in
-	      let x0 = X.bound * x1 in
-	      X.iter (fun x2 -> f (x0 + x2)) i
-	    end
-	  done
-
-    let map f e = fold (fun res x -> f x::res) [] e
-
-    let filter p e1 =
-      match kind e1 with
-      | Empty -> e1
-      | Full ->
-	  let e_mask = (-1) in
-	  let n = 31 in
-	  let e = make e_mask (n+1) in
-	  for x1 = 31 - 1 downto 0 do
-	    let x0 = X.bound * x1 in
-	    let e_x1 = X.filter (fun x2 -> p (x0 + x2)) X.full in
-	    if X.is_empty e_x1
-	    then set_mask e (reset (get_mask e) x1)
-	    else set_field e (get_i x1 e) e_x1
-	  done;
-	  simpl e
-      | Single x -> if p x then e1 else empty
-      | Other e1 ->
-	  let e_mask = get_mask e1 in
-	  let n = cardinal_word e_mask in
-	  let e = make e_mask (n+1) in
-	  for x1 = 31 - 1 downto 0 do
-	    if test (get_mask e) x1
-	    then
-	      let x0 = X.bound * x1 in
-	      let e_x1 = X.filter (fun x2 -> p (x0 + x2)) (get_subset x1 e1) in
-	      if X.is_empty e_x1
-	      then set_mask e (reset (get_mask e) x1)
-	      else set_field e (get_i x1 e) e_x1
-	  done;
-	  simpl e
-
-    let memory_size e =
-      match kind e with
-      | Empty -> 1
-      | Full -> 1
-      | Single _ -> 1
-      | Other e ->
-	  let n = length e in
-	  let res = ref (1 + n) in
-	  for i = 1 to n-1 do
-	    res := !res + X.memory_size (get_field e i)
-	  done;
-	  !res
-  end
-*)