├── .gitignore ├── .ocamlformat ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── bench ├── bench.html ├── bench_with_bechamel.ml ├── bfs.ml └── dune ├── database.json ├── dune-project ├── example ├── dune └── packer.ml ├── fuzz ├── dune └── fuzz.ml ├── ke.opam ├── lib ├── dune ├── fke.ml ├── fke.mli ├── ke.ml ├── ke.mli ├── minifmt.ml ├── rke.ml ├── rke.mli └── sigs.ml └── test ├── dune └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | setup.data 3 | setup.log 4 | doc/*.html 5 | *.native 6 | *.byte 7 | *.so 8 | lib/decompress_conf.ml 9 | *.tar.gz 10 | _tests 11 | lib_test/files 12 | zpipe 13 | c/dpipe 14 | *.merlin 15 | *.install -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.25.1 2 | module-item-spacing=compact 3 | break-struct=natural 4 | break-infix=fit-or-vertical 5 | parens-tuple=always 6 | wrap-comments=false 7 | break-collection-expressions=wrap 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: 3 | - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | - wget https://raw.githubusercontent.com/dinosaure/ocaml-travisci-skeleton/master/.travis-docgen.sh 5 | script: bash -ex .travis-opam.sh 6 | sudo: true 7 | env: 8 | matrix: 9 | - PACKAGE="ke" OCAML_VERSION=4.03 TESTS=true 10 | - PACKAGE="ke" OCAML_VERSION=4.04 TESTS=true 11 | - PACKAGE="ke" OCAML_VERSION=4.05 TESTS=true 12 | - PACKAGE="ke" OCAML_VERSION=4.06 TESTS=true 13 | - PACKAGE="ke" OCAML_VERSION=4.07 TESTS=true 14 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### v0.6 2022-04-07 Paris (France) 2 | 3 | * Require OCaml 4.08 and remove `bigarray-compat` dependency (@hannesm, #17) 4 | 5 | ### v0.5 2022-03-18 Paris (France) 6 | 7 | * Remove `{build}` directive into the OPAM file (@CraigFe, #10) 8 | * Add `unsafe_bigarray` into `Rke.Weighted` (@anmonteiro, #11) 9 | * Lint OPAM file (@kit-ty-kate, #12) 10 | * Fix the distribution and the CI (@dinosaure, #13) 11 | * Update the distribution with `cmdliner.1.1.0` (@dinosaure, #15) 12 | 13 | ### v0.4 2019-07-24 Мостар (Боснa и Херцеговина) 14 | 15 | * Call `dune subst` only when we _pin_ `ke` 16 | * Update documentation (@dinosaure, @Drup) 17 | - Typography 18 | - Documentation about `Fke.tail{,_exn}` 19 | - Documentation about `Fke.rev_iter` 20 | * Add `Fke.tail{,_exn}` (@dinosaure, #8) 21 | * Add `Fke.rev_iter` (@dinosaure, #9) 22 | * Compatible with `mirage`, dependance with `bigarray-compat` (@dinosaure, @TheLortex, #8) 23 | * Update OPAM file (@dinosaure) 24 | 25 | ### v0.3 2019-04-10 Paris (France) 26 | 27 | * Add `Rke.{,Weighted}.compress` function (fuzzed) 28 | * Update `bechamel` benchmark 29 | * Add `Rke{,.Weighted}.N.peek` function 30 | * Fix bug on `Rke.Weighted.N.keep` function 31 | * Add some tests 32 | 33 | ### v0.2 2019-01-14 Paris (France) 34 | 35 | * Add pretty-printer 36 | * Randomize `pop` action on the fuzzer 37 | * Add tests on `Rke` and `Rke.Weighted` (with `alcotest`) 38 | * Fix bug retrieved by `ocaml-git` (see 453633b) 39 | * Add `rev_iter` function 40 | * Fix bug on `Rke.N.keep_exn` (see 3951501) 41 | * Add Travis CI support 42 | 43 | ### v0.1 2018-12-20 Paris (France) 44 | 45 | * First release 46 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Romain Calascibetta 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Ke - Fast implementation of Queue in OCaml 2 | ========================================== 3 | 4 | ![travis-ci](https://travis-ci.org/mirage/ke.svg?banch=master) 5 | 6 | Queue or FIFO is one of the most famous data-structure used in several 7 | algorithms. `Ke` provides some implementations of it in a functional or 8 | imperative way. 9 | 10 | It is a little library with a benchmark 11 | ([`bechamel`](https://github.com/dinosaure/bechamel.git) or `core_bench`), 12 | a fuzzer and tests. 13 | 14 | We provide a functional interface `Fke` or an imperative interface `Rke`. 15 | 16 | From what we know, `Ke.Rke` is faster than `Queue` from the 17 | standard library or the `base` package. The type of data that it can store 18 | is limited (only supports the types supported by [`Bigarray.kind`](https://v2.ocaml.org/releases/5.1/api/Bigarray.html#TYPEkind)) 19 | , but this is enough for a lot of algorithms. The fast 20 | operations are: put some elements faster than a sequence of `Queue.push`, and 21 | get some elements faster than a sequence of `Queue.pop`. 22 | 23 | We provide extended implementations (`Rke.Weighted` and `Fke.Weighted`) with 24 | a limit on the number of elements stored. The purpose is to limit memory 25 | consumption of the queue when we use it in some contexts (like _encoder_). 26 | 27 | Again, as a part of the MirageOS project, `Ke` does not rely on C stubs, 28 | `Obj.magic` and so on. 29 | 30 | Author: Romain Calascibetta 31 | 32 | Documentation: https://mirage.github.io/ke/ 33 | 34 | Implementation notes 35 | ==================== 36 | 37 | The functional implementation `Fke` comes from Okazaki's queue 38 | implementation with GADT to discard impossible cases. 39 | 40 | `Rke`, `Rke.Weighted` and `Fke.Weighted` are limited by kind and follow Xen's 41 | implementation of the shared memory ring-buffer. The length of the internal buffer 42 | is always a power of two - that means for a large number of elements 43 | this kind of queue may not fit your requirements. 44 | 45 | A fuzzer was made to compare the standard `Queue` (as an oracle) with `Rke` and 46 | `Fke`. We construct a set of actions (`push` and `pop`) and ensure (by GADT) to 47 | never `pop` an empty queue. 48 | -------------------------------------------------------------------------------- /bench/bench.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 163 | 164 | 165 | 166 | 1044 | 1045 | 1046 | 1047 | -------------------------------------------------------------------------------- /bench/bench_with_bechamel.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | open Toolkit 3 | 4 | let random ln = 5 | let ic = open_in "/dev/urandom" in 6 | let rs = Bytes.create ln in 7 | really_input ic rs 0 ln; 8 | close_in ic; 9 | Bytes.unsafe_to_string rs 10 | 11 | let push_fke n = 12 | let raw = random n in 13 | let data = List.init n (String.get raw) in 14 | Staged.stage (fun () -> List.fold_left Ke.Fke.push Ke.Fke.empty data) 15 | 16 | let push_rke n = 17 | let queue = Ke.Rke.create ~capacity:n Bigarray.Char in 18 | let raw = random n in 19 | Staged.stage (fun () -> String.iter (Ke.Rke.push queue) raw) 20 | 21 | let push_rke_n n = 22 | let queue = Ke.Rke.create ~capacity:n Bigarray.Char in 23 | let raw = random n in 24 | let blit src src_off dst dst_off len = 25 | Bigstringaf.unsafe_blit_from_string src ~src_off dst ~dst_off ~len 26 | in 27 | Staged.stage (fun () -> Ke.Rke.N.push queue ~blit ~length:String.length raw) 28 | 29 | let push_queue n = 30 | let queue = Queue.create () in 31 | let raw = random n in 32 | Staged.stage (fun () -> String.iter (fun chr -> Queue.add chr queue) raw) 33 | 34 | let push_and_pop_fke n = 35 | let raw = random n in 36 | let data = List.init n (String.get raw) in 37 | Staged.stage (fun () -> 38 | let q = List.fold_left Ke.Fke.push Ke.Fke.empty data in 39 | let rec go q = 40 | if not (Ke.Fke.is_empty q) then 41 | let _, q = Ke.Fke.pop_exn q in 42 | go q 43 | else () 44 | in 45 | go q) 46 | 47 | let push_and_pop_rke n = 48 | let queue = Ke.Rke.create ~capacity:n Bigarray.Char in 49 | let raw = random n in 50 | Staged.stage (fun () -> 51 | String.iter (Ke.Rke.push queue) raw; 52 | while not (Ke.Rke.is_empty queue) do 53 | ignore (Ke.Rke.pop queue) 54 | done) 55 | 56 | let push_and_pop_queue n = 57 | let queue = Queue.create () in 58 | let raw = random n in 59 | Staged.stage (fun () -> 60 | String.iter (fun chr -> Queue.add chr queue) raw; 61 | while not (Queue.is_empty queue) do 62 | ignore (Queue.pop queue) 63 | done) 64 | 65 | let test_push_fke = 66 | Test.make_indexed ~name:"Fke.push" 67 | ~args:[ 100; 500; 1000; 5000; 10000 ] 68 | push_fke 69 | 70 | let test_push_rke = 71 | Test.make_indexed ~name:"Rke.push" 72 | ~args:[ 100; 500; 1000; 5000; 10000 ] 73 | push_rke 74 | 75 | let test_push_rke_n = 76 | Test.make_indexed ~name:"Rke.N.push" 77 | ~args:[ 100; 500; 1000; 5000; 10000 ] 78 | push_rke_n 79 | 80 | let test_push_queue = 81 | Test.make_indexed ~name:"Queue.push" 82 | ~args:[ 100; 500; 1000; 5000; 10000 ] 83 | push_queue 84 | 85 | let tests_push = 86 | [ test_push_fke; test_push_rke; test_push_rke_n; test_push_queue ] 87 | 88 | let big_push_fke n = 89 | Staged.stage @@ fun () -> 90 | let q = ref Ke.Fke.empty in 91 | for i = 1 to n do 92 | q := Ke.Fke.push !q i 93 | done 94 | 95 | let big_push_rke n = 96 | Staged.stage @@ fun () -> 97 | let q = Ke.Rke.create ~capacity:n Bigarray.Char in 98 | for i = 1 to n do 99 | Ke.Rke.push q (Obj.magic i) 100 | done 101 | 102 | let big_push_queue n = 103 | Staged.stage @@ fun () -> 104 | let q = Queue.create () in 105 | for i = 1 to n do 106 | Queue.push i q 107 | done 108 | 109 | let test_big_push_fke = 110 | Test.make_indexed ~name:"Fke.big_push" ~args:[ 10; 1_000_000 ] big_push_fke 111 | 112 | let test_big_push_rke = 113 | Test.make_indexed ~name:"Rke.big_push" ~args:[ 10; 1_000_000 ] big_push_rke 114 | 115 | let test_big_push_queue = 116 | Test.make_indexed ~name:"Queue.big_push" ~args:[ 10; 1_000_000 ] 117 | big_push_queue 118 | 119 | let tests_big_push = 120 | [ test_big_push_fke; test_big_push_rke; test_big_push_queue ] 121 | 122 | let test_push_and_pop_fke = 123 | Test.make_indexed ~name:"Fke.push & Fke.pop" 124 | ~args:[ 100; 500; 1000; 5000; 10000 ] 125 | push_and_pop_fke 126 | 127 | let test_push_and_pop_rke = 128 | Test.make_indexed ~name:"Rke.push & Rke.pop" 129 | ~args:[ 100; 500; 1000; 5000; 10000 ] 130 | push_and_pop_rke 131 | 132 | let test_push_and_pop_queue = 133 | Test.make_indexed ~name:"Queue.push & Queue.pop" 134 | ~args:[ 100; 500; 1000; 5000; 10000 ] 135 | push_and_pop_queue 136 | 137 | let tests_push_and_pop = 138 | [ test_push_and_pop_fke; test_push_and_pop_rke; test_push_and_pop_queue ] 139 | 140 | let ( <.> ) f g x = f (g x) 141 | let nothing _ = Ok () 142 | 143 | let () = 144 | let ols = 145 | Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:Measure.[| run |] 146 | in 147 | let instances = 148 | Instance.[ minor_allocated; major_allocated; monotonic_clock ] 149 | in 150 | let tests = 151 | match Sys.argv with 152 | | [| _ |] -> [] 153 | | [| _; "push" |] -> tests_push 154 | | [| _; "push&pop" |] -> tests_push_and_pop 155 | | [| _; "big-push" |] -> tests_big_push 156 | | [| _; "all" |] -> tests_push @ tests_big_push @ tests_push_and_pop 157 | | _ -> Fmt.invalid_arg "%s {push|push&pop|big-push|all}" Sys.argv.(1) 158 | in 159 | let tests = Bechamel.Test.make_grouped ~name:"ke" tests in 160 | let cfg = Benchmark.cfg ~limit:3000 () in 161 | let raw_results = Benchmark.all cfg instances tests in 162 | let results = 163 | List.map (fun instance -> Analyze.all ols instance raw_results) instances 164 | |> Analyze.merge ols instances 165 | in 166 | let open Bechamel_js in 167 | emit ~dst:(Channel stdout) nothing ~compare:String.compare 168 | ~x_label:Measure.run 169 | ~y_label:(Measure.label Instance.monotonic_clock) 170 | (results, raw_results) 171 | |> Rresult.R.failwith_error_msg 172 | -------------------------------------------------------------------------------- /bench/bfs.ml: -------------------------------------------------------------------------------- 1 | module type F_PROBLEM = sig 2 | type state 3 | type move 4 | 5 | val success : state -> bool 6 | val moves : state -> (move * state) list 7 | 8 | type table 9 | 10 | val create : unit -> table 11 | val add : table -> state -> unit 12 | val mem : table -> state -> bool 13 | val clear : table -> unit 14 | end 15 | 16 | module type M_PROBLEM = sig 17 | type move 18 | 19 | val success : unit -> bool 20 | val moves : unit -> move list 21 | val do_move : move -> unit 22 | val undo_move : move -> unit 23 | val add : unit -> unit 24 | val mem : unit -> bool 25 | val clear : unit -> unit 26 | end 27 | 28 | module F (Q : Ke.Sigs.M) (P : F_PROBLEM) = struct 29 | let search s0 = 30 | let visited = P.create () in 31 | let already s = 32 | P.mem visited s 33 | || 34 | (P.add visited s; 35 | false) 36 | in 37 | let _ = already s0 in 38 | let q = Q.create () in 39 | Q.push q ([], s0); 40 | let rec bfs () = 41 | if Q.is_empty q then raise Not_found; 42 | let path, s = Q.pop_exn q in 43 | if P.success s then (s, List.rev path) 44 | else ( 45 | List.iter 46 | (fun (m, s') -> if not (already s') then Q.push q (m :: path, s')) 47 | (P.moves s); 48 | bfs ()) 49 | in 50 | bfs () 51 | end 52 | 53 | module M (Q : Ke.Sigs.M) (P : M_PROBLEM) = struct 54 | let rec cut_head n l = if n == 0 then l else cut_head (pred n) (List.tl l) 55 | 56 | let common_psuffix (n1, l1) (n2, l2) = 57 | let rec suffix l1 l2 = 58 | if l1 == l2 then l1 else suffix (List.tl l1) (List.tl l2) 59 | in 60 | if n1 < n2 then suffix l1 (cut_head (n2 - n1) l2) 61 | else if n2 < n1 then suffix (cut_head (n1 - n2) l1) l2 62 | else suffix l1 l2 63 | 64 | let search () = 65 | let already () = 66 | P.mem () 67 | || 68 | (P.add (); 69 | false) 70 | in 71 | let q = Q.create () in 72 | Q.push q (0, []); 73 | let cpath = ref (0, []) in 74 | let rec restore_state path = 75 | let suf = common_psuffix path !cpath in 76 | let rec backward = function 77 | | m :: r as p when p != suf -> 78 | P.undo_move m; 79 | backward r 80 | | _ -> () 81 | in 82 | let rec forward = function 83 | | m :: r as p when p != suf -> 84 | forward r; 85 | P.do_move m 86 | | _ -> () 87 | in 88 | backward (snd !cpath); 89 | forward (snd path); 90 | cpath := path 91 | in 92 | let rec bfs () = 93 | if Q.is_empty q then raise Not_found; 94 | let ((n, path) as s) = Q.pop_exn q in 95 | restore_state s; 96 | if P.success () then List.rev path 97 | else if not (already ()) then ( 98 | List.iter (fun m -> Q.push q (succ n, m :: path)) (P.moves ()); 99 | bfs ()) 100 | else bfs () 101 | in 102 | bfs () 103 | end 104 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bench_with_bechamel) 3 | (modules bench_with_bechamel) 4 | (libraries bigstringaf ke bechamel bechamel-js)) 5 | 6 | (rule 7 | (targets bench.json) 8 | (enabled_if 9 | (= %{profile} benchmark)) 10 | (action 11 | (with-stdout-to 12 | %{targets} 13 | (run ./bench_with_bechamel.exe push&pop)))) 14 | 15 | (rule 16 | (targets bench.html) 17 | (mode promote) 18 | (enabled_if 19 | (= %{profile} benchmark)) 20 | (action 21 | (system "%{bin:bechamel-html} < %{dep:bench.json} > %{targets}"))) 22 | -------------------------------------------------------------------------------- /database.json: -------------------------------------------------------------------------------- 1 | [ 2 | {"name": "First node", "time": "0", "ancestors": []}, 3 | {"name": "Second node", "time": "1", "ancestors": [0]} 4 | ] 5 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name ke) 3 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name packer) 3 | (libraries psq ke jsonm fmt rresult cmdliner json-data-encoding lwt lwt.unix)) 4 | -------------------------------------------------------------------------------- /example/packer.ml: -------------------------------------------------------------------------------- 1 | let () = Printexc.record_backtrace true 2 | 3 | module type GRAPH = sig 4 | type t 5 | type id 6 | type value 7 | type error = private [> `Not_found ] 8 | 9 | val pp_error : error Fmt.t 10 | val preds : value -> id list 11 | val get : t -> id -> (value, error) result Lwt.t 12 | val compare : value -> value -> int 13 | end 14 | 15 | module Make (Q : Ke.Sigs.R) (G : GRAPH with type id = nativeint) = struct 16 | open Lwt 17 | 18 | exception Graph of G.error 19 | 20 | module Node = struct 21 | type t = { value : G.value; mutable color : [ `White | `Black ] } 22 | 23 | let compare a b = G.compare a.value b.value 24 | end 25 | 26 | module Pq = Psq.Make (Nativeint) (Node) 27 | module Map = Map.Make (Nativeint) 28 | 29 | let pack graph exclude roots = 30 | let store = Hashtbl.create 128 in 31 | let memoize get id = 32 | try 33 | let ret = Hashtbl.find store id in 34 | Lwt.return (Some ret) 35 | with Not_found -> ( 36 | get id >>= function 37 | | Ok value -> 38 | let node = { Node.value; color = `White } in 39 | Hashtbl.add store id node; 40 | Lwt.return (Some node) 41 | | Error `Not_found -> Lwt.return None 42 | | Error err -> Lwt.fail (Graph err)) 43 | in 44 | let preds v = G.preds v in 45 | let get = memoize (G.get graph) in 46 | let all_blacks pq = 47 | Pq.fold 48 | (fun _ -> function 49 | | { Node.color = `Black; _ } -> ( && ) true 50 | | _ -> ( && ) false) 51 | true pq 52 | in 53 | let propagate { Node.value; color } = 54 | let p = preds value in 55 | let q = Q.create ~capacity:(List.length p) Bigarray.Nativeint in 56 | let rec go () = 57 | match Q.pop q with 58 | | Some id -> ( 59 | try 60 | let node = Hashtbl.find store id in 61 | node.Node.color <- color; 62 | go (List.iter (Q.push q) (preds node.Node.value)) 63 | with Not_found -> go ()) 64 | | None -> () 65 | in 66 | List.iter (Q.push q) p; 67 | go () 68 | in 69 | let rec garbage pq = 70 | if all_blacks pq then Lwt.return () 71 | else 72 | match Pq.pop pq with 73 | | Some ((_, { Node.value; color = `Black }), pq) -> 74 | Lwt_list.fold_left_s 75 | (fun pq id -> 76 | get id >>= function 77 | | Some ({ Node.color = `White; _ } as node) -> 78 | node.Node.color <- `Black; 79 | propagate node; 80 | Lwt.return (Pq.add id node pq) 81 | | Some node -> Lwt.return (Pq.add id node pq) 82 | | None -> Lwt.return pq) 83 | pq (preds value) 84 | >>= garbage 85 | | Some ((_, { Node.value; _ }), pq) -> 86 | Lwt_list.fold_left_s 87 | (fun pq id -> 88 | get id >>= function 89 | | None -> Lwt.return pq 90 | | Some node -> Lwt.return (Pq.add id node pq)) 91 | pq (preds value) 92 | >>= garbage 93 | | None -> Lwt.return () 94 | in 95 | let collect () = 96 | Hashtbl.fold 97 | (fun id -> function 98 | | { Node.color = `White; value } -> Map.add id value 99 | | _ -> fun acc -> acc) 100 | store Map.empty 101 | in 102 | Lwt_list.map_s 103 | (fun id -> 104 | get id >>= function 105 | | Some node -> Lwt.return (Some (id, node)) 106 | | None -> Lwt.return None) 107 | roots 108 | >>= fun roots -> 109 | Lwt_list.map_s 110 | (fun id -> 111 | get id >>= function 112 | | Some node -> 113 | node.Node.color <- `Black; 114 | Lwt.return (Some (id, node)) 115 | | None -> Lwt.return None) 116 | exclude 117 | >|= List.append roots 118 | >|= List.fold_left 119 | (fun acc -> function None -> acc | Some x -> x :: acc) 120 | [] 121 | >|= Pq.of_list 122 | >>= fun pq -> garbage pq >|= collect 123 | end 124 | 125 | module Git = struct 126 | type t = unit 127 | type id = nativeint 128 | type value = { name : string; time : int64; ancestors : nativeint list } 129 | type error = [ `Not_found ] 130 | 131 | let pp_error ppf = function `Not_found -> Fmt.string ppf "`Not_found" 132 | let store : (id, value) Hashtbl.t = Hashtbl.create 16 133 | let preds { ancestors; _ } = ancestors 134 | 135 | let get () id = 136 | try Lwt.return_ok (Hashtbl.find store id) 137 | with Not_found -> Lwt.return_error `Not_found 138 | 139 | let compare { time = a; _ } { time = b; _ } = Int64.compare a b 140 | end 141 | 142 | module Packer = Make (Ke.Rke) (Git) 143 | 144 | let json = 145 | let open Json_encoding in 146 | let name = req "name" string in 147 | let time = req "time" (conv Int64.to_string Int64.of_string string) in 148 | let ancestors = 149 | req "ancestors" (list (conv Nativeint.to_int32 Nativeint.of_int32 int32)) 150 | in 151 | conv 152 | (fun { Git.name; time; ancestors } -> (name, time, ancestors)) 153 | (fun (name, time, ancestors) -> { Git.name; time; ancestors }) 154 | (obj3 name time ancestors) 155 | 156 | type await = [ `Await ] 157 | type error = [ `Error of Jsonm.error ] 158 | type eoi = [ `End ] 159 | type value = [ `Null | `Bool of bool | `String of string | `Float of float ] 160 | 161 | let pp_json ppf v = 162 | let rec pp_value ppf = function 163 | | `Bool v -> Fmt.bool ppf v 164 | | `String v -> Fmt.quote Fmt.text ppf v 165 | | `Float v -> Fmt.float ppf v 166 | | `Null -> Fmt.string ppf "" 167 | | `A l -> pp_arr ppf l 168 | | `O l -> pp_obj ppf l 169 | and pp_arr ppf arr = Fmt.(using Array.of_list (Dump.array pp_value)) ppf arr 170 | and pp_obj ppf obj = 171 | Fmt.Dump.iter_bindings 172 | (fun f -> List.iter (fun (k, v) -> f k v)) 173 | Fmt.(any "object") 174 | Fmt.string pp_value ppf obj 175 | in 176 | pp_value ppf v 177 | 178 | let of_database ic : Git.value list = 179 | let decoder = Jsonm.decoder (`Channel ic) in 180 | 181 | let error (`Error err) = Fmt.invalid_arg "%a" Jsonm.pp_error err in 182 | let end_of_input `End = Fmt.invalid_arg "Unexpected end of input" in 183 | 184 | let rec arr acc k = 185 | match Jsonm.decode decoder with 186 | | #await -> assert false 187 | | #error as v -> error v 188 | | #eoi as v -> end_of_input v 189 | | `Lexeme `Ae -> k (`A (List.rev acc)) 190 | | `Lexeme v -> base (fun v -> arr (v :: acc) k) v 191 | and name n k = 192 | match Jsonm.decode decoder with 193 | | #await -> assert false 194 | | #error as v -> error v 195 | | #eoi as v -> end_of_input v 196 | | `Lexeme v -> base (fun v -> k (n, v)) v 197 | and obj acc k = 198 | match Jsonm.decode decoder with 199 | | #await -> assert false 200 | | #error as v -> error v 201 | | #eoi as v -> end_of_input v 202 | | `Lexeme `Oe -> k (`O (List.rev acc)) 203 | | `Lexeme (`Name n) -> name n (fun v -> obj (v :: acc) k) 204 | | `Lexeme v -> Fmt.invalid_arg "Unexpected lexeme: %a" Jsonm.pp_lexeme v 205 | and base k = function 206 | | #value as v -> k v 207 | | `Os -> obj [] k 208 | | `As -> arr [] k 209 | | `Ae | `Oe -> Fmt.invalid_arg "Unexpected end of array/object" 210 | | `Name n -> Fmt.invalid_arg "Unexpected key: %s" n 211 | in 212 | 213 | let go k = 214 | match Jsonm.decode decoder with 215 | | #await -> assert false 216 | | #error as v -> error v 217 | | #eoi as v -> end_of_input v 218 | | `Lexeme (#Jsonm.lexeme as lexeme) -> base k lexeme 219 | in 220 | 221 | go Json_encoding.(destruct (list json)) 222 | 223 | let flat_json json : Jsonm.lexeme list = 224 | let rec arr acc k = function 225 | | [] -> k (List.rev (`Ae :: acc)) 226 | | (#value as x) :: r -> arr (x :: acc) k r 227 | | `A l :: r -> arr [ `As ] (fun l -> arr (List.rev_append l acc) k r) l 228 | | `O l :: r -> obj [ `Os ] (fun l -> arr (List.rev_append l acc) k r) l 229 | and obj acc k = function 230 | | [] -> k (List.rev (`Oe :: acc)) 231 | | (n, x) :: r -> 232 | base (fun v -> obj (List.rev_append v (`Name n :: acc)) k r) x 233 | and base k = function 234 | | `A l -> arr [ `As ] k l 235 | | `O l -> obj [ `Os ] k l 236 | | #value as x -> k [ x ] 237 | in 238 | 239 | base (fun l -> l) json 240 | 241 | external identity : 'a -> 'a = "%identity" 242 | 243 | let show ppf map = 244 | let json = 245 | Json_encoding.( 246 | construct (list json) (List.map snd (Packer.Map.bindings map))) 247 | in 248 | let raw = Bytes.create 0x800 in 249 | let encoder = Jsonm.encoder `Manual in 250 | let rec write k = function 251 | | `Ok -> k () 252 | | `Partial -> 253 | Fmt.string ppf (Bytes.sub_string raw 0 (Jsonm.Manual.dst_rem encoder)); 254 | Jsonm.Manual.dst encoder raw 0 (Bytes.length raw); 255 | write k (Jsonm.encode encoder `Await) 256 | in 257 | let rec go k = function 258 | | [] -> write k (Jsonm.encode encoder `End) 259 | | lexeme :: r -> 260 | write (fun () -> go k r) (Jsonm.encode encoder (`Lexeme lexeme)) 261 | in 262 | let lexemes = flat_json json in 263 | go identity lexemes 264 | 265 | let run database exclude roots = 266 | let graph = of_database (open_in database) in 267 | let () = 268 | List.iteri 269 | (fun id value -> Hashtbl.add Git.store (Nativeint.of_int id) value) 270 | graph 271 | in 272 | match 273 | Lwt_main.run 274 | Lwt.Infix.( 275 | Packer.pack () exclude roots >|= Fmt.fmt "%a\n%!" Fmt.stdout show) 276 | with 277 | | () -> `Ok () 278 | | exception Packer.Graph err -> 279 | `Error (false, Fmt.str "Retrieve an error: %a." Git.pp_error err) 280 | 281 | open Cmdliner 282 | 283 | let database = 284 | let parser s = 285 | if Sys.file_exists s then Ok s 286 | else Rresult.R.error_msgf "File %s does not exists" s 287 | in 288 | let pp = Fmt.string in 289 | Arg.conv (parser, pp) 290 | 291 | let id = 292 | let parser s = 293 | match Nativeint.of_string_opt s with 294 | | Some n -> Ok n 295 | | None -> Rresult.R.error_msgf "Invalid id: %s" s 296 | in 297 | let pp = Fmt.nativeint in 298 | Arg.conv (parser, pp) 299 | 300 | let database = 301 | let doc = "Database of graph." in 302 | Arg.( 303 | required 304 | & opt (some database) None 305 | & info [ "d"; "database" ] ~doc ~docv:"") 306 | 307 | let roots = 308 | let doc = "Roots of graph." in 309 | Arg.(non_empty & opt (list id) [] & info [ "r"; "roots" ] ~doc ~docv:"") 310 | 311 | let exclude = 312 | let doc = "Excluded nodes of graph." in 313 | Arg.( 314 | non_empty & opt (list id) [] & info [ "e"; "exclude" ] ~doc ~docv:"") 315 | 316 | let command = 317 | let doc = "Example of ke." in 318 | let exits = Cmd.Exit.defaults in 319 | Cmd.v 320 | (Cmd.info "packer" ~version:"dev" ~doc ~exits) 321 | Term.(ret (const run $ database $ exclude $ roots)) 322 | 323 | let () = Cmd.(exit @@ eval command) 324 | -------------------------------------------------------------------------------- /fuzz/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name fuzz) 3 | (libraries fmt crowbar bigstringaf ke)) 4 | 5 | (rule 6 | (alias runtest) 7 | (action 8 | (run ./fuzz.exe))) 9 | -------------------------------------------------------------------------------- /fuzz/fuzz.ml: -------------------------------------------------------------------------------- 1 | type 'a action = Push of 'a * 'a action | Pop of 'a action | Empty 2 | 3 | exception Invalid 4 | 5 | external identity : 'a -> 'a = "%identity" 6 | 7 | let valid a = 8 | let rec go k = function 9 | | Empty -> k 0 10 | | Push (_, a) -> go (fun len -> k (succ len)) a 11 | | Pop a -> go (function 0 -> raise Invalid | n -> k (pred n)) a 12 | in 13 | go identity a 14 | 15 | let push x a = Push (x, a) 16 | let empty = Empty 17 | let pop a = Pop a 18 | let () = assert (valid empty = 0) 19 | let () = assert (valid (push 0 empty) = 1) 20 | let () = assert (valid (push 1 (push 0 empty)) = 2) 21 | let () = assert (valid (pop (push 0 empty)) = 0) 22 | 23 | let () = 24 | assert (match valid (pop empty) with _ -> false | exception Invalid -> true) 25 | 26 | module Peano = struct type zero = Zero type 'a succ = Succ end 27 | module Refl = struct type ('a, 'b) t = Refl : ('a, 'a) t end 28 | 29 | module Value = struct 30 | type 'a value = 31 | | Zero : Peano.zero value 32 | | Succ : 'a value -> 'a Peano.succ value 33 | 34 | type t = V : 'a value -> t 35 | 36 | let of_int n = 37 | let rec go k = function 38 | | 0 -> k (V Zero) 39 | | n -> go (fun (V n) -> k (V (Succ n))) (pred n) 40 | in 41 | if n < 0 then invalid_arg "Value.of_int" else go identity n 42 | 43 | let to_int v = 44 | let rec go : type a. (int -> 'r) -> a value -> 'r = 45 | fun k -> function Zero -> k 0 | Succ x -> go (fun v -> k (succ v)) x 46 | in 47 | go identity v 48 | 49 | let () = assert (to_int Zero = 0) 50 | let () = assert (to_int (Succ Zero) = 1) 51 | let () = assert (to_int (Succ (Succ Zero)) = 2) 52 | let pp : t Fmt.t = fun ppf (V v) -> Fmt.int ppf (to_int v) 53 | 54 | let is_zero : type a. a value -> (a, Peano.zero) Refl.t option = function 55 | | Zero -> Some Refl.Refl 56 | | Succ _ -> None 57 | 58 | type 'a is_not_zero = 59 | | Is_not_zero : ('a, _ Peano.succ) Refl.t -> 'a is_not_zero 60 | 61 | let is_not_zero : type a. a value -> a is_not_zero option = function 62 | | Zero -> None 63 | | Succ _ -> Some (Is_not_zero Refl.Refl) 64 | end 65 | 66 | module Stack = struct 67 | type ('a, 'l) action = 68 | | Push : 'a * ('a, 'l) action -> ('a, 'l Peano.succ) action 69 | | Pop : ('a, 'l Peano.succ) action -> ('a, 'l) action 70 | | Empty : ('a, Peano.zero) action 71 | 72 | type 'a t = V : ('a, 'l) action -> 'a t 73 | 74 | let rec pp : type l. 'a Fmt.t -> ('a, l) action Fmt.t = 75 | fun pp_elt ppf -> function 76 | | Push (v, a) -> 77 | Fmt.pf ppf "@[<1>(Push %a)]" Fmt.(Dump.pair pp_elt (pp pp_elt)) (v, a) 78 | | Pop a -> Fmt.pf ppf "@[<1>(Pop %a)]" (pp pp_elt) a 79 | | Empty -> Fmt.pf ppf "Empty" 80 | 81 | let rec length : type a l. (a, l) action -> l Value.value = function 82 | | Empty -> Value.Zero 83 | | Pop a -> ( match length a with Value.Succ x -> x) 84 | | Push (_, a) -> Value.Succ (length a) 85 | 86 | let is_empty : type l. ('a, l) action -> (l, Peano.zero) Refl.t option = 87 | function 88 | | Empty -> Some Refl.Refl 89 | | Push _ -> None 90 | | Pop a -> ( 91 | match length a with 92 | | Value.Succ Value.Zero -> Some Refl.Refl 93 | | Value.Succ _ -> None) 94 | 95 | type 'a is_not_empty = 96 | | Is_not_empty : ('a, _ Peano.succ) Refl.t -> 'a is_not_empty 97 | 98 | let is_not_empty : type l. ('a, l) action -> l is_not_empty option = function 99 | | Empty -> None 100 | | Push _ -> Some (Is_not_empty Refl.Refl) 101 | | Pop a -> ( 102 | match length a with 103 | | Value.Succ Value.Zero -> None 104 | | Value.Succ (Value.Succ _) -> Some (Is_not_empty Refl.Refl)) 105 | end 106 | 107 | open Crowbar 108 | 109 | type tree = Tree of Value.t * tree list * bool 110 | 111 | let rec list_of_tree (Tree (v, x, pop)) : [ `Push of Value.t | `Pop ] list = 112 | if pop then [ `Push v ] @ List.concat (List.map list_of_tree x) @ [ `Pop ] 113 | else [ `Push v ] @ List.concat (List.map list_of_tree x) 114 | 115 | let generate : tree gen = 116 | let value = map [ range 30 ] Value.of_int in 117 | fix @@ fun m -> map [ value; list m; bool ] (fun v l pop -> Tree (v, l, pop)) 118 | 119 | let action_of_tree tree : Value.t Stack.t = 120 | let lst = list_of_tree tree in 121 | List.fold_left 122 | (fun (Stack.V acc) -> function 123 | | `Push v -> Stack.(V (Push (v, acc))) 124 | | `Pop -> ( 125 | match Stack.is_not_empty acc with 126 | | Some (Stack.Is_not_empty Refl.Refl) -> Stack.V (Stack.Pop acc) 127 | | None -> bad_test ())) 128 | Stack.(V Empty) 129 | lst 130 | 131 | (* XXX(dinosaure): [Stdlib.Queue] is the oracle. *) 132 | 133 | module Compare = struct 134 | exception Not_equal 135 | 136 | let fke q fke = 137 | let q' = Queue.copy q in 138 | try 139 | Ke.Fke.iter 140 | (fun x -> 141 | let x' = Queue.pop q' in 142 | if x <> x' then raise Not_equal) 143 | fke; 144 | true 145 | with Not_equal | Queue.Empty -> false 146 | 147 | let rke q rke = 148 | let q' = Queue.copy q in 149 | try 150 | Ke.Rke.iter 151 | (fun x -> 152 | let x' = Queue.pop q' in 153 | if x <> x' then raise Not_equal) 154 | rke; 155 | true 156 | with Not_equal | Queue.Empty -> false 157 | end 158 | 159 | let iter iter pp_name pp_elt ppf v = 160 | let is_first = ref true in 161 | let pp_elt v = 162 | if !is_first then is_first := false else Fmt.pf ppf "@ "; 163 | Fmt.pf ppf "@[%a@]" pp_elt v 164 | in 165 | Fmt.pf ppf "@[<1>(%a@ " pp_name v; 166 | iter pp_elt v; 167 | Fmt.pf ppf ")@]" 168 | 169 | let pp_fke pp_elt = iter Ke.Fke.iter (Fmt.any "fke") pp_elt 170 | let pp_rke pp_elt = iter Ke.Rke.iter (Fmt.any "rke") pp_elt 171 | 172 | let rke_of_action a = 173 | let q = 174 | Ke.Rke.create ~capacity:(Value.to_int (Stack.length a)) Bigarray.Int 175 | in 176 | let rec go : type l. (Value.t, l) Stack.action -> unit = function 177 | | Stack.Empty -> () 178 | | Stack.Push (Value.V v, a) -> 179 | go a; 180 | Ke.Rke.push q (Value.to_int v) 181 | | Stack.Pop a -> 182 | go a; 183 | ignore @@ Ke.Rke.pop_exn q 184 | in 185 | go a; 186 | q 187 | 188 | let queue_of_action a = 189 | let q = Queue.create () in 190 | let rec go : type l. (Value.t, l) Stack.action -> unit = function 191 | | Stack.Empty -> () 192 | | Stack.Push (Value.V v, a) -> 193 | go a; 194 | Queue.push (Value.to_int v) q 195 | | Stack.Pop a -> 196 | go a; 197 | ignore @@ Queue.pop q 198 | in 199 | go a; 200 | q 201 | 202 | let fke_of_action a = 203 | let rec go : type l. (int Ke.Fke.t -> 'r) -> (Value.t, l) Stack.action -> 'r = 204 | fun k -> function 205 | | Stack.Empty -> k Ke.Fke.empty 206 | | Stack.Push (Value.V v, a) -> 207 | go 208 | (fun q -> 209 | let q = Ke.Fke.push q (Value.to_int v) in 210 | k q) 211 | a 212 | | Stack.Pop a -> 213 | go 214 | (fun q -> 215 | let _, q = Ke.Fke.pop_exn q in 216 | k q) 217 | a 218 | in 219 | go identity a 220 | 221 | let () = 222 | add_test ~name:"queue" [ map [ generate ] action_of_tree ] 223 | @@ fun (Stack.V a) -> 224 | let fke = fke_of_action a in 225 | let rke = rke_of_action a in 226 | let queue = queue_of_action a in 227 | if not (Compare.fke queue fke) then 228 | failf "%a <> %a" Fmt.(Dump.queue int) queue (pp_fke Fmt.int) fke; 229 | if not (Compare.rke queue rke) then 230 | failf "%a <> %a" Fmt.(Dump.queue int) queue (pp_rke Fmt.int) rke; 231 | () 232 | -------------------------------------------------------------------------------- /ke.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "ke" 3 | maintainer: "Romain Calascibetta " 4 | authors: "Romain Calascibetta " 5 | homepage: "https://github.com/mirage/ke" 6 | bug-reports: "https://github.com/mirage/ke/issues" 7 | dev-repo: "git+https://github.com/mirage/ke.git" 8 | doc: "https://mirage.github.io/ke/" 9 | license: "MIT" 10 | synopsis: "Queue implementation" 11 | description: """Queue implementation in OCaml (functional and imperative queue)""" 12 | 13 | build: [ "dune" "build" "-p" name "-j" jobs ] 14 | run-test: [ "dune" "runtest" "-p" name "-j" jobs ] 15 | 16 | depends: [ 17 | "ocaml" {>= "4.08.0"} 18 | "dune" {>= "2.0"} 19 | "alcotest" {>= "1.7.0" & with-test} 20 | "bigstringaf" {>= "0.9.0" & with-test} 21 | "bechamel" {with-test} 22 | "bechamel-js" {with-test} 23 | "json-data-encoding" {with-test} 24 | "lwt" {with-test} 25 | "crowbar" {with-test} 26 | "rresult" {>= "0.7.0" & with-test} 27 | "jsonm" {with-test} 28 | "psq" {with-test} 29 | "fmt" {>= "0.8.7" & with-test} 30 | "cmdliner" {>= "1.1.0" & with-test} 31 | ] 32 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ke) 3 | (public_name ke)) 4 | -------------------------------------------------------------------------------- /lib/fke.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-37"] 2 | 3 | module Peano = struct 4 | type zero = Zero 5 | type 'a succ = Succ 6 | type one = zero succ 7 | type two = zero succ succ 8 | type three = zero succ succ 9 | end 10 | 11 | type ('a, 'l) digit = 12 | | Zero : ('a, Peano.zero) digit 13 | | One : 'a -> ('a, Peano.one) digit 14 | | Two : 'a * 'a -> ('a, Peano.two) digit 15 | | Three : 'a * 'a * 'a -> ('a, Peano.three) digit 16 | 17 | type 'a t = 18 | | Shallow : ('a, 'l) digit -> 'a t 19 | | Deep : { 20 | s : int; 21 | f : ('a, 'f Peano.succ) digit; 22 | m : ('a * 'a) t Lazy.t; 23 | r : ('a, 'r Peano.succ) digit; 24 | } 25 | -> 'a t 26 | 27 | let empty = Shallow Zero 28 | 29 | exception Empty 30 | 31 | let _one x = Shallow (One x) 32 | let _two x y = Shallow (Two (x, y)) 33 | let _three x y z = Shallow (Three (x, y, z)) 34 | let _deep s f m r = Deep { s; f; m; r } 35 | 36 | let is_empty : type a. a t -> bool = function 37 | | Shallow Zero -> true 38 | | Shallow _ | Deep _ -> false 39 | 40 | let rec push : type a. a t -> a -> a t = 41 | fun q x -> 42 | match q with 43 | | Shallow Zero -> _one x 44 | | Shallow (One y) -> _two y x 45 | | Shallow (Two (y, z)) -> _three y z x 46 | | Shallow (Three (a, b, c)) -> 47 | _deep 4 (Two (a, b)) (Lazy.from_val empty) (Two (c, x)) 48 | | Deep { s; f; m; r = One y } -> _deep (s + 1) f m (Two (y, x)) 49 | | Deep { s; f; m; r = Two (y, z) } -> _deep (s + 1) f m (Three (y, z, x)) 50 | | Deep { s; f; m = (lazy q'); r = Three (y, z, z') } -> 51 | _deep (s + 1) f (lazy (push q' (y, z))) (Two (z', x)) 52 | 53 | let rec pop_exn : type a. a t -> a * a t = 54 | fun q -> 55 | match q with 56 | | Shallow Zero -> raise Empty 57 | | Shallow (One x) -> (x, empty) 58 | | Shallow (Two (x, y)) -> (x, _one y) 59 | | Shallow (Three (x, y, z)) -> (x, _two y z) 60 | | Deep { s; f = One x; m = (lazy q'); r } -> 61 | if is_empty q' then (x, Shallow r) 62 | else 63 | let (y, z), q' = pop_exn q' in 64 | (x, _deep (s - 1) (Two (y, z)) (Lazy.from_val q') r) 65 | | Deep { s; f = Two (x, y); m; r } -> (x, _deep (s - 1) (One y) m r) 66 | | Deep { s; f = Three (x, y, z); m; r } -> (x, _deep (s - 1) (Two (y, z)) m r) 67 | 68 | let rec tail_exn : type a. a t -> a t * a = 69 | fun q -> 70 | match q with 71 | | Shallow Zero -> raise Empty 72 | | Shallow (One x) -> (empty, x) 73 | | Shallow (Two (x, y)) -> (_one x, y) 74 | | Shallow (Three (x, y, z)) -> (_two x y, z) 75 | | Deep { s; f; m = (lazy q'); r = One x } -> 76 | if is_empty q' then (Shallow f, x) 77 | else 78 | let q'', (y, z) = tail_exn q' in 79 | (_deep (s - 1) f (Lazy.from_val q'') (Two (y, z)), x) 80 | | Deep { s; f; m; r = Two (x, y) } -> (_deep (s - 1) f m (One x), y) 81 | | Deep { s; f; m; r = Three (x, y, z) } -> (_deep (s - 1) f m (Two (x, y)), z) 82 | 83 | let peek_exn : type a. a t -> a = 84 | fun q -> 85 | match q with 86 | | Shallow Zero -> raise Empty 87 | | Shallow (One x) -> x 88 | | Shallow (Two (x, _)) -> x 89 | | Shallow (Three (x, _, _)) -> x 90 | | Deep { f = One x; _ } -> x 91 | | Deep { f = Two (x, _); _ } -> x 92 | | Deep { f = Three (x, _, _); _ } -> x 93 | 94 | let pop q = try Some (pop_exn q) with Empty -> None 95 | let tail q = try Some (tail_exn q) with Empty -> None 96 | let peek q = try Some (peek_exn q) with Empty -> None 97 | 98 | let rec cons : type a. a t -> a -> a t = 99 | fun q x -> 100 | match q with 101 | | Shallow Zero -> _one x 102 | | Shallow (One y) -> _two x y 103 | | Shallow (Two (y, z)) -> _three x y z 104 | | Shallow (Three (y, z, z')) -> 105 | _deep 4 (Two (x, y)) (Lazy.from_val empty) (Two (z, z')) 106 | | Deep { s; f = One y; m; r } -> _deep (s + 1) (Two (x, y)) m r 107 | | Deep { s; f = Two (y, z); m; r } -> _deep (s + 1) (Three (x, y, z)) m r 108 | | Deep { s; f = Three (y, z, z'); m = (lazy q'); r } -> 109 | _deep (s + 1) (Three (x, y, z)) (lazy (cons q' (z, z'))) r 110 | 111 | let iter : type a. (a -> unit) -> a t -> unit = 112 | fun f q -> 113 | let rec go : type a. (a -> unit) -> a t -> unit = 114 | fun f -> function 115 | | Shallow Zero -> () 116 | | Shallow (One x) -> f x 117 | | Shallow (Two (x, y)) -> 118 | f x; 119 | f y 120 | | Shallow (Three (x, y, z)) -> 121 | f x; 122 | f y; 123 | f z 124 | | Deep { f = hd; m = (lazy q); r = tl; _ } -> 125 | go f (Shallow hd); 126 | go 127 | (fun (x, y) -> 128 | f x; 129 | f y) 130 | q; 131 | go f (Shallow tl) 132 | in 133 | go f q 134 | 135 | let rev_iter : type a. (a -> unit) -> a t -> unit = 136 | fun f q -> 137 | let rec go : type a. (a -> unit) -> a t -> unit = 138 | fun f -> function 139 | | Shallow Zero -> () 140 | | Shallow (One x) -> f x 141 | | Shallow (Two (y, x)) -> 142 | f x; 143 | f y 144 | | Shallow (Three (z, y, x)) -> 145 | f x; 146 | f y; 147 | f z 148 | | Deep { f = hd; m = (lazy q); r = tl; _ } -> 149 | go f (Shallow tl); 150 | go 151 | (fun (y, x) -> 152 | f x; 153 | f y) 154 | q; 155 | go f (Shallow hd) 156 | in 157 | go f q 158 | 159 | let fold : type acc x. (acc -> x -> acc) -> acc -> x t -> acc = 160 | fun f a q -> 161 | let rec go : type acc x. (acc -> x -> acc) -> acc -> x t -> acc = 162 | fun f a -> function 163 | | Shallow Zero -> a 164 | | Shallow (One x) -> f a x 165 | | Shallow (Two (x, y)) -> f (f a x) y 166 | | Shallow (Three (x, y, z)) -> f (f (f a x) y) z 167 | | Deep { f = hd; m = (lazy q); r = tl; _ } -> 168 | let a = go f a (Shallow hd) in 169 | let a = go (fun a (x, y) -> f (f a x) y) a q in 170 | go f a (Shallow tl) 171 | in 172 | go f a q 173 | 174 | let length = function 175 | | Deep { s; _ } -> s 176 | | Shallow Zero -> 0 177 | | Shallow (One _) -> 1 178 | | Shallow (Two _) -> 2 179 | | Shallow (Three _) -> 3 180 | 181 | let pp ?sep pp_elt = Minifmt.iter ?sep iter pp_elt 182 | let dump pp_elt = Minifmt.iter_dump iter (Minifmt.any "fke") pp_elt 183 | 184 | module Weighted = struct 185 | type ('a, 'b) t = { 186 | r : int; 187 | w : int; 188 | c : int; 189 | k : ('a, 'b) Bigarray.kind; 190 | v : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; 191 | } 192 | 193 | exception Empty 194 | exception Full 195 | 196 | let[@inline always] mask t v = v land (t.c - 1) 197 | let[@inline always] empty t = t.r = t.w 198 | let[@inline always] size t = t.w - t.r 199 | let[@inline always] full t = size t = t.c 200 | let[@inline always] available t = t.c - (t.w - t.r) 201 | let is_empty t = (empty [@inlined]) t 202 | let length q = size q 203 | 204 | let[@inline always] to_power_of_two v = 205 | let res = ref (pred v) in 206 | res := !res lor (!res lsr 1); 207 | res := !res lor (!res lsr 2); 208 | res := !res lor (!res lsr 4); 209 | res := !res lor (!res lsr 8); 210 | res := !res lor (!res lsr 16); 211 | succ !res 212 | 213 | let[@inline always] is_power_of_two v = v <> 0 && v land (lnot v + 1) = v 214 | 215 | let create ?capacity kind = 216 | let capacity = 217 | match capacity with 218 | | None | Some 0 -> 1 219 | | Some n -> 220 | if n < 0 then invalid_arg "Rke.Weighted.create" else to_power_of_two n 221 | in 222 | ( { 223 | r = 0; 224 | w = 0; 225 | c = capacity; 226 | k = kind; 227 | v = Bigarray.Array1.create kind Bigarray.c_layout capacity; 228 | }, 229 | capacity ) 230 | 231 | let copy t = 232 | let v = Bigarray.Array1.create t.k Bigarray.c_layout t.c in 233 | Bigarray.Array1.blit t.v v; 234 | { r = t.r; w = t.w; c = t.c; v; k = t.k } 235 | 236 | let from v = 237 | if not (is_power_of_two (Bigarray.Array1.dim v)) then invalid_arg "RBA.from"; 238 | let c = Bigarray.Array1.dim v in 239 | let k = Bigarray.Array1.kind v in 240 | { r = 0; w = 0; c; k; v } 241 | 242 | let push_exn t v = 243 | if (full [@inlined]) t then raise Full; 244 | Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t t.w) v; 245 | { t with w = t.w + 1 } 246 | 247 | let push t v = try Some (push_exn t v) with Full -> None 248 | 249 | let cons_exn t v = 250 | if (full [@inlined]) t then raise Full; 251 | let i = t.r - 1 in 252 | Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t i) v; 253 | { t with r = i } 254 | 255 | let cons t v = try Some (cons_exn t v) with Full -> None 256 | 257 | let pop_exn t = 258 | if (empty [@inlined]) t then raise Empty; 259 | let r = Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) in 260 | (r, { t with r = t.r + 1 }) 261 | 262 | let pop t = try Some (pop_exn t) with Empty -> None 263 | 264 | let peek_exn t = 265 | if (empty [@inlined]) t then raise Empty; 266 | Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) 267 | 268 | let peek t = try Some (peek_exn t) with Empty -> None 269 | 270 | module N = struct 271 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 272 | type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit 273 | type 'a length = 'a -> int 274 | 275 | let push_exn t ~blit ~length ?(off = 0) ?len v = 276 | let len = match len with None -> length v - off | Some len -> len in 277 | if (available [@inlined]) t < len then raise Full; 278 | let msk = (mask [@inlined]) t t.w in 279 | let pre = t.c - msk in 280 | let rst = len - pre in 281 | let ret = 282 | if rst > 0 then ( 283 | blit v off t.v msk pre; 284 | blit v (off + pre) t.v 0 rst; 285 | [ 286 | Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) pre; 287 | Bigarray.Array1.sub t.v 0 rst; 288 | ]) 289 | else ( 290 | blit v off t.v msk len; 291 | [ Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) len ]) 292 | in 293 | (ret, { t with w = t.w + len }) 294 | 295 | let push t ~blit ~length ?off ?len v = 296 | try Some (push_exn t ~blit ~length ?off ?len v) with Full -> None 297 | 298 | let keep_exn t ~blit ~length ?(off = 0) ?len v = 299 | let len = match len with None -> length v | Some len -> len in 300 | if (size [@inlined]) t < len then raise Empty; 301 | let msk = (mask [@inlined]) t t.r in 302 | let pre = t.c - msk in 303 | let rst = len - pre in 304 | if rst > 0 then ( 305 | blit t.v msk v off pre; 306 | blit t.v 0 v (off + pre) rst) 307 | else blit t.v msk v off len 308 | 309 | let keep t ~blit ~length ?off ?len v = 310 | try Some (keep_exn t ~blit ~length ?off ?len v) with Empty -> None 311 | 312 | let unsafe_shift t len = { t with r = t.r + len } 313 | 314 | let shift_exn t len = 315 | if (size [@inlined]) t < len then raise Empty; 316 | unsafe_shift t len 317 | 318 | let shift t len = try Some (shift_exn t len) with Empty -> None 319 | end 320 | 321 | let iter f t = 322 | let idx = ref t.r in 323 | let max = t.w in 324 | while !idx <> max do 325 | f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx)); 326 | incr idx 327 | done 328 | 329 | let rev_iter f t = 330 | if t.r == t.w then () 331 | else 332 | let idx = ref (pred t.w) in 333 | let min = t.r in 334 | while 335 | f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx)); 336 | !idx <> min 337 | do 338 | decr idx 339 | done 340 | 341 | let fold f a t = 342 | let a = ref a in 343 | iter (fun x -> a := f !a x) t; 344 | !a 345 | 346 | let clear t = { t with r = 0; w = 0 } 347 | let unsafe_bigarray { v; _ } = v 348 | let pp ?sep pp_elt = Minifmt.iter ?sep iter pp_elt 349 | let dump pp_elt = Minifmt.iter_dump iter (Minifmt.any "fke:weighted") pp_elt 350 | end 351 | -------------------------------------------------------------------------------- /lib/fke.mli: -------------------------------------------------------------------------------- 1 | include Sigs.F 2 | module Weighted : Sigs.Weighted.F 3 | -------------------------------------------------------------------------------- /lib/ke.ml: -------------------------------------------------------------------------------- 1 | module Sigs = Sigs 2 | module Fke = Fke 3 | module Rke = Rke 4 | -------------------------------------------------------------------------------- /lib/ke.mli: -------------------------------------------------------------------------------- 1 | module Sigs = Sigs 2 | module Fke = Fke 3 | module Rke = Rke 4 | -------------------------------------------------------------------------------- /lib/minifmt.ml: -------------------------------------------------------------------------------- 1 | let cut ppf _ = Format.pp_print_cut ppf () 2 | let sp ppf _ = Format.pp_print_space ppf () 3 | let any fmt ppf _ = Format.fprintf ppf fmt 4 | 5 | let box ?(indent = 0) pp_v ppf v = 6 | Format.( 7 | pp_open_box ppf indent; 8 | pp_v ppf v; 9 | pp_close_box ppf ()) 10 | 11 | let iter ?sep:(pp_sep = cut) iter pp_elt ppf v = 12 | let is_first = ref true in 13 | let pp_elt v = 14 | if !is_first then ( 15 | is_first := false; 16 | pp_sep ppf ()); 17 | pp_elt ppf v 18 | in 19 | iter pp_elt v 20 | 21 | let surround s1 s2 pp_v ppf v = 22 | Format.( 23 | pp_print_string ppf s1; 24 | pp_v ppf v; 25 | pp_print_string ppf s2) 26 | 27 | let parens pp_v = box ~indent:1 (surround "(" ")" pp_v) 28 | 29 | let ( ++ ) pp_v0 pp_v1 ppf v = 30 | pp_v0 ppf v; 31 | pp_v1 ppf v 32 | 33 | let iter_dump iter' pp_name pp_elt = 34 | let pp_v = iter ~sep:sp iter' (box pp_elt) in 35 | parens (pp_name ++ sp ++ pp_v) 36 | -------------------------------------------------------------------------------- /lib/rke.ml: -------------------------------------------------------------------------------- 1 | type ('a, 'b) t = { 2 | mutable r : int; 3 | mutable w : int; 4 | mutable c : int; 5 | k : ('a, 'b) Bigarray.kind; 6 | mutable v : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; 7 | } 8 | 9 | exception Empty 10 | 11 | external ( = ) : 'a -> 'a -> bool = "%equal" 12 | 13 | let ( = ) (a : int) b = a = b 14 | let[@inline always] mask t v = v land (t.c - 1) 15 | let[@inline always] empty t = t.r = t.w 16 | let[@inline always] size t = t.w - t.r 17 | let[@inline always] available t = t.c - (t.w - t.r) 18 | let[@inline always] full t = size t = t.c 19 | let length q = size q 20 | 21 | let[@inline always] to_power_of_two v = 22 | let res = ref (pred v) in 23 | res := !res lor (!res lsr 1); 24 | res := !res lor (!res lsr 2); 25 | res := !res lor (!res lsr 4); 26 | res := !res lor (!res lsr 8); 27 | res := !res lor (!res lsr 16); 28 | succ !res 29 | 30 | let[@inline always] is_power_of_two v = v <> 0 && v land (lnot v + 1) = v 31 | let is_empty t = (empty [@inlined]) t 32 | 33 | let create ?capacity kind = 34 | let capacity = 35 | match capacity with 36 | | None | Some 0 -> 1 37 | | Some n -> if n < 0 then invalid_arg "Rke.create" else to_power_of_two n 38 | in 39 | { 40 | r = 0; 41 | w = 0; 42 | c = capacity; 43 | k = kind; 44 | v = Bigarray.Array1.create kind Bigarray.c_layout capacity; 45 | } 46 | 47 | let capacity { c; _ } = c 48 | 49 | let copy t = 50 | let v = Bigarray.Array1.create t.k Bigarray.c_layout t.c in 51 | Bigarray.Array1.blit t.v v; 52 | { r = t.r; w = t.w; c = t.c; v; k = t.k } 53 | 54 | let grow t want = 55 | let max : int -> int -> int = max in 56 | let c = to_power_of_two (max 1 (max want (size t))) in 57 | if c <> Bigarray.Array1.dim t.v then ( 58 | let dst = Bigarray.Array1.create t.k Bigarray.c_layout c in 59 | let sze = (size [@inlined]) t in 60 | let msk = (mask [@inlined]) t t.r in 61 | let pre = t.c - msk in 62 | let rst = sze - pre in 63 | (if rst > 0 then ( 64 | Bigarray.Array1.(blit (sub t.v msk pre) (sub dst 0 pre)); 65 | Bigarray.Array1.(blit (sub t.v 0 rst) (sub dst pre rst))) 66 | else Bigarray.Array1.(blit (sub t.v msk sze) (sub dst 0 sze))); 67 | t.v <- dst; 68 | t.w <- sze; 69 | t.c <- c; 70 | t.r <- 0) 71 | 72 | let push t v = 73 | if (full [@inlined]) t then grow t (2 * (size [@inlined]) t); 74 | Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t t.w) v; 75 | t.w <- t.w + 1 76 | 77 | let cons t v = 78 | if (full [@inlined]) t then grow t (2 * (size [@inlined]) t); 79 | let i = t.r - 1 in 80 | Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t i) v; 81 | t.r <- i 82 | 83 | let pop_exn t = 84 | if (empty [@inlined]) t then raise Empty; 85 | let r = Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) in 86 | t.r <- t.r + 1; 87 | r 88 | 89 | let pop t = try Some (pop_exn t) with Empty -> None 90 | 91 | let peek_exn t = 92 | if (empty [@inlined]) t then raise Empty; 93 | Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) 94 | 95 | let peek t = try Some (peek_exn t) with Empty -> None 96 | 97 | let blit src src_off dst dst_off len = 98 | let a = Bigarray.Array1.sub src src_off len in 99 | let b = Bigarray.Array1.sub dst dst_off len in 100 | Bigarray.Array1.blit a b 101 | 102 | let compress t = 103 | let len = length t in 104 | let msk = (mask [@inlined]) t t.r in 105 | let pre = t.c - msk in 106 | let rst = len - pre in 107 | if rst > 0 then ( 108 | if (available [@inlined]) t >= pre then ( 109 | (* XXX(dinosaure): in this case, [pre + rst <= msk], so [blit] will not 110 | overlap bytes at the end of [t.v] (at offset [msk]). *) 111 | blit t.v 0 t.v pre rst; 112 | blit t.v msk t.v 0 pre) 113 | else 114 | let tmp = Bigarray.Array1.create t.k Bigarray.c_layout pre in 115 | blit t.v msk tmp 0 pre; 116 | blit t.v 0 t.v pre rst; 117 | blit tmp 0 t.v 0 pre) 118 | else blit t.v msk t.v 0 len; 119 | t.r <- 0; 120 | t.w <- len 121 | 122 | module N = struct 123 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 124 | type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit 125 | type 'a length = 'a -> int 126 | 127 | let push t ~blit ~length ?(off = 0) ?len v = 128 | let len = match len with None -> length v - off | Some len -> len in 129 | if (available [@inlined]) t < len then grow t (len + (size [@inlined]) t); 130 | let msk = (mask [@inlined]) t t.w in 131 | let pre = t.c - msk in 132 | let rst = len - pre in 133 | if rst > 0 then ( 134 | blit v off t.v msk pre; 135 | blit v (off + pre) t.v 0 rst) 136 | else blit v off t.v msk len; 137 | t.w <- t.w + len 138 | 139 | let keep_exn t ~blit ~length ?(off = 0) ?len v = 140 | let len = match len with None -> length v - off | Some len -> len in 141 | if (size [@inlined]) t < len then raise Empty; 142 | let msk = (mask [@inlined]) t t.r in 143 | let pre = t.c - msk in 144 | let rst = len - pre in 145 | if rst > 0 then ( 146 | blit t.v msk v off pre; 147 | blit t.v 0 v (off + pre) rst) 148 | else blit t.v msk v off len 149 | 150 | let keep t ~blit ~length ?off ?len v = 151 | try Some (keep_exn t ~blit ~length ?off ?len v) with Empty -> None 152 | 153 | let peek t = 154 | let len = (size [@inlined]) t in 155 | if len == 0 then [] 156 | else 157 | let msk = (mask [@inlined]) t t.r in 158 | let pre = t.c - msk in 159 | let rst = len - pre in 160 | if rst > 0 then 161 | [ Bigarray.Array1.sub t.v msk pre; Bigarray.Array1.sub t.v 0 rst ] 162 | else [ Bigarray.Array1.sub t.v msk len ] 163 | 164 | let unsafe_shift t len = t.r <- t.r + len 165 | 166 | let shift_exn t len = 167 | if (size [@inlined]) t < len then raise Empty; 168 | unsafe_shift t len 169 | 170 | let shift t len = try Some (shift_exn t len) with Empty -> None 171 | end 172 | 173 | let iter f t = 174 | let idx = ref t.r in 175 | let max = t.w in 176 | while !idx <> max do 177 | f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx)); 178 | incr idx 179 | done 180 | 181 | let rev_iter f t = 182 | if t.r == t.w then () 183 | else 184 | let idx = ref (pred t.w) in 185 | let min = t.r in 186 | while 187 | f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx)); 188 | !idx <> min 189 | do 190 | decr idx 191 | done 192 | 193 | let fold f a t = 194 | let a = ref a in 195 | iter (fun x -> a := f !a x) t; 196 | !a 197 | 198 | let pp ?sep pp_elt = Minifmt.iter ?sep iter pp_elt 199 | let dump pp_elt = Minifmt.iter_dump iter (Minifmt.any "rke") pp_elt 200 | 201 | let clear q = 202 | q.r <- 0; 203 | q.w <- 0 204 | 205 | module Weighted = struct 206 | type ('a, 'b) t = { 207 | mutable r : int; 208 | mutable w : int; 209 | c : int; 210 | k : ('a, 'b) Bigarray.kind; 211 | v : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; 212 | } 213 | 214 | exception Empty 215 | exception Full 216 | 217 | let[@inline always] mask t v = v land (t.c - 1) 218 | let[@inline always] empty t = t.r = t.w 219 | let[@inline always] size t = t.w - t.r 220 | let[@inline always] full t = size t = t.c 221 | let[@inline always] available t = t.c - (t.w - t.r) 222 | let is_empty t = (empty [@inlined]) t 223 | let length q = size q 224 | 225 | let create ?capacity kind = 226 | let capacity = 227 | match capacity with 228 | | None | Some 0 -> 1 229 | | Some n -> 230 | if n < 0 then invalid_arg "Rke.Weighted.create" else to_power_of_two n 231 | in 232 | ( { 233 | r = 0; 234 | w = 0; 235 | c = capacity; 236 | k = kind; 237 | v = Bigarray.Array1.create kind Bigarray.c_layout capacity; 238 | }, 239 | capacity ) 240 | 241 | let copy t = 242 | let v = Bigarray.Array1.create t.k Bigarray.c_layout t.c in 243 | Bigarray.Array1.blit t.v v; 244 | { r = t.r; w = t.w; c = t.c; v; k = t.k } 245 | 246 | let from v = 247 | if not (is_power_of_two (Bigarray.Array1.dim v)) then invalid_arg "RBA.from"; 248 | let c = Bigarray.Array1.dim v in 249 | let k = Bigarray.Array1.kind v in 250 | { r = 0; w = 0; c; k; v } 251 | 252 | let push_exn t v = 253 | if (full [@inlined]) t then raise Full; 254 | Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t t.w) v; 255 | t.w <- t.w + 1 256 | 257 | let push t v = try Some (push_exn t v) with Full -> None 258 | 259 | let cons_exn t v = 260 | if (full [@inlined]) t then raise Full; 261 | let i = t.r - 1 in 262 | Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t i) v; 263 | t.r <- i 264 | 265 | let cons t v = try Some (cons_exn t v) with Full -> None 266 | 267 | let pop_exn t = 268 | if (empty [@inlined]) t then raise Empty; 269 | let r = Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) in 270 | t.r <- t.r + 1; 271 | r 272 | 273 | let pop t = try Some (pop_exn t) with Empty -> None 274 | 275 | let peek_exn t = 276 | if (empty [@inlined]) t then raise Empty; 277 | Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) 278 | 279 | let peek t = try Some (peek_exn t) with Empty -> None 280 | 281 | let compress t = 282 | let len = length t in 283 | let msk = (mask [@inlined]) t t.r in 284 | let pre = t.c - msk in 285 | let rst = len - pre in 286 | if rst > 0 then ( 287 | if (available [@inlined]) t >= pre then ( 288 | (* XXX(dinosaure): in this case, [pre + rst <= msk], so [blit] will not 289 | overlap bytes at the end of [t.v] (at offset [msk]). *) 290 | blit t.v 0 t.v pre rst; 291 | blit t.v msk t.v 0 pre) 292 | else 293 | let tmp = Bigarray.Array1.create t.k Bigarray.c_layout pre in 294 | blit t.v msk tmp 0 pre; 295 | blit t.v 0 t.v pre rst; 296 | blit tmp 0 t.v 0 pre) 297 | else blit t.v msk t.v 0 len; 298 | t.r <- 0; 299 | t.w <- len 300 | 301 | module N = struct 302 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 303 | type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit 304 | type 'a length = 'a -> int 305 | 306 | let push_exn t ~blit ~length ?(off = 0) ?len v = 307 | let len = match len with None -> length v - off | Some len -> len in 308 | if (available [@inlined]) t < len then raise Full; 309 | let msk = (mask [@inlined]) t t.w in 310 | let pre = t.c - msk in 311 | let rst = len - pre in 312 | let ret = 313 | if rst > 0 then ( 314 | blit v off t.v msk pre; 315 | blit v (off + pre) t.v 0 rst; 316 | [ 317 | Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) pre; 318 | Bigarray.Array1.sub t.v 0 rst; 319 | ]) 320 | else ( 321 | blit v off t.v msk len; 322 | [ Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) len ]) 323 | in 324 | t.w <- t.w + len; 325 | ret 326 | 327 | let push t ~blit ~length ?off ?len v = 328 | try Some (push_exn t ~blit ~length ?off ?len v) with Full -> None 329 | 330 | let keep_exn t ~blit ~length ?(off = 0) ?len v = 331 | let len = match len with None -> length v - off | Some len -> len in 332 | if (size [@inlined]) t < len then raise Empty; 333 | let msk = (mask [@inlined]) t t.r in 334 | let pre = t.c - msk in 335 | let rst = len - pre in 336 | if rst > 0 then ( 337 | blit t.v msk v off pre; 338 | blit t.v 0 v (off + pre) rst) 339 | else blit t.v msk v off len 340 | 341 | let keep t ~blit ~length ?off ?len v = 342 | try Some (keep_exn t ~blit ~length ?off ?len v) with Empty -> None 343 | 344 | let peek t = 345 | let len = (size [@inlined]) t in 346 | if len == 0 then [] 347 | else 348 | let msk = (mask [@inlined]) t t.r in 349 | let pre = t.c - msk in 350 | let rst = len - pre in 351 | if rst > 0 then 352 | [ Bigarray.Array1.sub t.v msk pre; Bigarray.Array1.sub t.v 0 rst ] 353 | else [ Bigarray.Array1.sub t.v msk len ] 354 | 355 | let unsafe_shift t len = t.r <- t.r + len 356 | 357 | let shift_exn t len = 358 | if (size [@inlined]) t < len then raise Empty; 359 | unsafe_shift t len 360 | 361 | let shift t len = try Some (shift_exn t len) with Empty -> None 362 | end 363 | 364 | let iter f t = 365 | let idx = ref t.r in 366 | let max = t.w in 367 | while !idx <> max do 368 | f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx)); 369 | incr idx 370 | done 371 | 372 | let rev_iter f t = 373 | if t.r == t.w then () 374 | else 375 | let idx = ref (pred t.w) in 376 | let min = t.r in 377 | while 378 | f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx)); 379 | !idx <> min 380 | do 381 | decr idx 382 | done 383 | 384 | let fold f a t = 385 | let a = ref a in 386 | iter (fun x -> a := f !a x) t; 387 | !a 388 | 389 | let pp ?sep pp_elt = Minifmt.iter ?sep iter pp_elt 390 | let dump pp_elt = Minifmt.iter_dump iter (Minifmt.any "rke:weighted") pp_elt 391 | 392 | let clear q = 393 | q.r <- 0; 394 | q.w <- 0 395 | 396 | let unsafe_bigarray { v; _ } = v 397 | end 398 | -------------------------------------------------------------------------------- /lib/rke.mli: -------------------------------------------------------------------------------- 1 | include Sigs.R 2 | module Weighted : Sigs.Weighted.R 3 | -------------------------------------------------------------------------------- /lib/sigs.ml: -------------------------------------------------------------------------------- 1 | module type F = sig 2 | type 'a t 3 | (** The type of queues containing elements of type ['a]. *) 4 | 5 | exception Empty 6 | (** Raised when {!peek_exn} or {!pop_exn} is applied to an empty queue. *) 7 | 8 | val empty : 'a t 9 | (** An empty queue. *) 10 | 11 | val is_empty : 'a t -> bool 12 | (** Return [true] if the given queue is empty, [false] otherwise. *) 13 | 14 | val length : 'a t -> int 15 | (** Number of elements in the queue. *) 16 | 17 | val push : 'a t -> 'a -> 'a t 18 | (** Push element at the end of the queue. *) 19 | 20 | val cons : 'a t -> 'a -> 'a t 21 | (** Push element at the front of the queue. *) 22 | 23 | val peek : 'a t -> 'a option 24 | (** [peek q] returns the first element in the queue [q], without removing it 25 | from the queue. If [q] is empty, it returns [None]. *) 26 | 27 | val peek_exn : 'a t -> 'a 28 | (** Same as {!peek} but it raises an exception if [q] is empty. *) 29 | 30 | val pop : 'a t -> ('a * 'a t) option 31 | (** Get and remove the first element. If [q] is empty, it returns [None]. *) 32 | 33 | val pop_exn : 'a t -> 'a * 'a t 34 | (** Same as {!pop} but it raises an exception if [q] is empty. *) 35 | 36 | val tail : 'a t -> ('a t * 'a) option 37 | (** Get and remove the {b last} element. If [q] is empty, it returns [None]. *) 38 | 39 | val tail_exn : 'a t -> 'a t * 'a 40 | (** Same as {!tail} but it raises an exception if [q] is empty. *) 41 | 42 | val iter : ('a -> unit) -> 'a t -> unit 43 | (** [iter f q] applies [f] in turn to all elements of [q], from the least 44 | recently entered to the most recently entered. The queue itself is 45 | unchanged. *) 46 | 47 | val rev_iter : ('a -> unit) -> 'a t -> unit 48 | (** [rev_iter f q] applies [f] in turn to all elements of [q], from the most 49 | recently entered to the least recently entered. The queue itself is 50 | unchanged. *) 51 | 52 | val fold : ('acc -> 'x -> 'acc) -> 'acc -> 'x t -> 'acc 53 | (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the 54 | list of [q]'s elements. The queue remains unchanged. *) 55 | 56 | val pp : 57 | ?sep:(Format.formatter -> unit -> unit) -> 58 | (Format.formatter -> 'a -> unit) -> 59 | Format.formatter -> 60 | 'a t -> 61 | unit 62 | (** Pretty-printer of {!t}. *) 63 | 64 | val dump : 65 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 66 | (** Human-readable pretty-printer of {!t}. *) 67 | end 68 | 69 | module type R = sig 70 | type ('a, 'b) t 71 | (** The type of queues containing elements of type ['a]. *) 72 | 73 | exception Empty 74 | (** Raised when {!peek_exn}, {!pop_exn}, {!N.keep_exn} or {!N.shift_exn} is 75 | applied to an empty queue. *) 76 | 77 | val is_empty : ('a, 'b) t -> bool 78 | (** Return [true] if the given queue is empty, [false] otherwise. *) 79 | 80 | val create : ?capacity:int -> ('a, 'b) Bigarray.kind -> ('a, 'b) t 81 | (** Return a new queue, initially empty. *) 82 | 83 | val capacity : ('a, 'b) t -> int 84 | (** Returns how many objects [t] can store. *) 85 | 86 | val length : ('a, 'b) t -> int 87 | (** Number of elements in the queue. *) 88 | 89 | val push : ('a, 'b) t -> 'a -> unit 90 | (** [push q x] adds the elements [x] at the end of the queue [q]. *) 91 | 92 | val pop : ('a, 'b) t -> 'a option 93 | (** [pop q] removes and returns the first element in queue [q]. If [q] is 94 | empty, it returns [None]. *) 95 | 96 | val pop_exn : ('a, 'b) t -> 'a 97 | (** [pop_exn] is the same as {!pop} but it raises {!Empty} when the given 98 | queue [q] is empty. *) 99 | 100 | val peek : ('a, 'b) t -> 'a option 101 | (** [peek q] returns the first element in the queue [q], without removing it 102 | from the queue. If [q] is empty, it returns [None]. *) 103 | 104 | val peek_exn : ('a, 'b) t -> 'a 105 | (** Same as {!peek} but it raises {!Empty} if [q] is empty. *) 106 | 107 | val cons : ('a, 'b) t -> 'a -> unit 108 | (** [cons q x] adds element [x] at the front of the given queue [q]. It 109 | returns [None] if it fails. *) 110 | 111 | val copy : ('a, 'b) t -> ('a, 'b) t 112 | (** Return a copy of the given queue. *) 113 | 114 | val clear : ('a, 'b) t -> unit 115 | (** Discard all elements from a queue. *) 116 | 117 | val compress : ('a, 'b) t -> unit 118 | (** Compress queue, read cursor will be setted to [0] and data will be move 119 | to. This operation allows to provide much more space for a 120 | {!push}/{!N.push} operation - but it can not ensure enough free space. *) 121 | 122 | module N : sig 123 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 124 | (** The type of the internal bigarray of {!t}. *) 125 | 126 | type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit 127 | (** The type of the [blit] function. *) 128 | 129 | type 'a length = 'a -> int 130 | (** The type of the [length] function. *) 131 | 132 | val push : 133 | ('a, 'b) t -> 134 | blit:('src, ('a, 'b) bigarray) blit -> 135 | length:'src length -> 136 | ?off:int -> 137 | ?len:int -> 138 | 'src -> 139 | unit 140 | (** [push q ~blit ~length ?off ?len src] {i blits} elements in [src] to the 141 | given queue [q] at the end (like a fast iterative {!R.push}). Default 142 | value of [off] is [0]. Default value of [len] is [length src - off]. *) 143 | 144 | val keep_exn : 145 | ('a, 'b) t -> 146 | blit:(('a, 'b) bigarray, 'dst) blit -> 147 | length:'dst length -> 148 | ?off:int -> 149 | ?len:int -> 150 | 'dst -> 151 | unit 152 | (** [keep_exn q ~blit ~length ?off ?len dst] {i blits} elements of the given 153 | queue [q] in [dst] from the front to the end of [dst] (like a fast 154 | iterative {!R.pop_exn}). Default value of [off] is [0]. Default value of 155 | [len] is [length dst - off]. If the given [q] does not have enough 156 | elements to write on [dst], it raises {!Empty} and the given queue is 157 | unchanged. *) 158 | 159 | val keep : 160 | ('a, 'b) t -> 161 | blit:(('a, 'b) bigarray, 'dst) blit -> 162 | length:'dst length -> 163 | ?off:int -> 164 | ?len:int -> 165 | 'dst -> 166 | unit option 167 | (** Same as {!keep_exn} but if it fails, it returns [None]. *) 168 | 169 | val peek : ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t list 170 | (** Returns a sub-part of available to read payloads. *) 171 | 172 | val unsafe_shift : ('a, 'b) t -> int -> unit 173 | (** [unsafe_shift q l] discards [l] elements in the given queue [q] without 174 | any verification. Mostly used after {!keep_exn}, if the last one does not 175 | raise {!Empty}, it's safe to use it. *) 176 | 177 | val shift_exn : ('a, 'b) t -> int -> unit 178 | (** [shift_exn q l] discards [l] elements in the given queue [q]. If [q] 179 | does not have enough elements, it raises {!Empty} and the given queue is 180 | unchanged. *) 181 | 182 | val shift : ('a, 'b) t -> int -> unit option 183 | (** Same as {!shift_exn} but if it fails, it returns [None]. *) 184 | end 185 | 186 | val iter : ('a -> unit) -> ('a, 'b) t -> unit 187 | (** [iter f q] applies [f] in turn to all elements of [q], from the least 188 | recently entered to the most recently entered. The queue itself is 189 | unchanged. *) 190 | 191 | val rev_iter : ('a -> unit) -> ('a, 'b) t -> unit 192 | (** [iter f q] applies [f] in turn to all elements of [q], from the most 193 | recently entered to the least recently entered. The queue itself is 194 | unchanged. *) 195 | 196 | val fold : ('acc -> 'x -> 'acc) -> 'acc -> ('x, 'b) t -> 'acc 197 | (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the 198 | list of [q]'s elements. The queue remains unchanged. *) 199 | 200 | val pp : 201 | ?sep:(Format.formatter -> unit -> unit) -> 202 | (Format.formatter -> 'a -> unit) -> 203 | Format.formatter -> 204 | ('a, 'b) t -> 205 | unit 206 | (** Pretty-printer of {!t}. *) 207 | 208 | val dump : 209 | (Format.formatter -> 'a -> unit) -> Format.formatter -> ('a, 'b) t -> unit 210 | (** Human-readable pretty-printer of {!t}. *) 211 | end 212 | 213 | module Weighted = struct 214 | module type R = sig 215 | type ('a, 'b) t 216 | (** The type of queues containing elements of type ['a]. *) 217 | 218 | exception Full 219 | (** Raised when {!push_exn} or {!N.push_exn} is applied to an empty queue. *) 220 | 221 | exception Empty 222 | (** Raised when {!peek_exn}, {!pop_exn} is applied to an empty queue. *) 223 | 224 | val is_empty : ('a, 'b) t -> bool 225 | (** Return [true] if the given queue is empty, [false] otherwise. *) 226 | 227 | val create : ?capacity:int -> ('a, 'b) Bigarray.kind -> ('a, 'b) t * int 228 | (** Return a new queue, initially empty with the real capacity of it. *) 229 | 230 | val length : ('a, 'b) t -> int 231 | (** Number of elements in the queue. *) 232 | 233 | val available : ('a, 'b) t -> int 234 | (** Free cells availables on the queue. *) 235 | 236 | val push_exn : ('a, 'b) t -> 'a -> unit 237 | (** [push_exn q x] adds the elements [x] at the end of the queue [q]. It 238 | raises {!Full} if the given queue [q] is full. *) 239 | 240 | val push : ('a, 'b) t -> 'a -> unit option 241 | (** [push q x] is the same as {!push_exn} but returns [None] if it fails. *) 242 | 243 | val pop : ('a, 'b) t -> 'a option 244 | (** [pop q] removes and returns the first element in the given queue [q]. If 245 | [q] is empty, it returns [None]. *) 246 | 247 | val pop_exn : ('a, 'b) t -> 'a 248 | (** [pop_exn q] is the same as {!pop} but it raises an {!Empty} if the given 249 | queue is empty. *) 250 | 251 | val peek : ('a, 'b) t -> 'a option 252 | (** [peek q] returns the first element in the given queue [q]. If [q] is 253 | empty, it returns [None]. *) 254 | 255 | val peek_exn : ('a, 'b) t -> 'a 256 | (** [peek_exn q] returns the first element in the given queue [q]. If [q] is 257 | empty, it raises {!Empty}. *) 258 | 259 | val cons_exn : ('a, 'b) t -> 'a -> unit 260 | (** [cons_exn q x] adds element [x] at the front of the given queue [q]. It 261 | raises {!Full} if the queue is full. *) 262 | 263 | val cons : ('a, 'b) t -> 'a -> unit option 264 | (** [cons q x] adds element [x] at the front of the given queue [q]. It 265 | returns [None] if it fails. *) 266 | 267 | val copy : ('a, 'b) t -> ('a, 'b) t 268 | (** Return a copy of the given queue. *) 269 | 270 | val clear : ('a, 'b) t -> unit 271 | (** Discard all elements from a queue. *) 272 | 273 | val compress : ('a, 'b) t -> unit 274 | (** Compress queue, read cursor will be setted to [0] and data will be move 275 | to. This operation allows to provide much more space for a 276 | {!push}/{!N.push} operation - but it can not ensure enough free space. *) 277 | 278 | module N : sig 279 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 280 | (** The type of the internal bigarray of {!t}. *) 281 | 282 | type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit 283 | (** The type of the [blit] function. *) 284 | 285 | type 'a length = 'a -> int 286 | (** The type of the [length] function. *) 287 | 288 | val push_exn : 289 | ('a, 'b) t -> 290 | blit:('src, ('a, 'b) bigarray) blit -> 291 | length:'src length -> 292 | ?off:int -> 293 | ?len:int -> 294 | 'src -> 295 | ('a, 'b) bigarray list 296 | (** [push_exn q ~blit ~length ?off ?len src] {i blits} elements in [src] 297 | to the given queue [q] at the end (like a fast iterative {!R.push}). 298 | Default value of [off] is [0]. Default value of [len] is [length src - off]. 299 | It returns a list of internal {!bigarray}s which contain [dst]. 300 | If the given [q] does not have enough free space to write [src], it 301 | raises {!Full} and the given queue is unchanged. *) 302 | 303 | val push : 304 | ('a, 'b) t -> 305 | blit:('src, ('a, 'b) bigarray) blit -> 306 | length:'src length -> 307 | ?off:int -> 308 | ?len:int -> 309 | 'src -> 310 | ('a, 'b) bigarray list option 311 | (** Same as {!push_exn} but it returns [None] if it fails. *) 312 | 313 | val keep_exn : 314 | ('a, 'b) t -> 315 | blit:(('a, 'b) bigarray, 'dst) blit -> 316 | length:'dst length -> 317 | ?off:int -> 318 | ?len:int -> 319 | 'dst -> 320 | unit 321 | (** [keep_exn q ~blit ~length ?off ?len dst] {i blits} elements of the 322 | given queue [q] in [dst] from the front to the end of [dst] (like a 323 | fast iterative {!R.pop_exn}). Default value of [off] is [0]. Default 324 | value of [len] is [length dst - off]. If the given [q] does not have 325 | enough elements to write on [dst], it raises {!Empty}. In any case, the 326 | given queue is unchanged. *) 327 | 328 | val keep : 329 | ('a, 'b) t -> 330 | blit:(('a, 'b) bigarray, 'dst) blit -> 331 | length:'dst length -> 332 | ?off:int -> 333 | ?len:int -> 334 | 'dst -> 335 | unit option 336 | (** Same as {!keep_exn} but if it fails, it returns [None]. *) 337 | 338 | val peek : 339 | ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t list 340 | (** Returns a sub-part of available to read payloads. *) 341 | 342 | val unsafe_shift : ('a, 'b) t -> int -> unit 343 | (** [unsafe_shift q l] discards [l] elements in the given queue [q] 344 | without any verification. Mostly used after {!keep_exn}, if the last 345 | one does not raise {!Empty}, it's safe to use it. *) 346 | 347 | val shift_exn : ('a, 'b) t -> int -> unit 348 | (** [shift_exn q l] discards [l] elements in the given queue [q]. If [q] 349 | does not have enough elements, it raises {!Empty} and the given queue 350 | is unchanged. *) 351 | 352 | val shift : ('a, 'b) t -> int -> unit option 353 | (** Same as {!shift_exn} but if it fails, it returns [None]. *) 354 | end 355 | 356 | val iter : ('a -> unit) -> ('a, 'b) t -> unit 357 | (** [iter f q] applies [f] in turn to all elements of [q], from the least 358 | recently entered to the most recently entered. The queue itself is 359 | unchanged. *) 360 | 361 | val rev_iter : ('a -> unit) -> ('a, 'b) t -> unit 362 | (** [iter f q] applies [f] in turn to all elements of [q], from the most 363 | recently entered to the least recently entered. The queue itself is 364 | unchanged. *) 365 | 366 | val fold : ('acc -> 'x -> 'acc) -> 'acc -> ('x, 'b) t -> 'acc 367 | (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the 368 | list of [q]'s elements. The queue remains unchanged. *) 369 | 370 | val pp : 371 | ?sep:(Format.formatter -> unit -> unit) -> 372 | (Format.formatter -> 'a -> unit) -> 373 | Format.formatter -> 374 | ('a, 'b) t -> 375 | unit 376 | (** Pretty-printer of {!t}. *) 377 | 378 | val dump : 379 | (Format.formatter -> 'a -> unit) -> Format.formatter -> ('a, 'b) t -> unit 380 | (** Human-readable pretty-printer of {!t}. *) 381 | 382 | val unsafe_bigarray : 383 | ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 384 | (** / **) 385 | 386 | val from : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t -> ('a, 'b) t 387 | end 388 | 389 | module type F = sig 390 | type ('a, 'b) t 391 | (** The type of queues containing elements of type ['a]. *) 392 | 393 | exception Empty 394 | (** Raised when {!push_exn} or {!N.push_exn} is applied to an empty queue. *) 395 | 396 | exception Full 397 | (** Raised when {!peek_exn}, {!pop_exn} is applied to an empty queue. *) 398 | 399 | val is_empty : ('a, 'b) t -> bool 400 | (** Return [true] if the given queue is empty, [false] otherwise. *) 401 | 402 | val create : ?capacity:int -> ('a, 'b) Bigarray.kind -> ('a, 'b) t * int 403 | (** Return a new queue, initially empty with the real capacity of it. *) 404 | 405 | val length : ('a, 'b) t -> int 406 | (** Number of elements in the queue. *) 407 | 408 | val available : ('a, 'b) t -> int 409 | (** Free cells availables on the queue. *) 410 | 411 | val push_exn : ('a, 'b) t -> 'a -> ('a, 'b) t 412 | (** [push_exn q x] adds the elements [x] at the end of the queue [q] and 413 | returns the new queue [q']. It raises {!Full} if the given queue [q] is 414 | full. *) 415 | 416 | val push : ('a, 'b) t -> 'a -> ('a, 'b) t option 417 | (** [push q x] is the same as {!push_exn} but returns [None] if it fails. *) 418 | 419 | val pop : ('a, 'b) t -> ('a * ('a, 'b) t) option 420 | (** [pop q] removes and returns the first element in the given queue [q] and 421 | returns the new queue [q']. If [q] is empty, it returns [None]. *) 422 | 423 | val pop_exn : ('a, 'b) t -> 'a * ('a, 'b) t 424 | (** [pop_exn q] is the same as {!pop} but it raises an {!Empty} if the given 425 | queue is empty. *) 426 | 427 | val peek : ('a, 'b) t -> 'a option 428 | (** [peek q] returns the first element in the given queue [q]. If [q] is 429 | empty, it returns [None]. The given queue [q] is unchanged. *) 430 | 431 | val peek_exn : ('a, 'b) t -> 'a 432 | (** [peek_exn q] returns the first element in the given queue [q]. If [q] is 433 | empty, it raises {!Empty}. *) 434 | 435 | val cons : ('a, 'b) t -> 'a -> ('a, 'b) t option 436 | (** [cons q x] adds element [x] at the front of the given queue [q]. It 437 | returns [None] if it fails or the new queue [q']. *) 438 | 439 | val cons_exn : ('a, 'b) t -> 'a -> ('a, 'b) t 440 | (** [cons q x] adds element [x] at the front of the given queue [q]. It 441 | raises {!Empty} if the given queue [q] is full or the new queue [q']. *) 442 | 443 | val copy : ('a, 'b) t -> ('a, 'b) t 444 | (** Return a copy of the given queue. *) 445 | 446 | val clear : ('a, 'b) t -> ('a, 'b) t 447 | (** Discard all elements from a queue. *) 448 | 449 | module N : sig 450 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 451 | (** The type of the internal bigarray of {!t}. *) 452 | 453 | type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit 454 | (** The type of the [blit] function. *) 455 | 456 | type 'a length = 'a -> int 457 | (** The type of the [length] function. *) 458 | 459 | val push_exn : 460 | ('a, 'b) t -> 461 | blit:('src, ('a, 'b) bigarray) blit -> 462 | length:'src length -> 463 | ?off:int -> 464 | ?len:int -> 465 | 'src -> 466 | ('a, 'b) bigarray list * ('a, 'b) t 467 | (** [push_exn q ~blit ~length ?off ?len src] {i blits} elements in [src] 468 | to the given queue [q] at the end (like a fast iterative {!R.push}). 469 | Default value of [off] is [0]. Default value of [len] is [length src - off]. 470 | It returns a list of internal {!bigarray}s which contain [dst]. 471 | If the given [q] does not have enough free space to write [src], it 472 | raises {!Full} and the given queue is unchanged. *) 473 | 474 | val push : 475 | ('a, 'b) t -> 476 | blit:('src, ('a, 'b) bigarray) blit -> 477 | length:'src length -> 478 | ?off:int -> 479 | ?len:int -> 480 | 'src -> 481 | (('a, 'b) bigarray list * ('a, 'b) t) option 482 | (** Same as {!push_exn} but it returns [None] if it fails. *) 483 | 484 | val keep_exn : 485 | ('a, 'b) t -> 486 | blit:(('a, 'b) bigarray, 'dst) blit -> 487 | length:'dst length -> 488 | ?off:int -> 489 | ?len:int -> 490 | 'dst -> 491 | unit 492 | (** [keep_exn q ~blit ~length ?off ?len dst] {i blits} elements of the 493 | given queue [q] in [dst] from the front to the end of [dst] (like a 494 | fast iterative {!R.pop_exn}). Default value of [off] is [0]. Default 495 | value of [len] is [length dst - off]. If the given [q] does not have 496 | enough elements to write on [dst], it raises {!Empty}. In any case, the 497 | given queue is unchanged. *) 498 | 499 | val keep : 500 | ('a, 'b) t -> 501 | blit:(('a, 'b) bigarray, 'dst) blit -> 502 | length:'dst length -> 503 | ?off:int -> 504 | ?len:int -> 505 | 'dst -> 506 | unit option 507 | (** Same as {!keep_exn} but if it fails, it returns [None]. *) 508 | 509 | val unsafe_shift : ('a, 'b) t -> int -> ('a, 'b) t 510 | (** [unsafe_shift q l] discards [l] elements in the given queue [q] 511 | without any verification. Mostly used after {!keep_exn}, if the last 512 | one does not raise {!Empty}, it's safe to use it. *) 513 | 514 | val shift_exn : ('a, 'b) t -> int -> ('a, 'b) t 515 | (** [shift_exn q l] discards [l] elements in the given queue [q]. If [q] 516 | does not have enough elements, it raises {!Empty} and the given queue 517 | is unchanged. *) 518 | 519 | val shift : ('a, 'b) t -> int -> ('a, 'b) t option 520 | (** Same as {!shift_exn} but if it fails, it returns [None]. *) 521 | end 522 | 523 | val iter : ('a -> unit) -> ('a, 'b) t -> unit 524 | (** [iter f q] applies [f] in turn to all elements of [q], from the least 525 | recently entered to the most recently entered. The queue itself is 526 | unchanged. *) 527 | 528 | val rev_iter : ('a -> unit) -> ('a, 'b) t -> unit 529 | (** [iter f q] applies [f] in turn to all elements of [q], from the most 530 | recently entered to the least recently entered. The queue itself is 531 | unchanged. *) 532 | 533 | val fold : ('acc -> 'x -> 'acc) -> 'acc -> ('x, 'b) t -> 'acc 534 | (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the 535 | list of [q]'s elements. The queue remains unchanged. *) 536 | 537 | val pp : 538 | ?sep:(Format.formatter -> unit -> unit) -> 539 | (Format.formatter -> 'a -> unit) -> 540 | Format.formatter -> 541 | ('a, 'b) t -> 542 | unit 543 | (** Pretty-printer of {!t}. *) 544 | 545 | val dump : 546 | (Format.formatter -> 'a -> unit) -> Format.formatter -> ('a, 'b) t -> unit 547 | (** Human-readable pretty-printer of {!t}. *) 548 | 549 | (** / **) 550 | 551 | val unsafe_bigarray : 552 | ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 553 | 554 | val from : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t -> ('a, 'b) t 555 | end 556 | end 557 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries bigstringaf alcotest ke)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps 8 | (:exe test.exe)) 9 | (action 10 | (run %{exe} --color=always))) 11 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | let () = Printexc.record_backtrace true 2 | 3 | module Option = struct 4 | let map f = function Some x -> Some (f x) | None -> None 5 | end 6 | 7 | module type Q = sig 8 | type t 9 | 10 | exception Empty 11 | 12 | val available : t -> int 13 | val fold : ('a -> int -> 'a) -> 'a -> t -> 'a 14 | val create : unit -> t 15 | val push : t -> int -> unit 16 | val pop_exn : t -> int 17 | val peek_exn : t -> int 18 | val is_empty : t -> bool 19 | val length : t -> int 20 | val iter : (int -> unit) -> t -> unit 21 | val copy : t -> t 22 | val clear : t -> unit 23 | val compress : t -> unit 24 | end 25 | 26 | (* XXX(dinosaure): from [ocaml]. *) 27 | module Make (Q : Q) = struct 28 | let to_list q = Q.fold (fun a x -> x :: a) [] q |> List.rev 29 | 30 | let test_0 = 31 | Alcotest.test_case "test-0" `Quick @@ fun () -> 32 | let q = Q.create () in 33 | Alcotest.(check (list int)) "[ ]" (to_list q) []; 34 | Q.push q 1; 35 | Alcotest.(check (list int)) "[ 1 ]" (to_list q) [ 1 ]; 36 | Q.push q 2; 37 | Alcotest.(check (list int)) "[ 1; 2 ]" (to_list q) [ 1; 2 ]; 38 | Q.push q 3; 39 | Alcotest.(check (list int)) "[ 1; 2; 3 ]" (to_list q) [ 1; 2; 3 ]; 40 | Q.push q 4; 41 | Alcotest.(check (list int)) "[ 1; 2; 3; 4 ]" (to_list q) [ 1; 2; 3; 4 ]; 42 | let n = Q.pop_exn q in 43 | Alcotest.(check (list int)) "[ 2; 3; 4 ]" (to_list q) [ 2; 3; 4 ]; 44 | Alcotest.(check int) "1" n 1; 45 | let n = Q.pop_exn q in 46 | Alcotest.(check (list int)) "[ 3; 4 ]" (to_list q) [ 3; 4 ]; 47 | Alcotest.(check int) "2" n 2; 48 | let n = Q.pop_exn q in 49 | Alcotest.(check (list int)) "[ 4 ]" (to_list q) [ 4 ]; 50 | Alcotest.(check int) "3" n 3; 51 | let n = Q.pop_exn q in 52 | Alcotest.(check (list int)) "[ ]" (to_list q) []; 53 | Alcotest.(check int) "4" n 4; 54 | Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q)) 55 | 56 | let test_1 = 57 | Alcotest.test_case "test-1" `Quick @@ fun () -> 58 | let q = Q.create () in 59 | Alcotest.(check (list int)) "empty" (to_list q) []; 60 | Q.push q 1; 61 | let n = Q.pop_exn q in 62 | Alcotest.(check int) "1" n 1; 63 | Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q)); 64 | Q.push q 2; 65 | let n = Q.pop_exn q in 66 | Alcotest.(check int) "2" n 2; 67 | Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q)); 68 | Alcotest.(check bool) "empty" (Q.is_empty q) true 69 | 70 | let test_2 = 71 | Alcotest.test_case "test-2" `Quick @@ fun () -> 72 | let q = Q.create () in 73 | Q.push q 1; 74 | Alcotest.(check int) "[ 1 ]" (Q.peek_exn q) 1; 75 | Q.push q 2; 76 | Alcotest.(check int) "[ 1; 2 ]" (Q.peek_exn q) 1; 77 | Q.push q 3; 78 | Alcotest.(check int) "[ 1; 2; 3 ]" (Q.peek_exn q) 1; 79 | Alcotest.(check int) "peek" (Q.peek_exn q) 1; 80 | Alcotest.(check int) "pop" (Q.pop_exn q) 1; 81 | Alcotest.(check int) "peek" (Q.peek_exn q) 2; 82 | Alcotest.(check int) "pop" (Q.pop_exn q) 2; 83 | Alcotest.(check int) "peek" (Q.peek_exn q) 3; 84 | Alcotest.(check int) "pop" (Q.pop_exn q) 3; 85 | Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q)); 86 | Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q)); 87 | Alcotest.(check bool) "empty" (Q.is_empty q) true 88 | 89 | let test_3 = 90 | Alcotest.test_case "test-3" `Quick @@ fun () -> 91 | let q = Q.create () in 92 | for i = 1 to 10 do 93 | Q.push q i 94 | done; 95 | Q.clear q; 96 | Alcotest.(check int) "length" (Q.length q) 0; 97 | Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q)); 98 | Q.push q 42; 99 | Alcotest.(check int) "[ 42 ]" (Q.pop_exn q) 42 100 | 101 | let test_4 = 102 | Alcotest.test_case "test-4" `Quick @@ fun () -> 103 | let q1 = Q.create () in 104 | for i = 1 to 10 do 105 | Q.push q1 i 106 | done; 107 | let q2 = Q.copy q1 in 108 | Alcotest.(check (list int)) 109 | "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q1) 110 | [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]; 111 | Alcotest.(check (list int)) 112 | "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q2) 113 | [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]; 114 | Alcotest.(check int) "length" (Q.length q1) 10; 115 | Alcotest.(check int) "length" (Q.length q2) 10; 116 | for i = 1 to 10 do 117 | Alcotest.(check int) (string_of_int i) (Q.pop_exn q1) i 118 | done; 119 | for i = 1 to 10 do 120 | Alcotest.(check int) (string_of_int i) (Q.pop_exn q2) i 121 | done 122 | 123 | let test_5 = 124 | Alcotest.test_case "test-5" `Quick @@ fun () -> 125 | let q = Q.create () in 126 | Alcotest.(check bool) "is_empty" (Q.is_empty q) true; 127 | for i = 1 to 10 do 128 | Q.push q i; 129 | Alcotest.(check int) "length" (Q.length q) i; 130 | Alcotest.(check bool) "is_not_empty" (not (Q.is_empty q)) true 131 | done; 132 | for i = 10 downto 1 do 133 | Alcotest.(check int) "length" (Q.length q) i; 134 | Alcotest.(check bool) "is_not_empty" (not (Q.is_empty q)) true; 135 | ignore (Q.pop_exn q) 136 | done; 137 | Alcotest.(check int) "length" (Q.length q) 0; 138 | Alcotest.(check bool) "is_empty" (Q.is_empty q) true 139 | 140 | let test_6 = 141 | Alcotest.test_case "test-6" `Quick @@ fun () -> 142 | let q = Q.create () in 143 | for i = 1 to 10 do 144 | Q.push q i 145 | done; 146 | let i = ref 1 in 147 | Q.iter 148 | (fun j -> 149 | Alcotest.(check int) "iter" !i j; 150 | incr i) 151 | q 152 | 153 | let test_7 = 154 | Alcotest.test_case "test-7" `Quick @@ fun () -> 155 | let q = Q.create () in 156 | for i = 1 to 10 do 157 | Q.push q i 158 | done; 159 | for _ = 1 to 10 do 160 | ignore (Q.pop_exn q) 161 | done; 162 | for i = 1 to 10 do 163 | Q.push q i 164 | done; 165 | let expect = [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ] in 166 | Alcotest.(check (list int)) 167 | "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q) expect; 168 | Q.compress q; 169 | Alcotest.(check (list int)) 170 | "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q) expect 171 | 172 | let test_8 = 173 | Alcotest.test_case "test-8" `Quick @@ fun () -> 174 | let q = Q.create () in 175 | let m = Q.available q in 176 | for i = 1 to m / 2 do 177 | Q.push q i 178 | done; 179 | for _ = 1 to m / 2 do 180 | ignore (Q.pop_exn q) 181 | done; 182 | for i = 1 to m do 183 | Q.push q i 184 | done; 185 | let expect = to_list q in 186 | for _ = 1 to m do 187 | ignore (Q.pop_exn q) 188 | done; 189 | for i = 1 to m do 190 | Q.push q i 191 | done; 192 | Alcotest.(check (list int)) "filled" (to_list q) expect; 193 | Q.compress q; 194 | Alcotest.(check (list int)) "filled" (to_list q) expect 195 | end 196 | 197 | module Test_rke = Make (struct 198 | type t = (int, Bigarray.int_elt) Ke.Rke.t 199 | 200 | module W : sig 201 | exception Empty 202 | end = struct 203 | include Ke.Rke 204 | end 205 | 206 | include W 207 | 208 | let available = Ke.Rke.capacity 209 | let fold = Ke.Rke.fold 210 | let create () = Ke.Rke.create ~capacity:0x100 Bigarray.Int 211 | let push = Ke.Rke.push 212 | let pop_exn = Ke.Rke.pop_exn 213 | let peek_exn = Ke.Rke.peek_exn 214 | let is_empty = Ke.Rke.is_empty 215 | let length = Ke.Rke.length 216 | let iter = Ke.Rke.iter 217 | let copy = Ke.Rke.copy 218 | let clear = Ke.Rke.clear 219 | let compress = Ke.Rke.compress 220 | end) 221 | 222 | module Test_weighted_rke = Make (struct 223 | type t = (int, Bigarray.int_elt) Ke.Rke.Weighted.t 224 | 225 | module W : sig 226 | exception Empty 227 | end = struct 228 | include Ke.Rke.Weighted 229 | end 230 | 231 | include W 232 | 233 | let available = Ke.Rke.Weighted.available 234 | let fold = Ke.Rke.Weighted.fold 235 | 236 | let create () = 237 | let q, _ = Ke.Rke.Weighted.create ~capacity:0x100 Bigarray.Int in 238 | q 239 | 240 | let push = Ke.Rke.Weighted.push_exn 241 | let pop_exn = Ke.Rke.Weighted.pop_exn 242 | let peek_exn = Ke.Rke.Weighted.peek_exn 243 | let is_empty = Ke.Rke.Weighted.is_empty 244 | let length = Ke.Rke.Weighted.length 245 | let iter = Ke.Rke.Weighted.iter 246 | let copy = Ke.Rke.Weighted.copy 247 | let clear = Ke.Rke.Weighted.clear 248 | let compress = Ke.Rke.Weighted.compress 249 | end) 250 | 251 | module Test_blit = struct 252 | module Q = Ke.Rke.Weighted 253 | 254 | let blit_to_bytes src src_off dst dst_off len = 255 | Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len 256 | 257 | let blit_of_string src src_off dst dst_off len = 258 | Bigstringaf.blit_from_string src ~src_off dst ~dst_off ~len 259 | 260 | let blit_of_bytes src src_off dst dst_off len = 261 | Bigstringaf.blit_from_bytes src ~src_off dst ~dst_off ~len 262 | 263 | let test_0 = 264 | Alcotest.test_case "peek/keep" `Quick @@ fun () -> 265 | let q, _ = Q.create ~capacity:0x100 Bigarray.Char in 266 | let _ = 267 | Q.N.push_exn q ~blit:blit_of_string ~length:String.length "deadbeef" 268 | in 269 | let res = Q.N.peek q in 270 | Alcotest.(check (list string)) 271 | "peek:deadbeef" [ "deadbeef" ] 272 | (List.map Bigstringaf.to_string res); 273 | let tmp = Bytes.create (String.length "deadbeef") in 274 | let _ = Q.N.keep_exn q ~blit:blit_to_bytes ~length:Bytes.length tmp in 275 | Alcotest.(check string) 276 | "keep:deadbeef" "deadbeef" 277 | (Bytes.unsafe_to_string tmp) 278 | 279 | let test_1 = 280 | Alcotest.test_case "shift" `Quick @@ fun () -> 281 | let q, _ = Q.create ~capacity:0x100 Bigarray.Char in 282 | let _ = 283 | Q.N.push_exn q ~blit:blit_of_string ~length:String.length "deadbeef" 284 | in 285 | Q.N.shift_exn q (String.length "deadbeef"); 286 | let res = Q.N.peek q in 287 | Alcotest.(check (list string)) 288 | "peek:empty" [] 289 | (List.map Bigstringaf.to_string res) 290 | 291 | let test_2 = 292 | Alcotest.test_case "push" `Quick @@ fun () -> 293 | let q, capacity = Q.create ~capacity:0x10 Bigarray.Char in 294 | match 295 | Q.N.push q ~blit:blit_of_string ~length:String.length 296 | (String.make capacity '\000') 297 | with 298 | | Some res -> 299 | Alcotest.(check (list string)) 300 | "push:0x00" 301 | [ String.make capacity '\000' ] 302 | (List.map Bigstringaf.to_string res); 303 | let res = 304 | Q.N.push q ~blit:blit_of_string ~length:String.length "\x42" 305 | in 306 | Alcotest.(check (option (list string))) 307 | "push:0x42" None 308 | (Option.map (List.map Bigstringaf.to_string) res) 309 | | None -> 310 | Alcotest.failf "Impossible to push %S" (String.make capacity '\000') 311 | end 312 | 313 | let () = 314 | Alcotest.run "ke" 315 | [ 316 | ( "rke", 317 | [ 318 | Test_rke.test_0; Test_rke.test_1; Test_rke.test_2; Test_rke.test_3; 319 | Test_rke.test_4; Test_rke.test_5; Test_rke.test_6; Test_rke.test_7; 320 | Test_rke.test_8; 321 | ] ); 322 | ( "rke:weighted", 323 | [ 324 | Test_weighted_rke.test_0; Test_weighted_rke.test_1; 325 | Test_weighted_rke.test_2; Test_weighted_rke.test_3; 326 | Test_weighted_rke.test_4; Test_weighted_rke.test_5; 327 | Test_weighted_rke.test_6; Test_weighted_rke.test_7; 328 | Test_weighted_rke.test_8; Test_blit.test_0; Test_blit.test_1; 329 | Test_blit.test_2; 330 | ] ); 331 | ] 332 | --------------------------------------------------------------------------------