My working unpac space for OCaml projects in development
Merge opam/patches/psq
+1123
+11
vendor/opam/psq/.gitignore
+11
vendor/opam/psq/.gitignore
+26
vendor/opam/psq/.ocamlinit
+26
vendor/opam/psq/.ocamlinit
···
1
+
#require "fmt"
2
+
(* #directory "_build/src" *)
3
+
(* #load "psq.cma" *)
4
+
5
+
let shuff arr =
6
+
let n = Array.length arr in
7
+
for i = 0 to n - 2 do
8
+
let j = Random.int (n - i) + i in
9
+
let t = arr.(i) in
10
+
arr.(i) <- arr.(j);
11
+
arr.(j) <- t
12
+
done
13
+
14
+
let permutation n =
15
+
let arr = Array.init n (fun x -> x) in
16
+
shuff arr;
17
+
Array.to_list arr
18
+
19
+
let rec (--) a b = if a > b then [] else a :: succ a -- b
20
+
21
+
module I = struct type t = int let compare = compare end
22
+
module Q = Psq.Make (I) (I)
23
+
24
+
let pp_q = Q.pp_dump Fmt.int Fmt.int
25
+
;;
26
+
#install_printer pp_q
+15
vendor/opam/psq/.travis.yml
+15
vendor/opam/psq/.travis.yml
···
1
+
language: c
2
+
install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
3
+
script: bash -ex .travis-opam.sh
4
+
sudo: required
5
+
env:
6
+
global:
7
+
- PACKAGE="psq"
8
+
matrix:
9
+
- OCAML_VERSION=4.03
10
+
- OCAML_VERSION=4.04
11
+
- OCAML_VERSION=4.05
12
+
- OCAML_VERSION=4.06
13
+
- OCAML_VERSION=4.07
14
+
notifications:
15
+
email: false
+25
vendor/opam/psq/CHANGES.md
+25
vendor/opam/psq/CHANGES.md
···
1
+
## v0.2.1 2022-10-25
2
+
3
+
- added `push` to bump priorities
4
+
- added `split_at`
5
+
- changed `++`, `of_list` to select the lowest, not the last/rightmost priority
6
+
7
+
## v0.2.0 2019-04-09
8
+
9
+
Semantics cleanup.
10
+
11
+
- flipped args to `adjust` **breaking**
12
+
- `of_list` now always chooses the rightmost binding
13
+
- `update`, `(++)`, `add_seq`, `to_priority_list`
14
+
- somewhat faster
15
+
16
+
## v0.1.1 2019-04-06
17
+
18
+
- `Seq.t` conversions
19
+
- property tests
20
+
- fixed key ordering of interval queries
21
+
- key order tie-breaks `min`
22
+
23
+
## v0.1.0 2016-11-20
24
+
25
+
First release.
+13
vendor/opam/psq/LICENSE.md
+13
vendor/opam/psq/LICENSE.md
···
1
+
Copyright (c) 2016 David Kaloper Meršinjak
2
+
3
+
Permission to use, copy, modify, and/or distribute this software for any
4
+
purpose with or without fee is hereby granted, provided that the above
5
+
copyright notice and this permission notice appear in all copies.
6
+
7
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+23
vendor/opam/psq/README.md
+23
vendor/opam/psq/README.md
···
1
+
## psq — Functional Priority Search Queues
2
+
3
+
%%VERSION%%
4
+
5
+
psq provides a functional priority search queue for OCaml. This structure
6
+
behaves both as a finite map, containing bindings `k -> p`, and a priority queue
7
+
over `p`. It provides efficient access along more than one axis: to any binding
8
+
by `k`, and to the binding(s) with the least `p`.
9
+
10
+
Typical applications are searches, schedulers and caches. If you ever scratched
11
+
your head because that A\* didn't look quite right, a PSQ is what you needed.
12
+
13
+
The implementation is backed by [priority search pennants][hinze].
14
+
15
+
psq is distributed under the ISC license.
16
+
17
+
[hinze]: https://www.cs.ox.ac.uk/ralf.hinze/publications/ICFP01.pdf
18
+
19
+
## Documentation
20
+
21
+
Documentation is generated by `odoc`. It can be browsed [online][doc].
22
+
23
+
[doc]: https://pqwy.github.io/psq/doc/psq/
+3
vendor/opam/psq/dune-project
+3
vendor/opam/psq/dune-project
+24
vendor/opam/psq/psq.opam
+24
vendor/opam/psq/psq.opam
···
1
+
opam-version: "2.0"
2
+
maintainer: "David Kaloper Meršinjak <dk505@cam.ac.uk>"
3
+
authors: ["David Kaloper Meršinjak <dk505@cam.ac.uk>"]
4
+
homepage: "https://github.com/pqwy/psq"
5
+
doc: "https://pqwy.github.io/psq/doc"
6
+
license: "ISC"
7
+
dev-repo: "git+https://github.com/pqwy/psq.git"
8
+
bug-reports: "https://github.com/pqwy/psq/issues"
9
+
synopsis: "Functional Priority Search Queues"
10
+
build: [ [ "dune" "subst" ] {pinned}
11
+
[ "dune" "build" "-p" name "-j" jobs ]
12
+
[ "dune" "runtest" "-p" name ] {with-test & ocaml:version >= "4.07.0"} ]
13
+
depends: [
14
+
"ocaml" {>="4.03.0"}
15
+
"dune" {build & >= "1.7"}
16
+
"seq"
17
+
"qcheck-core" {with-test}
18
+
"qcheck-alcotest" {with-test}
19
+
"alcotest" {with-test}
20
+
]
21
+
description: """
22
+
Typical applications are searches, schedulers and caches. If you ever scratched
23
+
your head because that A* didn't look quite right, a PSQ is what you needed.
24
+
"""
+4
vendor/opam/psq/src/dune
+4
vendor/opam/psq/src/dune
+400
vendor/opam/psq/src/psq.ml
+400
vendor/opam/psq/src/psq.ml
···
1
+
(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
2
+
See LICENSE.md *)
3
+
4
+
type 'a fmt = Format.formatter -> 'a -> unit
5
+
6
+
let pf = Format.fprintf
7
+
8
+
module type Ordered = sig type t val compare : t -> t -> int end
9
+
10
+
module type S = sig
11
+
type t
12
+
type k
13
+
type p
14
+
val empty : t
15
+
val sg : k -> p -> t
16
+
val (++) : t -> t -> t
17
+
val is_empty : t -> bool
18
+
val size : t -> int
19
+
val mem : k -> t -> bool
20
+
val find : k -> t -> p option
21
+
val add : k -> p -> t -> t
22
+
val push : k -> p -> t -> t
23
+
val remove : k -> t -> t
24
+
val adjust : k -> (p -> p) -> t -> t
25
+
val update : k -> (p option -> p option) -> t -> t
26
+
val split_at : k -> t -> t * t
27
+
val min : t -> (k * p) option
28
+
val rest : t -> t option
29
+
val pop : t -> ((k * p) * t) option
30
+
val fold_at_most : p -> (k -> p -> 'a -> 'a) -> 'a -> t -> 'a
31
+
val iter_at_most : p -> (k -> p -> unit) -> t -> unit
32
+
val to_seq_at_most : p -> t -> (k * p) Seq.t
33
+
val of_list : (k * p) list -> t
34
+
val of_sorted_list : (k * p) list -> t
35
+
val of_seq : (k * p) Seq.t -> t
36
+
val add_seq : (k * p) Seq.t -> t -> t
37
+
val to_list : t -> (k * p) list
38
+
val to_seq : t -> (k * p) Seq.t
39
+
val fold : (k -> p -> 'a -> 'a) -> 'a -> t -> 'a
40
+
val iter : (k -> p -> unit) -> t -> unit
41
+
val to_priority_list : t -> (k * p) list
42
+
val to_priority_seq : t -> (k * p) Seq.t
43
+
val filter : (k -> p -> bool) -> t -> t
44
+
val partition : (k -> p -> bool) -> t -> t * t
45
+
val pp : ?sep:(unit fmt) -> (k * p) fmt -> t fmt
46
+
val pp_dump : k fmt -> p fmt -> t fmt
47
+
val depth : t -> int
48
+
end
49
+
50
+
module Make (K: Ordered) (P: Ordered) :
51
+
S with type k = K.t and type p = P.t =
52
+
struct
53
+
54
+
type k = K.t
55
+
type p = P.t
56
+
57
+
type t = (* SEARCH PENNANTS *)
58
+
N
59
+
| T of (k * p) * k * tree
60
+
61
+
and tree = (* LOSER TREES, OH MY *)
62
+
Lf
63
+
| NdL of (k * p) * tree * k * tree * int
64
+
| NdR of (k * p) * tree * k * tree * int
65
+
66
+
let empty = N
67
+
let sg (k, _ as kp) = T (kp, k, Lf)
68
+
69
+
let is_empty = function N -> true | _ -> false
70
+
71
+
let size_t = function
72
+
Lf -> 0
73
+
| NdL (_, _, _, _, w)
74
+
| NdR (_, _, _, _, w) -> w
75
+
76
+
let size = function N -> 0 | T (_, _, t) -> size_t t + 1
77
+
78
+
let nd_l kp t1 sk t2 = NdL (kp, t1, sk, t2, size_t t1 + size_t t2 + 1)
79
+
let nd_r kp t1 sk t2 = NdR (kp, t1, sk, t2, size_t t1 + size_t t2 + 1)
80
+
81
+
let nd (k, _ as kp) t1 sk t2 =
82
+
if K.compare k sk <= 0 then nd_l kp t1 sk t2 else nd_r kp t1 sk t2
83
+
84
+
85
+
let outweighs s1 s2 = s1 * 100 > s2 * 375
86
+
87
+
let (@<=@) (k1, p1) (k2, p2) =
88
+
match P.compare p1 p2 with 0 -> K.compare k1 k2 <= 0 | c -> c < 0
89
+
[@@inline]
90
+
91
+
let rot_l kp1 t1 sk1 = function
92
+
NdL (kp2, t2, sk2, t3, _) when kp1 @<=@ kp2 ->
93
+
nd kp1 (nd kp2 t1 sk1 t2) sk2 t3
94
+
| NdL (kp2, t2, sk2, t3, _) | NdR (kp2, t2, sk2, t3, _) ->
95
+
nd kp2 (nd kp1 t1 sk1 t2) sk2 t3
96
+
| Lf -> assert false
97
+
98
+
let rot_r kp1 tt sk2 t3 = match tt with
99
+
NdR (kp2, t1, sk1, t2, _) when kp1 @<=@ kp2 ->
100
+
nd kp1 t1 sk1 (nd kp2 t2 sk2 t3)
101
+
| NdL (kp2, t1, sk1, t2, _) | NdR (kp2, t1, sk1, t2, _) ->
102
+
nd kp2 t1 sk1 (nd kp1 t2 sk2 t3)
103
+
| Lf -> assert false
104
+
105
+
let rot_ll kp1 t1 sk1 = function
106
+
NdL (kp2, t2, sk2, t3, _) | NdR (kp2, t2, sk2, t3, _) ->
107
+
rot_l kp1 t1 sk1 (rot_r kp2 t2 sk2 t3)
108
+
| Lf -> assert false
109
+
110
+
let rot_rr kp1 tt sk2 t3 = match tt with
111
+
NdL (kp2, t1, sk1, t2, _) | NdR (kp2, t1, sk1, t2, _) ->
112
+
rot_r kp1 (rot_l kp2 t1 sk1 t2) sk2 t3
113
+
| Lf -> assert false
114
+
115
+
(* Precond: at most one of t1, t2 is at most 1 away from a balanced
116
+
configuration. *)
117
+
let nd_bal kp t1 sk t2 =
118
+
let s1 = size_t t1 and s2 = size_t t2 in
119
+
match (t1, t2) with
120
+
((NdL (_, t11, _, t12, _) | NdR (_, t11, _, t12, _)), _)
121
+
when s1 > 1 && outweighs s1 s2 ->
122
+
if size_t t11 > size_t t12 then
123
+
rot_r kp t1 sk t2
124
+
else rot_rr kp t1 sk t2
125
+
| (_, (NdL (_, t21, _, t22, _) | NdR (_, t21, _, t22, _)))
126
+
when s2 > 1 && outweighs s2 s1 ->
127
+
if size_t t21 < size_t t22 then
128
+
rot_l kp t1 sk t2
129
+
else rot_ll kp t1 sk t2
130
+
| _ -> nd kp t1 sk t2
131
+
132
+
let (><) t1 t2 = match (t1, t2) with
133
+
(N, t) | (t, N) -> t
134
+
| (T (kp1, sk1, t1), T (kp2, sk2, t2)) ->
135
+
if kp1 @<=@ kp2 then
136
+
T (kp1, sk2, nd_bal kp2 t1 sk1 t2)
137
+
else T (kp2, sk2, nd_bal kp1 t1 sk1 t2)
138
+
[@@inline]
139
+
140
+
let (>|<) (k1, _ as kp1) (k2, _ as kp2) =
141
+
if kp1 @<=@ kp2 then
142
+
T (kp1, k2, NdR (kp2, Lf, k1, Lf, 1))
143
+
else T (kp2, k2, NdL (kp1, Lf, k1, Lf, 1))
144
+
[@@inline]
145
+
146
+
let rec promote sk0 = function
147
+
Lf -> N
148
+
| NdL (kp, t1, sk, t2, _) -> T (kp, sk, t1) >< promote sk0 t2
149
+
| NdR (kp, t1, sk, t2, _) -> promote sk t1 >< T (kp, sk0, t2)
150
+
151
+
let min = function N -> None | T (kp, _, _) -> Some kp
152
+
let rest = function N -> None | T (_, sk, t) -> Some (promote sk t)
153
+
let pop = function N -> None | T (kp, sk, t) -> Some (kp, promote sk t)
154
+
155
+
let find k0 t =
156
+
let rec go k0 = function
157
+
Lf -> None
158
+
| NdL ((k, p), t1, sk, t2, _)
159
+
| NdR ((k, p), t1, sk, t2, _) ->
160
+
if K.compare k0 k = 0 then Some p else
161
+
if K.compare k0 sk <= 0 then go k0 t1 else go k0 t2 in
162
+
match t with
163
+
N -> None
164
+
| T ((k, p), _, t) -> if K.compare k0 k = 0 then Some p else go k0 t
165
+
166
+
let mem k0 t =
167
+
let rec go k0 = function
168
+
Lf -> false
169
+
| NdL ((k, _), t1, sk, t2, _)
170
+
| NdR ((k, _), t1, sk, t2, _) ->
171
+
K.compare k0 k = 0 ||
172
+
if K.compare k0 sk <= 0 then go k0 t1 else go k0 t2 in
173
+
match t with N -> false | T ((k, _), _, t) -> K.compare k0 k = 0 || go k0 t
174
+
175
+
let foldr_at_most p0 f t z =
176
+
let rec f1 p0 (_, p as kp) f z t =
177
+
if P.compare p p0 <= 0 then f2 p0 kp f z t else z ()
178
+
and f2 p0 kp0 f z = function
179
+
Lf -> f kp0 z
180
+
| NdL (kp, t1, _, t2, _) -> f1 p0 kp f (fun () -> f2 p0 kp0 f z t2) t1
181
+
| NdR (kp, t1, _, t2, _) -> f2 p0 kp0 f (fun () -> f1 p0 kp f z t2) t1 in
182
+
match t with T (kp0, _, t) -> f1 p0 kp0 f z t | _ -> z ()
183
+
184
+
let fold_at_most p0 f z t =
185
+
foldr_at_most p0 (fun (k, p) a -> f k p (a ())) t (fun () -> z)
186
+
187
+
let iter_at_most p0 f t =
188
+
foldr_at_most p0 (fun (k, p) i -> f k p; i ()) t ignore
189
+
190
+
let to_seq_at_most p0 t () =
191
+
foldr_at_most p0 (fun kp seq -> Seq.Cons (kp, seq)) t Seq.empty
192
+
193
+
(* type view = Nv | Sgv of (k * p) | Binv of t * K.t * t *)
194
+
195
+
(* let view = function *)
196
+
(* N -> Nv *)
197
+
(* | T (kp, _, Lf) -> Sgv kp *)
198
+
(* | T (kp1, sk1, NdL (kp2, t1, sk2, t2, _)) -> *)
199
+
(* Binv (T (kp2, sk2, t1), sk2, T (kp1, sk1, t2)) *)
200
+
(* | T (kp1, sk1, NdR (kp2, t1, sk2, t2, _)) -> *)
201
+
(* Binv (T (kp1, sk2, t1), sk2, T (kp2, sk1, t2)) *)
202
+
203
+
(* let rec add (k0, _ as kp0) t = match view t with *)
204
+
(* | Nv -> sg kp0 *)
205
+
(* | Sgv (k, _) -> *)
206
+
(* let c = K.compare k0 k and t' = sg kp0 in *)
207
+
(* if c < 0 then t' >< t else if c > 0 then t >< t' else t' *)
208
+
(* | Binv (t1, sk, t2) -> *)
209
+
(* if K.compare k0 sk <= 0 then add kp0 t1 >< t2 else t1 >< add kp0 t2 *)
210
+
211
+
(* let remove k0 t = *)
212
+
(* let rec go k0 t = match view t with *)
213
+
(* Binv (t1, sk, t2) -> *)
214
+
(* if K.compare k0 sk <= 0 then go k0 t1 >< t2 else t1 >< go k0 t2 *)
215
+
(* | Sgv (k, _) when K.compare k k0 = 0 -> N *)
216
+
(* | Sgv _ | Nv -> raise_notrace Exit in *)
217
+
(* try go k0 t with Exit -> t *)
218
+
219
+
(* let adjust k0 f t = *)
220
+
(* let rec go f k0 t = match view t with *)
221
+
(* Binv (t1, sk, t2) -> *)
222
+
(* if K.compare k0 sk <= 0 then go f k0 t1 >|< t2 else t1 >|< go f k0 t2 *)
223
+
(* | Sgv (k, p) when K.compare k k0 = 0 -> sg (k, f p) *)
224
+
(* | Sgv _ | Nv -> raise_notrace Exit in *)
225
+
(* try go f k0 t with Exit -> t *)
226
+
227
+
(* let rec filter pf t = match view t with *)
228
+
(* Nv -> N *)
229
+
(* | Sgv (k, p as kp) -> if pf k p then sg kp else N *)
230
+
(* | Binv (t1, _, t2) -> filter pf t1 >< filter pf t2 *)
231
+
232
+
let update =
233
+
let rec go k0 f (k1, p1 as kp1) sk1 = function
234
+
Lf ->
235
+
let c = K.compare k0 k1 in
236
+
if c = 0 then
237
+
match f (Some p1) with
238
+
| Some p when p == p1 -> raise_notrace Exit
239
+
| Some p -> sg (k0, p)
240
+
| None -> N
241
+
else ( match f None with
242
+
| Some p when c < 0 -> (k0, p) >|< kp1
243
+
| Some p -> kp1 >|< (k0, p)
244
+
| None -> raise_notrace Exit )
245
+
| NdL (kp2, t1, sk2, t2, _) ->
246
+
if K.compare k0 sk2 <= 0 then
247
+
go k0 f kp2 sk2 t1 >< T (kp1, sk1, t2)
248
+
else T (kp2, sk2, t1) >< go k0 f kp1 sk1 t2
249
+
| NdR (kp2, t1, sk2, t2, _) ->
250
+
if K.compare k0 sk2 <= 0 then
251
+
go k0 f kp1 sk2 t1 >< T (kp2, sk1, t2)
252
+
else T (kp1, sk2, t1) >< go k0 f kp2 sk1 t2 in
253
+
fun k0 f -> function
254
+
| N -> (match f None with Some p -> sg (k0, p) | _ -> N)
255
+
| T (kp, sk, t1) as t -> try go k0 f kp sk t1 with Exit -> t
256
+
257
+
let add k p t = update k (fun _ -> Some p) t
258
+
let push k p t = update k (function
259
+
| Some p0 -> Some (if P.compare p p0 < 0 then p else p0)
260
+
| None -> Some p) t
261
+
let remove k t = update k (fun _ -> None) t
262
+
let adjust k f t = update k (function Some p -> Some (f p) | _ -> None) t
263
+
264
+
let filter =
265
+
let rec go pf kp1 sk1 = function
266
+
Lf -> if pf (fst kp1) (snd kp1) then sg kp1 else N
267
+
| NdL (kp2, t1, sk2, t2, _) -> go pf kp2 sk2 t1 >< go pf kp1 sk1 t2
268
+
| NdR (kp2, t1, sk2, t2, _) -> go pf kp1 sk2 t1 >< go pf kp2 sk1 t2 in
269
+
fun pf -> function N -> N | T (kp, sk, t) -> go pf kp sk t
270
+
271
+
let partition pf t = filter pf t, filter (fun k p -> not (pf k p)) t
272
+
273
+
let split_at =
274
+
let rec go k0 pk sk = function
275
+
| Lf -> if K.compare (fst pk) k0 <= 0 then sg pk, empty else empty, sg pk
276
+
| NdL (pk1, t1, sk1, t2, _) ->
277
+
if K.compare k0 sk1 <= 0 then
278
+
let t11, t12 = go k0 pk1 sk1 t1 in t11, t12 >< T (pk, sk, t2)
279
+
else let t21, t22 = go k0 pk sk t2 in T (pk1, sk1, t1) >< t21, t22
280
+
| NdR (pk1, t1, sk1, t2, _) ->
281
+
if K.compare k0 sk1 <= 0 then
282
+
let t11, t12 = go k0 pk sk1 t1 in t11, t12 >< T (pk1, sk, t2)
283
+
else let t21, t22 = go k0 pk1 sk t2 in T (pk, sk1, t1) >< t21, t22 in
284
+
fun k0 -> function N -> N, N | T (pk, sk, t) -> go k0 pk sk t
285
+
286
+
let rec (++) =
287
+
let app q1 = function
288
+
| N -> q1
289
+
| T ((k, p), _, Lf) -> push k p q1
290
+
| T ((k1, p1), _,
291
+
(NdL ((k2, p2), Lf, _, Lf, _) |
292
+
NdR ((k2, p2), Lf, _, Lf, _))) -> push k1 p1 (push k2 p2 q1)
293
+
| T (kp, sk, NdL (kp1, t1, sk1, t2, _)) ->
294
+
let q11, q12 = split_at sk1 q1 in
295
+
(q11 ++ T (kp1, sk1, t1)) >< (q12 ++ T (kp, sk, t2))
296
+
| T (kp, sk, NdR (kp1, t1, sk1, t2, _)) ->
297
+
let q11, q12 = split_at sk1 q1 in
298
+
(q11 ++ T (kp, sk1, t1)) >< (q12 ++ T (kp1, sk, t2)) in
299
+
fun q1 q2 -> if size q1 < size q2 then app q2 q1 else app q1 q2
300
+
301
+
let of_sorted_list =
302
+
let rec group1 = function
303
+
| [] -> []
304
+
| [x] -> [sg x]
305
+
| [x;y] -> [x >|< y]
306
+
| [x;y;z] -> [(x >|< y) >< sg z]
307
+
| x::y::z::w::xs -> ((x >|< y) >< (z >|< w)) :: group1 xs
308
+
and group2 = function
309
+
| [] | [_] as r -> r
310
+
| [x;y] -> [x >< y]
311
+
| [x;y;z] -> [(x >< y) >< z]
312
+
| x::y::z::w::xs -> ((x >< y) >< (z >< w)) :: group2 xs
313
+
and go = function [] -> N | [t] -> t | ts -> go (group2 ts) in
314
+
fun xs -> go (group1 xs)
315
+
316
+
let of_list =
317
+
let rec sieve k0 a = function
318
+
| [] -> a
319
+
| (k, _) as kv :: kvs ->
320
+
if K.compare k0 k = 0 then sieve k0 a kvs else sieve k (kv :: a) kvs in
321
+
let cmp_kv (k1, p1) (k2, p2) =
322
+
match K.compare k2 k1 with 0 -> P.compare p1 p2 | r -> r in
323
+
fun xs -> match List.sort cmp_kv xs with
324
+
| [] -> empty
325
+
| (k, _) as kv :: kvs -> sieve k [kv] kvs |> of_sorted_list
326
+
327
+
let of_seq xs = Seq.fold_left (fun xs a -> a::xs) [] xs |> of_list
328
+
329
+
let add_seq xs q = Seq.fold_left (fun q (k, p) -> add k p q) q xs
330
+
331
+
let iter =
332
+
let rec go (p0, k0 as pk0) f = function
333
+
Lf -> f p0 k0
334
+
| NdL (pk, t1, _, t2, _) -> go pk f t1; go pk0 f t2
335
+
| NdR (pk, t1, _, t2, _) -> go pk0 f t1; go pk f t2 in
336
+
fun f -> function N -> () | T (pk, _, t) -> go pk f t
337
+
338
+
let foldr =
339
+
let rec go kp0 f z = function
340
+
Lf -> f kp0 z
341
+
| NdL (kp, t1, _, t2, _) -> go kp f (go kp0 f z t2) t1
342
+
| NdR (kp, t1, _, t2, _) -> go kp0 f (go kp f z t2) t1 in
343
+
fun f z -> function N -> z | T (kp, _, t) -> go kp f z t
344
+
345
+
let lfoldr =
346
+
let rec go kp0 f z = function
347
+
Lf -> f kp0 z
348
+
| NdL (kp, t1, _, t2, _) -> go kp f (fun () -> go kp0 f z t2) t1
349
+
| NdR (kp, t1, _, t2, _) -> go kp0 f (fun () -> go kp f z t2) t1 in
350
+
fun f z -> function T (kp, _, t) -> go kp f z t | N -> z ()
351
+
352
+
let fold f z t = foldr (fun (k, p) z -> f k p z) z t
353
+
let to_list t = foldr (fun kp xs -> kp :: xs) [] t
354
+
let to_seq t () = lfoldr (fun kp xs -> Seq.Cons (kp, xs)) Seq.empty t
355
+
356
+
let to_priority_list =
357
+
let rec (--) xs ys = match xs, ys with
358
+
[], l | l, [] -> l
359
+
| x::xt, y::yt -> if x @<=@ y then x :: (xt -- ys) else y :: (xs -- yt) in
360
+
let rec go = function
361
+
Lf -> []
362
+
| NdL (kp2, t1, _, t2, _) -> (kp2 :: go t1) -- go t2
363
+
| NdR (kp2, t1, _, t2, _) -> go t1 -- (kp2 :: go t2) in
364
+
function N -> [] | T (kp, _, t) -> kp :: go t
365
+
366
+
let to_priority_seq t () =
367
+
let open Seq in
368
+
let rec (--) n1 n2 = match n1, n2 with
369
+
Nil, n | n, Nil -> n
370
+
| Cons (x, xt), Cons (y, yt) ->
371
+
if x @<=@ y then
372
+
Cons (x, fun _ -> xt () -- n2)
373
+
else Cons (y, fun _ -> n1 -- yt ()) in
374
+
let rec go = function
375
+
Lf -> Nil
376
+
| NdL (kp2, t1, _, t2, _) -> Cons (kp2, fun _ -> go t1) -- go t2
377
+
| NdR (kp2, t1, _, t2, _) -> go t1 -- Cons (kp2, fun _ -> go t2) in
378
+
match t with N -> Nil | T (kp, _, t) -> Cons (kp, fun _ -> go t)
379
+
380
+
let sg k p = sg (k, p)
381
+
382
+
let depth t =
383
+
let rec go = function
384
+
Lf -> 0
385
+
| NdL (_, t1, _, t2, _) | NdR (_, t1, _, t2, _) ->
386
+
max (go t1) (go t2) + 1 in
387
+
match t with N -> 0 | T (_, _, t) -> go t + 1
388
+
389
+
let pp ?(sep = Format.pp_print_space) pp ppf t =
390
+
let first = ref true in
391
+
let k ppf = iter @@ fun k p ->
392
+
( match !first with true -> first := false | _ -> sep ppf ());
393
+
pp ppf (k, p) in
394
+
pf ppf "@[%a@]" k t
395
+
396
+
let pp_dump ppk ppp ppf =
397
+
let sep ppf () = pf ppf ";@ "
398
+
and ppkp ppf (k, p) = pf ppf "(@[%a,@ %a@])" ppk k ppp p in
399
+
pf ppf "of_sorted_list [%a]" (pp ~sep ppkp)
400
+
end
+223
vendor/opam/psq/src/psq.mli
+223
vendor/opam/psq/src/psq.mli
···
1
+
(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
2
+
See LICENSE.md *)
3
+
4
+
(** Functional Priority Search Queues
5
+
6
+
[Psq] provides a functional structure that behaves as both a finite map and
7
+
a priority queue.
8
+
9
+
{ul
10
+
{- The structure contains a collection of bindings [k -> p], and allows
11
+
efficient {{!S.add}addition}, {{!S.find}lookup} and {{!S.remove}removal}
12
+
of bindings by key.}
13
+
{- It additionally supports {{!S.min}access} to, and {{!S.rest}removal} of
14
+
the binding [k -> p] with the least [p].}}
15
+
16
+
The implementation is backed by a weight-balanced semi-heap. Access by key
17
+
is [O(log n)]. Access to the minimal [p] is [O(1)], and its removal is
18
+
[O(log n)].
19
+
20
+
{b References}
21
+
{ul
22
+
{- Ralf Hinze.
23
+
{{:https://www.cs.ox.ac.uk/ralf.hinze/publications/ICFP01.pdf} A Simple
24
+
Implementation Technique for Priority Search Queues}. 2001.}}
25
+
26
+
{e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *)
27
+
28
+
(** {1 Psq} *)
29
+
30
+
(** Signature of priority search queues. *)
31
+
module type S = sig
32
+
33
+
(** {1 Priority Search Queue} *)
34
+
35
+
type t
36
+
(** A search queue. *)
37
+
38
+
type k
39
+
(** Keys in {{!t}[t]}. *)
40
+
41
+
type p
42
+
(** Priorities in {{!t}[t]}. *)
43
+
44
+
val empty : t
45
+
(** [empty] is the search queue that contains no bindings. *)
46
+
47
+
val sg : k -> p -> t
48
+
(** [sg k p] is the singleton search queue, containing only the
49
+
binding [k -> p]. *)
50
+
51
+
val (++) : t -> t -> t
52
+
(** [t1 ++ t2] contains bindings from [t1] and [t2]. If a key [k] is bound in
53
+
both, the result has the binding with lower priority.
54
+
55
+
Hence,
56
+
{ul
57
+
{- [t1 ++ t2 = t2 ++ t1]}
58
+
{- [(t1 ++ t2) ++ t3 = t1 ++ (t2 ++ t3)]}} *)
59
+
60
+
val is_empty : t -> bool
61
+
(** [is_empty t] is [true] iff [t] is {{!empty}[empty]}. *)
62
+
63
+
val size : t -> int
64
+
(** [size t] is the number of distinct bindings in [t]. *)
65
+
66
+
(** {1 Access by [k]} *)
67
+
68
+
val mem : k -> t -> bool
69
+
(** [find k t] is [true] iff [k] is bound in [t]. *)
70
+
71
+
val find : k -> t -> p option
72
+
(** [find k t] is [Some p] if [t] contains the binding [k -> p], or [None]
73
+
otherwise. *)
74
+
75
+
val add : k -> p -> t -> t
76
+
(** [add k p t] is [t] with the binding [k -> p].
77
+
78
+
Note that [add] does {e not} commute:
79
+
[add k p2 (add k p1 q) <> add k p1 (add k p2 q)] when [p1 <> p2].
80
+
Compare {!push}. *)
81
+
82
+
val push : k -> p -> t -> t
83
+
(** [push k p t] is [t] with [k] bound to the lower of [p] and its previous
84
+
priority in [t], if it exists — when [t] contains [k -> p0], the result
85
+
contains [k -> min p0 p], otherwise it contains [k -> p].
86
+
87
+
Note that [push] commutes:
88
+
[push k p1 (push k p2 q) = push k p2 (push k p1 q)]. Compare {!add}. *)
89
+
90
+
val remove : k -> t -> t
91
+
(** [remove k t] is [t] without any bindings for [k]. *)
92
+
93
+
val adjust : k -> (p -> p) -> t -> t
94
+
(** [adjust k f t] is [t] with the binding [k -> p] replaced by [k -> f p].
95
+
When [k] is not bound in [t], the result is [t]. *)
96
+
97
+
val update : k -> (p option -> p option) -> t -> t
98
+
(** [update k f t] is [t] with the binding for [k] given by [f].
99
+
100
+
When [t] contains a binding [k -> p], the new binding is given by
101
+
[f (Some p)]; otherwise, by [f None].
102
+
103
+
When the result of applying [f] is [Some p'], the binding [k -> p'] is
104
+
added to [t]; otherwise, the binding for [k] is removed from [t]. *)
105
+
106
+
val split_at : k -> t -> t * t
107
+
(** [split_at k t] splits [t] into [(t0, t1)], such that for all keys [k0] in
108
+
[t0], [k0 <= k], for all keys [k1] in [t1], [k1 > k], and [t = t0 ++ t1]. *)
109
+
110
+
(** {1 Access by min [p]} *)
111
+
112
+
val min : t -> (k * p) option
113
+
(** [min t] is the binding [Some (k, p)] where [p] is minimal in [t], or
114
+
[None] if [t] is {{!empty}[empty]}.
115
+
116
+
When several keys share the minimal priority, [min t] is the binding with
117
+
the smallest key. *)
118
+
119
+
val rest : t -> t option
120
+
(** [rest t] is [t] without the binding [min t], or [None]. *)
121
+
122
+
val pop : t -> ((k * p) * t) option
123
+
(** [pop t] is [(min t, rest t)], or [None]. *)
124
+
125
+
val fold_at_most : p -> (k -> p -> 'a -> 'a) -> 'a -> t -> 'a
126
+
(** [fold_at_most p0 f z q] folds [f] over bindings [k -> p] where [p] is not
127
+
larger than [p0], in key-ascending order. *)
128
+
129
+
val iter_at_most : p -> (k -> p -> unit) -> t -> unit
130
+
(** [iter_at_most p0 f q] applies [f] to the bindings [k -> p] where [p] is
131
+
not larger than [p0], in key-ascending order. *)
132
+
133
+
val to_seq_at_most : p -> t -> (k * p) Seq.t
134
+
(** [iter_at_most p0 f q] is the sequence of bindings [k -> p] where [p] not
135
+
larger than [p0], in key-ascending order. *)
136
+
137
+
(** {1 Aggregate construction} *)
138
+
139
+
val of_list : (k * p) list -> t
140
+
(** [of_list kps] is [t] with bindings [kps].
141
+
142
+
When [pks] contains multiple priorities for a given [k], the lowest one
143
+
wins. *)
144
+
145
+
val of_sorted_list : (k * p) list -> t
146
+
(** [of_sorted_list kps] is [t] with bindings [kps].
147
+
[kps] must contain the bindings in key-ascending order without
148
+
repetitions. When this is not the case, the result is undefined.
149
+
150
+
{b Note} When applicable, this operation is faster than
151
+
{{!of_list}[of_list]}. *)
152
+
153
+
val of_seq : (k * p) Seq.t -> t
154
+
(** [of_seq kps] is [of_list (List.of_seq kps)]. *)
155
+
156
+
val add_seq : (k * p) Seq.t -> t -> t
157
+
(** [of_seq kps t] is [t ++ of_seq kps]. *)
158
+
159
+
(** {1 Whole-structure access} *)
160
+
161
+
val to_list : t -> (k * p) list
162
+
(** [to_list t] are all the bindings in [t] in key-ascending order. *)
163
+
164
+
val to_seq : t -> (k * p) Seq.t
165
+
(** [to_seq t] iterates over bindings in [t] in key-ascending order. *)
166
+
167
+
val fold : (k -> p -> 'a -> 'a) -> 'a -> t -> 'a
168
+
(** [fold f z t] is [f k0 p0 (f k1 p1 ... (f kn pn z))], where
169
+
[k0, k1, ..., kn] are in ascending order. *)
170
+
171
+
val iter : (k -> p -> unit) -> t -> unit
172
+
(** [iter f t] applies [f] to all bindings in [t] in key-ascending order. *)
173
+
174
+
val to_priority_list : t -> (k * p) list
175
+
(** [to_priority_list t] are the bindings in [t] in priority-ascending order.
176
+
177
+
{b Note} Priority-ordered traversal is slower than key-ordered traversal. *)
178
+
179
+
val to_priority_seq : t -> (k * p) Seq.t
180
+
(** [to_priority_seq t] is the sequence version of [to_priority_list].
181
+
182
+
{b Note} For traversing the whole [t], [to_priority_list] is more
183
+
efficient. *)
184
+
185
+
val filter : (k -> p -> bool) -> t -> t
186
+
(** [filter p t] is the search queue with exactly the bindings in [t] which
187
+
satisfy the predicate [p]. *)
188
+
189
+
val partition : (k -> p -> bool) -> t -> t * t
190
+
(** [partition p t] is [(filter p t, filter np t)] where [np] is the negation
191
+
of [p]. *)
192
+
193
+
(** {1 Pretty-printing} *)
194
+
195
+
open Format
196
+
197
+
val pp : ?sep:(formatter -> unit -> unit) -> (formatter -> k * p -> unit) ->
198
+
formatter -> t -> unit
199
+
(** [pp ?sep pp_kp ppf t] pretty-prints [t] to [ppf], using [pp_kp] to print
200
+
the bindings and [~sep] to separate them.
201
+
202
+
[~sep] defaults to {!Format.print_space}. *)
203
+
204
+
val pp_dump : (formatter -> k -> unit) -> (formatter -> p -> unit) ->
205
+
formatter -> t -> unit
206
+
(** [pp_dump pp_k pp_f ppf t] is a handier pretty-printer for development. *)
207
+
208
+
(**/**)
209
+
(* Debug. *)
210
+
val depth : t -> int
211
+
(**/**)
212
+
end
213
+
214
+
(** Signature of ordered types. *)
215
+
module type Ordered = sig
216
+
type t
217
+
val compare : t -> t -> int
218
+
(** [compare] is a total order on {{!t}[t]}. *)
219
+
end
220
+
221
+
(** [Make(K)(P)] is the {{!S}priority search queue} with bindings [K.t -> P.t]. *)
222
+
module Make (K: Ordered) (P: Ordered):
223
+
S with type k = K.t and type p = P.t
+86
vendor/opam/psq/test/bench.ml
+86
vendor/opam/psq/test/bench.ml
···
1
+
(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
2
+
See LICENSE.md *)
3
+
4
+
let shuffle arr =
5
+
let n = Array.length arr in
6
+
for i = 0 to n - 2 do
7
+
let j = Random.int (n - i) + i in
8
+
let t = arr.(i) in
9
+
arr.(i) <- arr.(j); arr.(j) <- t
10
+
done
11
+
12
+
let permutation n =
13
+
let arr = Array.init n (fun x -> x) in
14
+
shuffle arr;
15
+
Array.to_list arr
16
+
17
+
let r_bindings n = permutation n |> List.rev_map (fun x -> x, x)
18
+
19
+
module type S = sig
20
+
type t
21
+
val add : int -> int -> t -> t
22
+
val find : int -> t -> int option
23
+
val remove : int -> t -> t
24
+
val of_list : (int * int) list -> t
25
+
end
26
+
module I = struct type t = int let compare (a: int) b = compare a b end
27
+
module Q = Psq.Make (I)(I)
28
+
let q = (module Q: S)
29
+
let m = (module struct
30
+
module M = Map.Make (I)
31
+
type t = int M.t
32
+
let find, add, remove = M.(find_opt, add, remove)
33
+
let of_list xs = List.fold_left (fun m (k, v) -> M.add k v m) M.empty xs
34
+
end: S)
35
+
36
+
open Unmark
37
+
38
+
let runs ((module M: S)) size =
39
+
let xs = r_bindings size in
40
+
let q = M.of_list xs
41
+
and q' = List.rev_map (fun (k, p) -> (k * 2, p * 2)) xs |> M.of_list in
42
+
group (Fmt.strf "x%d" size) [
43
+
bench "find" (fun () -> M.find (Random.int size) q)
44
+
; bench "add" (fun () -> let k = Random.int size + 1 in M.add k k q')
45
+
; bench "remove" (fun () -> M.remove (Random.int size) q)
46
+
]
47
+
48
+
let runs1 size =
49
+
let xs = r_bindings size in
50
+
let q = Q.of_list xs in
51
+
group (Fmt.strf "x%d" size) [
52
+
group "of_" [
53
+
bench "of_sorted_list" (fun () -> Q.of_sorted_list xs)
54
+
; bench "of_list" (fun () -> Q.of_list xs)
55
+
; bench "of_seq" (fun () -> Q.of_seq (List.to_seq xs))
56
+
; bench "add_seq" (fun () -> Q.(add_seq (List.to_seq xs) empty))
57
+
];
58
+
group "to_" [
59
+
bench "to_p_list" (fun () -> Q.to_priority_list q)
60
+
; bench "to_seq" (fun () -> Q.to_seq q |> Seq.iter ignore)
61
+
; bench "to_list" (fun () -> Q.to_list q)
62
+
]
63
+
]
64
+
65
+
let runs2 size =
66
+
let r_key () = Random.int (size * 5) in
67
+
let gen n = List.init n Random.(fun _ -> r_key (), int n) |> Q.of_list in
68
+
let xs, ys, zs = gen size, gen size, gen 10 in
69
+
group (Fmt.strf "x%d" size) [
70
+
bench "split" (fun () -> Q.split_at (r_key ()) xs);
71
+
bench "filter" (fun () ->
72
+
let x = r_key () in Q.filter (fun k _ -> k <= x) xs);
73
+
bench "++" (fun () -> Q.(xs ++ ys));
74
+
bench "++ k" (fun () -> Q.(xs ++ zs));
75
+
]
76
+
77
+
78
+
let arg = Cmdliner.Arg.(
79
+
value @@ opt (list int) [10; 100; 1000] @@ info ["sizes"])
80
+
let _ = Unmark_cli.main_ext "psq" ~arg @@ fun ns -> [
81
+
bench "Random.int" (fun () -> Random.int 1000)
82
+
; group "map" (List.map (runs m) ns)
83
+
; group "psq" (List.map (runs q) ns)
84
+
; group "psq1" (List.map runs1 ns)
85
+
; group "psq2" (List.map runs2 ns)
86
+
]
+14
vendor/opam/psq/test/dune
+14
vendor/opam/psq/test/dune
+55
vendor/opam/psq/test/search.ml
+55
vendor/opam/psq/test/search.ml
···
1
+
(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
2
+
See LICENSE.md *)
3
+
4
+
let rec mem ?(cmp=compare) a = function
5
+
| [] -> false | x::xs -> cmp a x = 0 || mem ~cmp a xs
6
+
7
+
let rec add ?(cmp=compare) a = function
8
+
| [] -> [a]
9
+
| x::xs ->
10
+
match cmp a x with -1 -> a::x::xs | 1 -> x::add ~cmp a xs | _ -> x::xs
11
+
12
+
let astar (type a) ?(cmp=compare) start graph h sat =
13
+
let module K = struct type t = a let compare = cmp end in
14
+
let module P = struct
15
+
type t = int * a list
16
+
let compare (a: t) b = compare (fst a) (fst b)
17
+
end in
18
+
let module Q = Psq.Make(K)(P) in
19
+
let rec go q = match Q.pop q with
20
+
| Some ((a, (dist, path)), q) ->
21
+
if sat a then Some (dist, a, List.rev path) else
22
+
let f q (w, b) =
23
+
let d' = w + h b in
24
+
if mem ~cmp b path then q else
25
+
match Q.find b q with
26
+
| Some (d, _) when d <= d' -> q
27
+
| _ -> Q.add b (d', a::path) q in
28
+
go @@ List.fold_left f q @@ graph a
29
+
| None -> None in
30
+
go Q.(sg start (0, []))
31
+
32
+
let labyrinth p0 (pn_m, pn_n as pn) grid =
33
+
let (m0, n0) = Array.(length grid, length grid.(0)) in
34
+
let h (m, n) = abs (pn_m - m) + abs (pn_n - n)
35
+
and sat mn = mn = pn
36
+
and graph (m, n) =
37
+
(if m > 0 && grid.(m-1).(n) = `o then [1, (m-1, n)] else []) @
38
+
(if m < m0-1 && grid.(m+1).(n) = `o then [1, (m+1, n)] else []) @
39
+
(if n > 0 && grid.(m).(n-1) = `o then [1, (m, n-1)] else []) @
40
+
(if n < n0-1 && grid.(m).(n+1) = `o then [1, (m, n+1)] else []) in
41
+
match astar ~cmp:compare p0 graph h sat with
42
+
| None -> Fmt.pr "not found\n%!"
43
+
| Some (dist, (m, n), path) ->
44
+
Fmt.(pr "@[(%d, %d), dist: %d@;steps: %a@]\n%!"
45
+
m n dist (Dump.(list (pair int int))) path)
46
+
47
+
let l : [`X|`o] array array =
48
+
[|[| `o; `X; `o; `o; `o; `o; |];
49
+
[| `o; `X; `X; `X; `o; `o; |];
50
+
[| `o; `o; `o; `o; `X; `o; |];
51
+
[| `o; `X; `X; `X; `o; `o; |];
52
+
[| `o; `X; `o; `o; `o; `o; |];
53
+
[| `o; `o; `o; `X; `X; `o; |]|]
54
+
55
+
let () = labyrinth (0, 0) (5, 5) l
+201
vendor/opam/psq/test/test.ml
+201
vendor/opam/psq/test/test.ml
···
1
+
(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
2
+
See LICENSE.md *)
3
+
4
+
let id x = x
5
+
let (%) f g x = f (g x)
6
+
7
+
module I = struct type t = int let compare (a: int) b = compare a b end
8
+
module Q = Psq.Make (I) (I)
9
+
10
+
let list_of_iter_2 i =
11
+
let xs = ref [] in i (fun a b -> xs := (a, b) :: !xs); List.rev !xs
12
+
let rec unfold f s = match f s with Some (x, s) -> x :: unfold f s | _ -> []
13
+
14
+
let cmpi (a: int) b = compare a b
15
+
let (%%) f g a b = f (g a) (g b)
16
+
let (=>) cmp1 cmp2 a b = match cmp1 a b with 0 -> cmp2 a b | r -> r
17
+
let k_order xs = List.sort (cmpi %% fst) xs
18
+
let pk_order xs = List.sort (cmpi %% snd => cmpi %% fst) xs
19
+
let k_order_uniq xs =
20
+
let cmp_kp = cmpi %% fst => cmpi %% snd and cmp_k = cmpi %% fst in
21
+
match List.sort_uniq cmp_kp xs with
22
+
| [] -> []
23
+
| kp0::kps ->
24
+
let f kp xs kp0 = if cmp_k kp kp0 = 0 then xs kp0 else kp :: xs kp in
25
+
kp0 :: List.fold_right f kps (fun _ -> []) kp0
26
+
27
+
let is_balanced q =
28
+
let (n, d) = Q.(size q, depth q) in
29
+
n <= 1 || float d < log (float n) *. log 10. *. 3.75
30
+
31
+
let (!) q = `Sem (Q.to_list q)
32
+
let sem xs = `Sem (k_order_uniq xs)
33
+
34
+
let g_size = QCheck.Gen.(small_nat >|= fun x -> x mod 1_000)
35
+
let bindings = QCheck.(
36
+
make Gen.(list_size g_size (pair small_nat small_nat))
37
+
~print:Fmt.(to_to_string Dump.(pair int int |> list))
38
+
~shrink:Shrink.list)
39
+
let psq = QCheck.(
40
+
map Q.of_list bindings ~rev:Q.to_list |>
41
+
set_print Fmt.(to_to_string (Q.pp_dump int int)))
42
+
let kv = QCheck.small_nat
43
+
let psq_w arb = QCheck.pair psq arb
44
+
let psq_w_any_key = psq_w kv
45
+
46
+
let test name gen p =
47
+
QCheck.Test.make ~count:200 ~name gen p |> QCheck_alcotest.to_alcotest
48
+
49
+
let () = Alcotest.run "psq" [
50
+
51
+
"of_list", [
52
+
test "sem" bindings (fun xs -> !(Q.of_list xs) = sem xs);
53
+
test "of_sorted_list sem" bindings
54
+
(fun xs -> !(Q.of_sorted_list (k_order_uniq xs)) = sem xs);
55
+
test "bal" bindings (fun xs -> is_balanced (Q.of_list xs));
56
+
];
57
+
58
+
"to_list", [
59
+
test "order" psq (fun q -> Q.to_list q = k_order (Q.to_list q));
60
+
];
61
+
62
+
"to_priority_list", [
63
+
test "sem" psq (fun q -> Q.to_priority_list q = pk_order (Q.to_list q))
64
+
];
65
+
66
+
"size", [
67
+
test "sem" psq (fun q -> Q.size q = List.length (Q.to_list q));
68
+
];
69
+
70
+
"sg", [
71
+
test "sem" kv (fun x -> !Q.(sg x x) = sem [x, x]);
72
+
];
73
+
74
+
"(++)", [
75
+
test "sem" QCheck.(pair bindings bindings)
76
+
(fun (xs1, xs2) -> !Q.(of_list xs1 ++ of_list xs2) = sem (xs1 @ xs2));
77
+
test "comm" QCheck.(pair psq psq)
78
+
(fun (q1, q2) -> !Q.(q1 ++ q2) = !Q.(q2 ++ q1));
79
+
test "assoc" QCheck.(pair psq psq |> pair psq)
80
+
(fun (q1, (q2, q3)) -> !Q.((q1 ++ q2) ++ q3) = !Q.(q1 ++ (q2 ++ q3)));
81
+
];
82
+
83
+
"split_at", [
84
+
test "sem" psq_w_any_key (fun (q, k) ->
85
+
let q1, q2 = Q.split_at k q
86
+
and xs1, xs2 = List.partition (fun (k1, _) -> k1 <= k) (Q.to_list q) in
87
+
!q1 = sem xs1 && !q2 = sem xs2);
88
+
test "inv" psq_w_any_key (fun (q, k) ->
89
+
let q1, q2 = Q.split_at k q in !q = !Q.(q1 ++ q2));
90
+
];
91
+
92
+
"membership", [
93
+
test "find sem" psq_w_any_key
94
+
(fun (q, x) -> Q.find x q = List.assoc_opt x (Q.to_list q));
95
+
test "mem ==> find" psq_w_any_key
96
+
(fun (q, k) -> QCheck.assume Q.(mem k q); Q.find k q <> None);
97
+
test "find ==> mem" psq_w_any_key
98
+
(fun (q, k) -> QCheck.assume (Q.find k q <> None); Q.mem k q);
99
+
];
100
+
101
+
"update", [
102
+
test "sem" (psq_w QCheck.(pair kv (option kv)))
103
+
(fun (q, (x, yy)) ->
104
+
let kp = match yy with Some y -> [x, y] | _ -> [] in
105
+
!(Q.update x (fun _ -> yy) q) =
106
+
sem (kp @ List.remove_assoc x (Q.to_list q)));
107
+
test "bal" (psq_w QCheck.(pair kv (option kv)))
108
+
(fun (q, (x, yy)) -> is_balanced (Q.update x (fun _ -> yy) q));
109
+
test "phys" psq_w_any_key (fun (q, x) -> Q.update x id q == q);
110
+
];
111
+
112
+
"add", [
113
+
test "sem" psq_w_any_key
114
+
(fun (q, x) ->
115
+
!(Q.add x x q) = sem ((x, x) :: List.remove_assoc x (Q.to_list q)));
116
+
test "bal" psq_w_any_key (fun (q, k) -> is_balanced (Q.add k k q));
117
+
];
118
+
119
+
"push", [
120
+
test "sem" psq_w_any_key
121
+
(fun (q, x) ->
122
+
let p = match List.assoc_opt x (Q.to_list q) with
123
+
| Some p0 -> min x p0
124
+
| None -> x in
125
+
!(Q.push x x q) = sem ((x, p) :: List.remove_assoc x (Q.to_list q)));
126
+
test "mono" psq_w_any_key
127
+
(fun (q, x) ->
128
+
QCheck.assume (Q.mem x q);
129
+
Q.find x (Q.push x x q) <= Q.find x q);
130
+
test "comm" (psq_w (QCheck.pair kv kv))
131
+
(fun (q, (x, y)) ->
132
+
!Q.(q |> push x x |> push x y) = !Q.(q |> push x y |> push x x));
133
+
test "= of_list" bindings
134
+
(fun xs ->
135
+
!(Q.of_list xs) =
136
+
!(List.fold_left (fun q (k, p) -> Q.push k p q) Q.empty xs));
137
+
];
138
+
139
+
"remove", [
140
+
test "sem" psq_w_any_key
141
+
(fun (q, k) ->
142
+
!(Q.remove k q) = sem (List.remove_assoc k (Q.to_list q)));
143
+
test "phys" psq_w_any_key
144
+
(fun (q, k) -> QCheck.assume (not (Q.mem k q)); Q.remove k q == q);
145
+
test "bal" psq_w_any_key (fun (q, k) -> Q.(remove k q |> is_balanced));
146
+
];
147
+
148
+
"adjust", [
149
+
test "sem" psq_w_any_key
150
+
(fun (q, x) ->
151
+
!(Q.adjust x succ q) =
152
+
sem (Q.to_list q |>
153
+
List.map (fun (k, p) -> (k, if k = x then succ p else p))));
154
+
];
155
+
156
+
"pop", [
157
+
test "sem1" psq (fun q -> unfold Q.pop q = pk_order (Q.to_list q));
158
+
test "sem2" psq (fun q -> unfold Q.pop q = Q.to_priority_list q);
159
+
test "min, rest" psq
160
+
(fun q ->
161
+
QCheck.assume (not (Q.is_empty q));
162
+
match Q.(pop q, min q, rest q) with
163
+
Some (kp1, q1), Some kp2, Some q2 -> kp1 = kp2 && !q1 = !q2
164
+
| _ -> false);
165
+
];
166
+
167
+
"at_most", [
168
+
test "sem" psq_w_any_key
169
+
(fun (q, x) ->
170
+
List.of_seq (Q.to_seq_at_most x q) =
171
+
List.filter (fun kp -> snd kp <= x) (Q.to_list q));
172
+
test "seq = fold" psq_w_any_key
173
+
(fun (q, x) ->
174
+
List.of_seq (Q.to_seq_at_most x q) =
175
+
Q.fold_at_most x (fun k p xs -> (k, p)::xs) [] q);
176
+
test "seq = iter" psq_w_any_key
177
+
(fun (q, x) ->
178
+
List.of_seq (Q.to_seq_at_most x q) =
179
+
list_of_iter_2 (fun f -> Q.iter_at_most x f q));
180
+
];
181
+
182
+
"to_stuff", [
183
+
test "to_list = to_seq" psq
184
+
(fun q -> Q.to_list q = (Q.to_seq q |> List.of_seq));
185
+
test "to_list = fold" psq
186
+
(fun q -> Q.to_list q = Q.fold (fun k p xs -> (k, p) :: xs) [] q);
187
+
test "to_list = iter" psq
188
+
(fun q -> Q.to_list q = list_of_iter_2 (fun f -> Q.iter f q));
189
+
test "to_priority_seq" psq
190
+
(fun q -> Q.to_priority_list q = List.of_seq (Q.to_priority_seq q));
191
+
];
192
+
193
+
"filter", [
194
+
test "sem" psq_w_any_key
195
+
(fun (q, k0) ->
196
+
!(Q.filter (fun k _ -> k <= k0) q) =
197
+
sem (List.filter (fun (k, _) -> k <= k0) (Q.to_list q)));
198
+
test "bal" psq_w_any_key
199
+
(fun (q, k0) -> is_balanced (Q.filter (fun k _ -> k <= k0) q));
200
+
];
201
+
]