unikernel/duniverse/psq/test/bench.ml

@@ -0,0 +1,86 @@
+(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+let shuffle arr =
+  let n = Array.length arr in
+  for i = 0 to n - 2 do
+    let j = Random.int (n - i) + i in
+    let t = arr.(i) in
+    arr.(i) <- arr.(j); arr.(j) <- t
+  done
+
+let permutation n =
+  let arr = Array.init n (fun x -> x) in
+  shuffle arr;
+  Array.to_list arr
+
+let r_bindings n = permutation n |> List.rev_map (fun x -> x, x)
+
+module type S = sig
+  type t
+  val add     : int -> int -> t -> t
+  val find    : int -> t -> int option
+  val remove  : int -> t -> t
+  val of_list : (int * int) list -> t
+end
+module I = struct type t = int let compare (a: int) b = compare a b end
+module Q = Psq.Make (I)(I)
+let q = (module Q: S)
+let m = (module struct
+  module M = Map.Make (I)
+  type t = int M.t
+  let find, add, remove = M.(find_opt, add, remove)
+  let of_list xs = List.fold_left (fun m (k, v) -> M.add k v m) M.empty xs
+end: S)
+
+open Unmark
+
+let runs ((module M: S)) size =
+  let xs = r_bindings size in
+  let q  = M.of_list xs
+  and q' = List.rev_map (fun (k, p) -> (k * 2, p * 2)) xs |> M.of_list in
+  group (Fmt.strf "x%d" size) [
+    bench "find" (fun () -> M.find (Random.int size) q)
+  ; bench "add" (fun () -> let k = Random.int size + 1 in M.add k k q')
+  ; bench "remove" (fun () -> M.remove (Random.int size) q)
+  ]
+
+let runs1 size =
+  let xs = r_bindings size in
+  let q = Q.of_list xs in
+  group (Fmt.strf "x%d" size) [
+    group "of_" [
+      bench "of_sorted_list" (fun () -> Q.of_sorted_list xs)
+    ; bench "of_list" (fun () -> Q.of_list xs)
+    ; bench "of_seq" (fun () -> Q.of_seq (List.to_seq xs))
+    ; bench "add_seq" (fun () -> Q.(add_seq (List.to_seq xs) empty))
+    ];
+    group "to_" [
+      bench "to_p_list" (fun () -> Q.to_priority_list q)
+    ; bench "to_seq" (fun () -> Q.to_seq q |> Seq.iter ignore)
+    ; bench "to_list" (fun () -> Q.to_list q)
+    ]
+  ]
+
+let runs2 size =
+  let r_key () = Random.int (size * 5) in
+  let gen n = List.init n Random.(fun _ -> r_key (), int n) |> Q.of_list in
+  let xs, ys, zs = gen size, gen size, gen 10 in
+  group (Fmt.strf "x%d" size) [
+    bench "split" (fun () -> Q.split_at (r_key ()) xs);
+    bench "filter" (fun () ->
+      let x = r_key () in Q.filter (fun k _ -> k <= x) xs);
+    bench "++" (fun () -> Q.(xs ++ ys));
+    bench "++ k" (fun () -> Q.(xs ++ zs));
+  ]
+
+
+let arg = Cmdliner.Arg.(
+  value @@ opt (list int) [10; 100; 1000] @@ info ["sizes"])
+let _ = Unmark_cli.main_ext "psq" ~arg @@ fun ns -> [
+    bench "Random.int" (fun () -> Random.int 1000)
+  ; group "map" (List.map (runs m) ns)
+  ; group "psq" (List.map (runs q) ns)
+  ; group "psq1" (List.map runs1 ns)
+  ; group "psq2" (List.map runs2 ns)
+]

unikernel/duniverse/psq/test/dune

@@ -0,0 +1,14 @@
+(test
+  (name test)
+  (modules test)
+  (libraries psq alcotest qcheck-core qcheck-alcotest))
+
+(executable
+  (name bench)
+  (modules bench)
+  (libraries psq unmark unmark.cli))
+
+(executable
+  (name search)
+  (modules search)
+  (libraries psq fmt))

unikernel/duniverse/psq/test/search.ml

@@ -0,0 +1,55 @@
+(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+let rec mem ?(cmp=compare) a = function
+  | [] -> false | x::xs -> cmp a x = 0 || mem ~cmp a xs
+
+let rec add ?(cmp=compare) a = function
+  | []    -> [a]
+  | x::xs ->
+      match cmp a x with -1 -> a::x::xs | 1 -> x::add ~cmp a xs | _ -> x::xs
+
+let astar (type a) ?(cmp=compare) start graph h sat =
+  let module K = struct type t = a let compare = cmp end in
+  let module P = struct
+    type t = int * a list
+    let compare (a: t) b = compare (fst a) (fst b)
+  end in
+  let module Q = Psq.Make(K)(P) in
+  let rec go q = match Q.pop q with
+    | Some ((a, (dist, path)), q) ->
+        if sat a then Some (dist, a, List.rev path) else
+          let f q (w, b) =
+            let d' = w + h b in
+            if mem ~cmp b path then q else
+              match Q.find b q with
+              | Some (d, _) when d <= d' -> q
+              | _ -> Q.add b (d', a::path) q in
+          go @@ List.fold_left f q @@ graph a
+    | None -> None in
+  go Q.(sg start (0, []))
+
+let labyrinth p0 (pn_m, pn_n as pn) grid =
+  let (m0, n0) = Array.(length grid, length grid.(0)) in
+  let h (m, n) = abs (pn_m - m) + abs (pn_n - n)
+  and sat mn = mn = pn
+  and graph (m, n) =
+    (if m > 0    && grid.(m-1).(n) = `o then [1, (m-1, n)] else []) @
+    (if m < m0-1 && grid.(m+1).(n) = `o then [1, (m+1, n)] else []) @
+    (if n > 0    && grid.(m).(n-1) = `o then [1, (m, n-1)] else []) @
+    (if n < n0-1 && grid.(m).(n+1) = `o then [1, (m, n+1)] else []) in
+  match astar ~cmp:compare p0 graph h sat with
+  | None -> Fmt.pr "not found\n%!"
+  | Some (dist, (m, n), path) ->
+      Fmt.(pr "@[(%d, %d), dist: %d@;steps: %a@]\n%!"
+        m n dist (Dump.(list (pair int int))) path)
+
+let l : [`X|`o] array array =
+[|[| `o; `X; `o; `o; `o; `o; |];
+  [| `o; `X; `X; `X; `o; `o; |];
+  [| `o; `o; `o; `o; `X; `o; |];
+  [| `o; `X; `X; `X; `o; `o; |];
+  [| `o; `X; `o; `o; `o; `o; |];
+  [| `o; `o; `o; `X; `X; `o; |]|]
+
+let () = labyrinth (0, 0) (5, 5) l

unikernel/duniverse/psq/test/test.ml

@@ -0,0 +1,201 @@
+(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+let id x = x
+let (%) f g x = f (g x)
+
+module I = struct type t = int let compare (a: int) b = compare a b end
+module Q = Psq.Make (I) (I)
+
+let list_of_iter_2 i =
+  let xs = ref [] in i (fun a b -> xs := (a, b) :: !xs); List.rev !xs
+let rec unfold f s = match f s with Some (x, s) -> x :: unfold f s | _ -> []
+
+let cmpi (a: int) b = compare a b
+let (%%) f g a b = f (g a) (g b)
+let (=>) cmp1 cmp2 a b = match cmp1 a b with 0 -> cmp2 a b | r -> r
+let k_order xs = List.sort (cmpi %% fst) xs
+let pk_order xs = List.sort (cmpi %% snd => cmpi %% fst) xs
+let k_order_uniq xs =
+  let cmp_kp = cmpi %% fst => cmpi %% snd and cmp_k = cmpi %% fst in
+  match List.sort_uniq cmp_kp xs with
+  | [] -> []
+  | kp0::kps ->
+      let f kp xs kp0 = if cmp_k kp kp0 = 0 then xs kp0 else kp :: xs kp in
+      kp0 :: List.fold_right f kps (fun _ -> []) kp0
+
+let is_balanced q =
+  let (n, d) = Q.(size q, depth q) in
+  n <= 1 || float d < log (float n) *. log 10. *. 3.75
+
+let (!) q = `Sem (Q.to_list q)
+let sem xs = `Sem (k_order_uniq xs)
+
+let g_size = QCheck.Gen.(small_nat >|= fun x -> x mod 1_000)
+let bindings = QCheck.(
+  make Gen.(list_size g_size (pair small_nat small_nat))
+    ~print:Fmt.(to_to_string Dump.(pair int int |> list))
+    ~shrink:Shrink.list)
+let psq = QCheck.(
+  map Q.of_list bindings ~rev:Q.to_list |>
+    set_print Fmt.(to_to_string (Q.pp_dump int int)))
+let kv = QCheck.small_nat
+let psq_w arb = QCheck.pair psq arb
+let psq_w_any_key = psq_w kv
+
+let test name gen p =
+  QCheck.Test.make ~count:200 ~name gen p |> QCheck_alcotest.to_alcotest
+
+let () = Alcotest.run "psq" [
+
+  "of_list", [
+    test "sem" bindings (fun xs -> !(Q.of_list xs) = sem xs);
+    test "of_sorted_list sem" bindings
+      (fun xs -> !(Q.of_sorted_list (k_order_uniq xs)) = sem xs);
+    test "bal" bindings (fun xs -> is_balanced (Q.of_list xs));
+  ];
+
+  "to_list", [
+    test "order" psq (fun q -> Q.to_list q = k_order (Q.to_list q));
+  ];
+
+  "to_priority_list", [
+    test "sem" psq (fun q -> Q.to_priority_list q = pk_order (Q.to_list q))
+  ];
+
+  "size", [
+    test "sem" psq (fun q -> Q.size q = List.length (Q.to_list q));
+  ];
+
+  "sg", [
+    test "sem" kv (fun x -> !Q.(sg x x) = sem [x, x]);
+  ];
+
+  "(++)", [
+    test "sem" QCheck.(pair bindings bindings)
+      (fun (xs1, xs2) -> !Q.(of_list xs1 ++ of_list xs2) = sem (xs1 @ xs2));
+    test "comm" QCheck.(pair psq psq)
+      (fun (q1, q2) -> !Q.(q1 ++ q2) = !Q.(q2 ++ q1));
+    test "assoc" QCheck.(pair psq psq |> pair psq)
+      (fun (q1, (q2, q3)) -> !Q.((q1 ++ q2) ++ q3) = !Q.(q1 ++ (q2 ++ q3)));
+  ];
+
+  "split_at", [
+    test "sem" psq_w_any_key (fun (q, k) ->
+      let q1, q2 = Q.split_at k q
+      and xs1, xs2 = List.partition (fun (k1, _) -> k1 <= k) (Q.to_list q) in
+      !q1 = sem xs1 && !q2 = sem xs2);
+    test "inv" psq_w_any_key (fun (q, k) ->
+      let q1, q2 = Q.split_at k q in !q = !Q.(q1 ++ q2));
+  ];
+
+  "membership", [
+    test "find sem" psq_w_any_key
+      (fun (q, x) -> Q.find x q = List.assoc_opt x (Q.to_list q));
+    test "mem ==> find" psq_w_any_key
+      (fun (q, k) -> QCheck.assume Q.(mem k q); Q.find k q <> None);
+    test "find ==> mem" psq_w_any_key
+      (fun (q, k) -> QCheck.assume (Q.find k q <> None); Q.mem k q);
+  ];
+
+  "update", [
+    test "sem" (psq_w QCheck.(pair kv (option kv)))
+      (fun (q, (x, yy)) ->
+        let kp = match yy with Some y -> [x, y] | _ -> [] in
+        !(Q.update x (fun _ -> yy) q) =
+          sem (kp @ List.remove_assoc x (Q.to_list q)));
+    test "bal" (psq_w QCheck.(pair kv (option kv)))
+      (fun (q, (x, yy)) -> is_balanced (Q.update x (fun _ -> yy) q));
+    test "phys" psq_w_any_key (fun (q, x) -> Q.update x id q == q);
+  ];
+
+  "add", [
+    test "sem" psq_w_any_key
+      (fun (q, x) ->
+        !(Q.add x x q) = sem ((x, x) :: List.remove_assoc x (Q.to_list q)));
+    test "bal" psq_w_any_key (fun (q, k) -> is_balanced (Q.add k k q));
+  ];
+
+  "push", [
+    test "sem" psq_w_any_key
+      (fun (q, x) ->
+        let p = match List.assoc_opt x (Q.to_list q) with
+        | Some p0 -> min x p0
+        | None -> x in
+        !(Q.push x x q) = sem ((x, p) :: List.remove_assoc x (Q.to_list q)));
+    test "mono" psq_w_any_key
+       (fun (q, x) ->
+         QCheck.assume (Q.mem x q);
+         Q.find x (Q.push x x q) <= Q.find x q);
+    test "comm" (psq_w (QCheck.pair kv kv))
+      (fun (q, (x, y)) ->
+        !Q.(q |> push x x |> push x y) = !Q.(q |> push x y |> push x x));
+    test "= of_list" bindings
+      (fun xs ->
+        !(Q.of_list xs) =
+          !(List.fold_left (fun q (k, p) -> Q.push k p q) Q.empty xs));
+  ];
+
+  "remove", [
+    test "sem" psq_w_any_key
+      (fun (q, k) ->
+        !(Q.remove k q) = sem (List.remove_assoc k (Q.to_list q)));
+    test "phys" psq_w_any_key
+      (fun (q, k) -> QCheck.assume (not (Q.mem k q)); Q.remove k q == q);
+    test "bal" psq_w_any_key (fun (q, k) -> Q.(remove k q |> is_balanced));
+  ];
+
+  "adjust", [
+    test "sem" psq_w_any_key
+      (fun (q, x) ->
+        !(Q.adjust x succ q) =
+          sem (Q.to_list q |>
+            List.map (fun (k, p) -> (k, if k = x then succ p else p))));
+  ];
+
+  "pop", [
+    test "sem1" psq (fun q -> unfold Q.pop q = pk_order (Q.to_list q));
+    test "sem2" psq (fun q -> unfold Q.pop q = Q.to_priority_list q);
+    test "min, rest" psq
+      (fun q ->
+        QCheck.assume (not (Q.is_empty q));
+        match Q.(pop q, min q, rest q) with
+          Some (kp1, q1), Some kp2, Some q2 -> kp1 = kp2 && !q1 = !q2
+        | _ -> false);
+  ];
+
+  "at_most", [
+    test "sem" psq_w_any_key
+      (fun (q, x) ->
+        List.of_seq (Q.to_seq_at_most x q) =
+          List.filter (fun kp -> snd kp <= x) (Q.to_list q));
+    test "seq = fold" psq_w_any_key
+      (fun (q, x) ->
+        List.of_seq (Q.to_seq_at_most x q) =
+          Q.fold_at_most x (fun k p xs -> (k, p)::xs) [] q);
+    test "seq = iter" psq_w_any_key
+      (fun (q, x) ->
+        List.of_seq (Q.to_seq_at_most x q) =
+          list_of_iter_2 (fun f -> Q.iter_at_most x f q));
+  ];
+
+  "to_stuff", [
+    test "to_list = to_seq" psq
+      (fun q -> Q.to_list q = (Q.to_seq q |> List.of_seq));
+    test "to_list = fold" psq
+      (fun q -> Q.to_list q = Q.fold (fun k p xs -> (k, p) :: xs) [] q);
+    test "to_list = iter" psq
+      (fun q -> Q.to_list q = list_of_iter_2 (fun f -> Q.iter f q));
+    test "to_priority_seq" psq
+      (fun q -> Q.to_priority_list q = List.of_seq (Q.to_priority_seq q));
+  ];
+
+  "filter", [
+    test "sem" psq_w_any_key
+      (fun (q, k0) ->
+        !(Q.filter (fun k _ -> k <= k0) q) =
+          sem (List.filter (fun (k, _) -> k <= k0) (Q.to_list q)));
+    test "bal" psq_w_any_key
+      (fun (q, k0) -> is_balanced (Q.filter (fun k _ -> k <= k0) q));
+  ];
+]