Skip to content

Commit af5f5f6

Browse files
backtrackingbacktracking
committed
persistent bit vectors, wip
1 parent 0926285 commit af5f5f6

File tree

3 files changed

+234
-88
lines changed

3 files changed

+234
-88
lines changed

‎pbv.ml‎

Lines changed: 186 additions & 71 deletions
Original file line numberDiff line numberDiff line change
@@ -21,8 +21,9 @@ module type S = sig
2121
val init: int -> (int -> bool) -> t
2222
val get: t -> int -> bool
2323
val set: t -> int -> bool -> t
24-
val swap: t -> int -> t
24+
val iteri: (int -> bool -> unit) -> t -> unit
2525

26+
val swap: t -> int -> t
2627
val bw_and: t -> t -> t
2728
val bw_or: t -> t -> t
2829
val bw_xor: t -> t -> t
@@ -32,6 +33,13 @@ module type S = sig
3233
val nlz: t -> int
3334
val print: Format.formatter -> t -> unit
3435

36+
val compare: t -> t -> int
37+
val equal: t -> t -> bool
38+
val hash: t -> int
39+
40+
val unsafe_get: t -> int -> bool
41+
val unsafe_set: t -> int -> bool -> t
42+
3543
type size = int
3644
type elt = int
3745
val empty: size -> t
@@ -51,9 +59,8 @@ module type S = sig
5159
val diff: t -> t -> t
5260
val subset: t -> t -> bool
5361
val disjoint: t -> t -> bool
54-
val iter: (elt -> unit) -> t -> unit
55-
val map: (elt -> elt) -> t -> t
56-
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
62+
val iteri_true: (elt -> unit) -> t -> unit
63+
val foldi_true: (elt -> 'a -> 'a) -> t -> 'a -> 'a
5764
val for_all: (elt -> bool) -> t -> bool
5865
val exists: (elt -> bool) -> t -> bool
5966
val filter: (elt -> bool) -> t -> t
@@ -76,29 +83,28 @@ module type S = sig
7683
val add_seq : elt Seq.t -> t -> t
7784
val of_seq : elt Seq.t -> t
7885
val print_set: Format.formatter -> t -> unit
79-
80-
val compare: t -> t -> int
81-
val equal: t -> t -> bool
82-
val hash: t -> int
83-
84-
val unsafe_get: t -> int -> bool
85-
val unsafe_set: t -> int -> bool -> t
8686
end
8787

8888
module SetOps(X: sig
8989
type t
90+
val make: int -> bool -> t
9091
val length: t -> int
9192
val is_empty: t -> bool
9293
val pop: t -> int
9394
val ntz: t -> int
9495
val nlz: t -> int
9596
val get: t -> int -> bool
97+
val unsafe_get: t -> int -> bool
9698
val set: t -> int -> bool -> t
99+
val unsafe_set: t -> int -> bool -> t
97100
val bw_and: t -> t -> t
98101
val bw_or: t -> t -> t
99102
val bw_xor: t -> t -> t
100103
val bw_not: t -> t
104+
val elements: t -> int list
101105
end) = struct
106+
let empty size = X.make size false
107+
let full size = X.make size true
102108
let mem i v = X.get v i
103109
let cardinal = X.pop
104110
let find i s = if mem i s then i else raise Not_found
@@ -118,6 +124,8 @@ end) = struct
118124
X.length v - 1 - X.nlz v
119125
let max_elt_opt v =
120126
if X.is_empty v then None else Some (Sys.int_size - 1 - X.nlz v)
127+
let choose = min_elt
128+
let choose_opt = min_elt_opt
121129
let check_index s v i =
122130
if i < 0 || i >= X.length v then invalid_arg s
123131
let add i v =
@@ -130,6 +138,101 @@ end) = struct
130138
for i = X.length v - 1 downto 0 do
131139
Format.fprintf fmt "%c" (if X.get v i then '1' else '0')
132140
done
141+
142+
let find_first p v =
143+
let rec loop v =
144+
if X.is_empty v then raise Not_found;
145+
let x = min_elt v in
146+
if p x then x else loop (X.unsafe_set v x false) in
147+
loop v
148+
149+
let find_first_opt p v =
150+
try Some (find_first p v) with Not_found -> None
151+
152+
let find_last p v =
153+
let rec loop v =
154+
if X.is_empty v then raise Not_found;
155+
let x = max_elt v in
156+
if p x then x else loop (X.unsafe_set v x false) in
157+
loop v
158+
159+
let find_last_opt p v =
160+
try Some (find_last p v) with Not_found -> None
161+
162+
let rec for_all p v =
163+
X.is_empty v ||
164+
let x = min_elt v in p x && for_all p (X.unsafe_set v x false)
165+
166+
let rec exists p v =
167+
not (X.is_empty v) &&
168+
let x = min_elt v in p x || exists p (X.unsafe_set v x false)
169+
170+
let rec filter p v =
171+
if X.is_empty v then
172+
empty (X.length v)
173+
else
174+
let x = min_elt v in
175+
let v = filter p (X.unsafe_set v x false) in
176+
if p x then add x v else v
177+
178+
let rec filter_map f v =
179+
if X.is_empty v then
180+
empty (X.length v)
181+
else
182+
let x = min_elt v in
183+
let v = filter_map f (X.unsafe_set v x false) in
184+
match f x with
185+
| None -> v
186+
| Some x -> add x v
187+
188+
let rec partition p v =
189+
if X.is_empty v then
190+
let v = empty (X.length v) in v, v
191+
else
192+
let x = min_elt v in
193+
let vt,vf = partition p (X.unsafe_set v x false) in
194+
if p x then add x vt, vf else vt, add x vf
195+
196+
let split x v =
197+
filter (fun y -> y < x) v, X.get v x, filter (fun y -> y > x) v
198+
199+
let print_set fmt v =
200+
let rec pr = function
201+
| [] -> ()
202+
| x :: l ->
203+
Format.fprintf fmt "%d" x; if l <> [] then Format.fprintf fmt ",@,";
204+
pr l
205+
in
206+
Format.fprintf fmt "{";
207+
pr (X.elements v);
208+
Format.fprintf fmt "}"
209+
210+
let of_list l =
211+
List.fold_left (fun s x -> add x s) (empty (List.length l)) l
212+
213+
let of_seq s =
214+
Seq.fold_left (fun v x -> add x v) (empty (Seq.length s)) s
215+
216+
let rec to_seq_from x v =
217+
if x > max_elt v then Seq.empty
218+
else if mem x v then fun () -> Seq.Cons (x, to_seq_from (x + 1) v)
219+
else to_seq_from (x + 1) v
220+
221+
let to_seq v =
222+
if X.is_empty v then Seq.empty else to_seq_from (min_elt v) v
223+
224+
let rec to_rev_seq_from x v =
225+
if x < min_elt v then Seq.empty
226+
else if mem x v then fun () -> Seq.Cons (x, to_rev_seq_from (x - 1) v)
227+
else to_rev_seq_from (x - 1) v
228+
229+
let to_rev_seq v =
230+
if X.is_empty v then Seq.empty else to_rev_seq_from (max_elt v) v
231+
232+
let rec add_seq veq v = match veq () with
233+
| Seq.Nil -> v
234+
| Seq.Cons (x, veq) -> add_seq veq (add x v)
235+
133236
end
134237

135238
let rec naive_pop x =
@@ -211,6 +314,11 @@ module Native = struct
211314
check_index "set" v i;
212315
unsafe_set v i b
213316

317+
let iteri f v =
318+
let n = length v in
319+
let rec loop i = if i < n then (f i (unsafe_get v i); loop (i+1)) in
320+
loop 0
321+
214322
let swap v i =
215323
check_index "swap" v i;
216324
v lxor (1 lsl i)
@@ -224,34 +332,34 @@ module Native = struct
224332
let nlz v = compute_nlz max_length v
225333
let pop = pop
226334

227-
let empty _n =
228-
0
229-
let full _n =
230-
-1
231335
let singleton len i =
232336
if i < 0 || i >= len then invalid_arg "singleton";
233337
1 lsl i
234338
let is_empty v =
235339
v == 0
236340

341+
let rec elements v =
342+
if v == 0 then [] else let i = v land (-v) in tib i :: elements (v - i)
343+
237344
include SetOps(struct
238345
type t_ = t type t = t_
346+
let make = make
239347
let length = length
240348
let is_empty = is_empty
241349
let pop = pop
242350
let ntz = ntz
243351
let nlz = nlz
244352
let get = get
353+
let unsafe_get = unsafe_get
245354
let set = set
355+
let unsafe_set = unsafe_set
246356
let bw_or = bw_or
247357
let bw_and = bw_and
248358
let bw_xor = bw_xor
249359
let bw_not = bw_not
360+
let elements = elements
250361
end)
251362

252-
let choose = min_elt
253-
let choose_opt = min_elt_opt
254-
255363
let find_first p v =
256364
let rec loop v =
257365
if v = 0 then raise Not_found;
@@ -274,14 +382,17 @@ module Native = struct
274382
let find_last_opt p v =
275383
try Some (find_last p v) with Not_found -> None
276384

277-
let rec elements v =
278-
if v == 0 then [] else let i = v land (-v) in tib i :: elements (v - i)
279-
280-
let rec iter f v =
281-
if v != 0 then let i = v land (-v) in f (tib i); iter f (v - i)
385+
let rec iteri_true f v =
386+
if v != 0 then let i = v land (-v) in f (tib i); iteri_true f (v - i)
387+
let rec iteri_true_ofs f ofs v =
388+
if v != 0 then
389+
let i = v land (-v) in f (ofs + tib i); iteri_true_ofs f ofs (v - i)
282390

283-
let rec fold f v acc =
284-
if v == 0 then acc else let i = v land (-v) in fold f (v - i) (f (tib i) acc)
391+
let rec foldi_true f v acc =
392+
if v == 0 then acc else let i = v land (-v) in foldi_true f (v - i) (f (tib i) acc)
393+
let rec foldi_true_ofs f ofs v acc =
394+
if v == 0 then acc else
395+
let i = v land (-v) in foldi_true_ofs f ofs (v - i) (f (ofs + tib i) acc)
285396

286397
let rec for_all p v =
287398
v == 0 || let i = v land (-v) in p (tib i) && for_all p (v - i)
@@ -319,20 +430,6 @@ module Native = struct
319430
let bi = 1 lsl i in
320431
v land (bi - 1), v land bi != 0, v land (-1 lsl (i+1))
321432

322-
let print_set fmt v =
323-
let rec pr = function
324-
| [] -> ()
325-
| x :: l ->
326-
Format.fprintf fmt "%d" x; if l <> [] then Format.fprintf fmt ",@,";
327-
pr l
328-
in
329-
Format.fprintf fmt "{";
330-
pr (elements v);
331-
Format.fprintf fmt "}"
332-
333-
let map f v =
334-
fold (fun x v -> add (f x) v) v 0(*(empty (length v))*)
335-
336433
let of_list =
337434
List.fold_left (fun s x -> add x s) 0(*(empty (List.length l))*)
338435

@@ -381,6 +478,10 @@ module Large : S = struct
381478
| Leaf of int
382479
| Node of { info: int; high: t; low: t }
383480

481+
let compare: t -> t -> int = Stdlib.compare
482+
let equal: t -> t -> bool = (=)
483+
let hash: t -> int = Hashtbl.hash
484+
384485
let bits x = x land 0xFFFF_FFFF
385486
let ilen x = (x lsr 32) land 0x3F
386487
let ipop x = (x lsr 38) land 0x3F
@@ -528,54 +629,68 @@ module Large : S = struct
528629
let nlzh = nlz high in
529630
if nlzh < length high then nlzh else nlzh + nlz low
530631

632+
(* FIXME: improve *)
633+
let iteri f v =
634+
let n = length v in
635+
let rec loop i = if i < n then (f i (unsafe_get v i); loop (i+1)) in
636+
loop 0
637+
638+
let elements v =
639+
let rec elements acc ofs = function
640+
| Leaf x ->
641+
let rec loop acc x =
642+
if x == 0 then acc else
643+
let i = x land (-x) in loop (ofs + tib i :: acc) (x - i) in
644+
loop acc (bits x)
645+
| Node {high;low;_} ->
646+
let ll = length low in
647+
elements (elements acc ofs low) (ll + ofs) high
648+
in
649+
elements [] 0 v
650+
531651
include SetOps(struct
532652
type t_ = t type t = t_
653+
let make = make
533654
let length = length
534655
let is_empty = is_empty
535656
let pop = pop
536657
let ntz = ntz
537658
let nlz = nlz
538659
let get = get
660+
let unsafe_get = unsafe_get
539661
let set = set
662+
let unsafe_set = unsafe_set
540663
let bw_or = bw_or
541664
let bw_and = bw_and
542665
let bw_xor = bw_xor
543666
let bw_not = bw_not
667+
let elements = elements
544668
end)
545669

546-
let empty: size -> t = fun _ -> assert false (*TODO*)
547-
let full: size -> t = fun _ -> assert false (*TODO*)
548-
let mem: elt -> t -> bool = fun _ -> assert false (*TODO*)
549-
let singleton size i = set (make size false) i true
550-
let iter: (elt -> unit) -> t -> unit = fun _ -> assert false (*TODO*)
551-
let map: (elt -> elt) -> t -> t = fun _ -> assert false (*TODO*)
552-
let fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a = fun _ -> assert false (*TODO*)
553-
let for_all: (elt -> bool) -> t -> bool = fun _ -> assert false (*TODO*)
554-
let exists: (elt -> bool) -> t -> bool = fun _ -> assert false (*TODO*)
555-
let filter: (elt -> bool) -> t -> t = fun _ -> assert false (*TODO*)
556-
let filter_map: (elt -> elt option) -> t -> t = fun _ -> assert false (*TODO*)
557-
let partition: (elt -> bool) -> t -> t * t = fun _ -> assert false (*TODO*)
558-
let elements: t -> elt list = fun _ -> assert false (*TODO*)
559-
let choose: t -> elt = fun _ -> assert false (*TODO*)
560-
let choose_opt: t -> elt option = fun _ -> assert false (*TODO*)
561-
let split: elt -> t -> t * bool * t = fun _ -> assert false (*TODO*)
562-
let find: elt -> t -> elt = fun _ -> assert false (*TODO*)
563-
let find_opt: elt -> t -> elt option = fun _ -> assert false (*TODO*)
564-
let find_first: (elt -> bool) -> t -> elt = fun _ -> assert false (*TODO*)
565-
let find_first_opt: (elt -> bool) -> t -> elt option = fun _ -> assert false (*TODO*)
566-
let find_last: (elt -> bool) -> t -> elt = fun _ -> assert false (*TODO*)
567-
let find_last_opt: (elt -> bool) -> t -> elt option = fun _ -> assert false (*TODO*)
568-
let of_list: elt list -> t = fun _ -> assert false (*TODO*)
569-
let to_seq_from : elt -> t -> elt Seq.t = fun _ -> assert false (*TODO*)
570-
let to_seq : t -> elt Seq.t = fun _ -> assert false (*TODO*)
571-
let to_rev_seq : t -> elt Seq.t = fun _ -> assert false (*TODO*)
572-
let add_seq : elt Seq.t -> t -> t = fun _ -> assert false (*TODO*)
573-
let of_seq : elt Seq.t -> t = fun _ -> assert false (*TODO*)
574-
let print_set: Format.formatter -> t -> unit = fun _ -> assert false (*TODO*)
670+
let singleton size i =
671+
set (make size false) i true
575672

576-
let compare: t -> t -> int = Stdlib.compare
577-
let equal: t -> t -> bool = (=)
578-
let hash: t -> int = Hashtbl.hash
673+
let iteri_true f v =
674+
let rec iter ofs = function
675+
| Leaf x ->
676+
Native.iteri_true_ofs f ofs (bits x)
677+
| Node {high;low;info} ->
678+
let ll = length low in
679+
if nntz info < ll then iter ofs low;
680+
if not (is_empty high) then iter (ofs+ll) high
681+
in
682+
iter 0 v
683+
684+
let foldi_true f v acc =
685+
let rec fold ofs acc = function
686+
| Leaf x ->
687+
Native.foldi_true_ofs f ofs (bits x) acc
688+
| Node {high;low;info} ->
689+
let ll = length low in
690+
let acc = if nntz info < ll then fold ofs acc low else acc in
691+
if not (is_empty high) then fold (ofs+ll) acc high else acc
692+
in
693+
fold 0 acc v
579694

580695
end
581696

0 commit comments

Comments
 (0)