├── .gitignore ├── .ocamlinit ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── dune-project ├── psq.opam ├── src ├── dune ├── psq.ml └── psq.mli └── test ├── bench.ml ├── dune ├── search.ml └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | 3 | tmp 4 | *~ 5 | \.\#* 6 | \#*# 7 | 8 | gmon.out 9 | perf.data* 10 | rondom 11 | *.json 12 | -------------------------------------------------------------------------------- /.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 27 | -------------------------------------------------------------------------------- /.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 16 | -------------------------------------------------------------------------------- /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. 26 | -------------------------------------------------------------------------------- /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. 14 | -------------------------------------------------------------------------------- /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/ 24 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.7) 2 | (name psq) 3 | (version %%VERSION_NUM%%) 4 | -------------------------------------------------------------------------------- /psq.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "David Kaloper Meršinjak " 3 | authors: ["David Kaloper Meršinjak "] 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 | """ 25 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name psq) 3 | (synopsis "Functional Priority Search Queues") 4 | (libraries seq) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /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 401 | -------------------------------------------------------------------------------- /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 224 | -------------------------------------------------------------------------------- /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 | ] 87 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (modules test) 4 | (libraries psq alcotest qcheck-core qcheck-alcotest)) 5 | 6 | (executable 7 | (name bench) 8 | (modules bench) 9 | (libraries psq unmark unmark.cli)) 10 | 11 | (executable 12 | (name search) 13 | (modules search) 14 | (libraries psq fmt)) 15 | -------------------------------------------------------------------------------- /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 56 | -------------------------------------------------------------------------------- /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 | ] 202 | --------------------------------------------------------------------------------