A collection of experiments, more or less organized.
Merge Set for Date Ranges
+163
-2
+1
-1
.ocamlformat
+1
-1
.ocamlformat
+1
desert.opam
+1
desert.opam
+2
dune-project
+2
dune-project
+6
-1
lib/desert/dune
+6
-1
lib/desert/dune
+73
lib/desert/range_set.md
+73
lib/desert/range_set.md
···
1
+
Instanciate a Range functor and defining some pretty-printers
2
+
3
+
```ocaml
4
+
let range_to_string r =
5
+
let (a, b) = Lunar.Date.Range.bounds r in
6
+
Lunar.Date.to_string a ^ " .. " ^ Lunar.Date.to_string b
7
+
8
+
module S = Desert.Range_set.Make_over_range
9
+
(Lunar.Date) (Lunar.Date.Range)
10
+
11
+
let dump r = r |> S.to_list |> List.map range_to_string
12
+
```
13
+
14
+
```ocaml
15
+
let today = Lunar.Date.from_string_exn "2026-04-07"
16
+
let start = Lunar.Date.start_of_month today
17
+
let stop = Lunar.Date.end_of_month today
18
+
let stopw = Lunar.Date.end_of_week today
19
+
let startw = Lunar.Date.start_of_week today
20
+
let r = S.empty
21
+
22
+
let range_a = Lunar.Date.Range.make ~first:start ~last:today
23
+
let range_b = Lunar.Date.Range.make ~first:today ~last:stop
24
+
let range_c = Lunar.Date.Range.make ~first:start ~last:stop
25
+
let range_d = Lunar.Date.Range.make ~first:startw ~last:stopw
26
+
let range_e = Lunar.Date.Range.make ~first:startw ~last:today
27
+
let range_f = Lunar.Date.Range.make ~first:today ~last:stopw
28
+
let range_g = Lunar.Date.Range.make ~first:start ~last:startw
29
+
let range_h = Lunar.Date.Range.make ~first:stopw ~last:stop
30
+
```
31
+
32
+
```ocaml
33
+
# dump r ;;
34
+
- : string list = []
35
+
```
36
+
37
+
```ocaml
38
+
# r |> S.add range_a |> dump
39
+
- : string list = ["2026-04-01 .. 2026-04-07"]
40
+
```
41
+
42
+
```ocaml
43
+
# r |> S.add range_a |> S.add range_b |> dump
44
+
- : string list = ["2026-04-01 .. 2026-04-30"]
45
+
```
46
+
47
+
```ocaml
48
+
# r |> S.add range_a |> S.add range_e |> dump
49
+
- : string list = ["2026-04-01 .. 2026-04-07"]
50
+
```
51
+
52
+
```ocaml
53
+
# r |> S.add range_a |> S.add range_f |> dump
54
+
- : string list = ["2026-04-01 .. 2026-04-12"]
55
+
```
56
+
57
+
```ocaml
58
+
# r |> S.add range_g |> S.add range_h |> dump
59
+
- : string list = ["2026-04-01 .. 2026-04-06"; "2026-04-12 .. 2026-04-30"]
60
+
```
61
+
62
+
```ocaml
63
+
# r |> S.add range_g |> S.add range_h |> S.remove range_c |> dump
64
+
- : string list = []
65
+
```
66
+
67
+
68
+
```ocaml
69
+
# r |> S.add range_g |> S.add range_h |> S.remove range_a |> dump
70
+
- : string list = ["2026-04-12 .. 2026-04-30"]
71
+
```
72
+
73
+
+57
lib/desert/range_set.ml
+57
lib/desert/range_set.ml
···
1
+
module Make_over_range
2
+
(C : Lunar.Sigs.COMPARABLE)
3
+
(R : Lunar.Range.S with type elt = C.t) =
4
+
struct
5
+
module S = Set.Make (struct
6
+
type t = R.t
7
+
8
+
let compare a b =
9
+
let c = C.compare (R.min_elt a) (R.min_elt b) in
10
+
if Int.equal 0 c then C.compare (R.max_elt a) (R.max_elt b) else c
11
+
;;
12
+
end)
13
+
14
+
type elt = R.t
15
+
type t = S.t
16
+
17
+
let substract by range =
18
+
match R.intersection by range with
19
+
| None -> [ range ]
20
+
| Some inter ->
21
+
let rmin, rmax = R.bounds range
22
+
and imin, imax = R.bounds inter in
23
+
let acc =
24
+
if C.compare rmin imin = 0
25
+
then []
26
+
else [ R.make ~first:rmin ~last:imin ]
27
+
in
28
+
if C.compare rmax imax = 0
29
+
then acc
30
+
else R.make ~first:imax ~last:rmax :: acc
31
+
;;
32
+
33
+
let empty = S.empty
34
+
let singleton = S.singleton
35
+
36
+
let add elt set =
37
+
let overlapping, disjoint = S.partition (R.overlaps elt) set in
38
+
S.add (elt |> S.fold R.span overlapping) disjoint
39
+
;;
40
+
41
+
let remove elt set =
42
+
S.fold
43
+
(fun range acc ->
44
+
let p = substract elt range in
45
+
List.fold_left (fun acc r -> S.add r acc) acc p)
46
+
set
47
+
S.empty
48
+
;;
49
+
50
+
let of_list = List.fold_left (fun acc x -> add x acc) empty
51
+
let of_seq = Seq.fold_left (fun acc x -> add x acc) empty
52
+
let to_list = S.to_list
53
+
let to_seq = S.to_seq
54
+
end
55
+
56
+
module Make (C : Lunar.Sigs.COMPARABLE) =
57
+
Make_over_range (C) (Lunar.Range.Make (C))
+23
lib/desert/range_set.mli
+23
lib/desert/range_set.mli
···
1
+
(** Describes a normalized set of disjoint intervals (or more simply a
2
+
Merged Interval Set).
3
+
4
+
Unlike a traditional set, this one merges overlapping ranges. *)
5
+
6
+
module Make_over_range
7
+
(C : Lunar.Sigs.COMPARABLE)
8
+
(R : Lunar.Range.S with type elt = C.t) : sig
9
+
type elt = R.t
10
+
type t
11
+
12
+
val empty : t
13
+
val singleton : elt -> t
14
+
val add : elt -> t -> t
15
+
val remove : elt -> t -> t
16
+
val of_list : elt list -> t
17
+
val of_seq : elt Seq.t -> t
18
+
val to_seq : t -> elt Seq.t
19
+
val to_list : t -> elt list
20
+
end
21
+
22
+
module Make (C : Lunar.Sigs.COMPARABLE) :
23
+
module type of Make_over_range (C) (Lunar.Range.Make (C))