├── .gitignore ├── CHANGES.md ├── LICENSE ├── README.md ├── dune ├── dune-project ├── makefile ├── src ├── array_like.ml ├── circular.ml ├── dune ├── grow.ml ├── root.ml ├── varray.ml ├── varray.mli └── varray_sig.ml ├── tests ├── array_like_test.ml ├── bench_access.ml ├── dune └── exhaust.ml └── varray.opam /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | .merlin 12 | *.install 13 | *.coverage 14 | *.sw[lmnop] 15 | 16 | _build/ 17 | _doc/ 18 | _coverage/ 19 | _opam/ 20 | 21 | odoc.css 22 | bench.tsv 23 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 0.1 (2022-04-09) 2 | 3 | Initial release. 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Arthur Wendling 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, 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, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | > **[Tiered Vectors: Efficient Dynamic Arrays for Rank-Based Sequences]** \[243ko pdf\]\ 2 | > by Michael T. Goodrich and John G. Kloss II \ 3 | > WADS 1999. Lecture Notes in Computer Science, vol 1663 https://doi.org/10.1007/3-540-48447-7\_21 4 | 5 | This library provides an implementation of **var**iable sized **arrays**, which 6 | are also called resizable arrays, dynamic arrays or even "vectors" in C++ and 7 | "ArrayList" in Java. Just like an array, accessing any element by its index is 8 | constant time, but one can also efficiently insert and delete at any location 9 | (with the array resizing automatically to meet the need). 10 | 11 | **[Online Documentation]** 12 | 13 | Following the above paper, the family of tiered vectors yields a nice 14 | compromise between random access and resizing: 15 | 16 | | Module Circular | `get`, `set` | `{push,pop}_{back,front}` | `insert_at`, `pop_at` | Memory overhead | 17 | |-------------------------------|-------------:|:-------------------------:|:----------------------------------:|:-----------------------:| 18 | | Circular | O(1) | O(1) amortized | O(N) | O(N) | 19 | | Root(Circular) | O(1) | O(1) amortized | O(√N) | O(√N) | 20 | | Rootk-1(Circular) | O(k) | O(k) amortized | O(k2 × k√N) | O(Nk-1 / k) | 21 | 22 | In other words, each instantiation of the `Root` functor leads to slower random 23 | access into the array, but it also makes insertion and deletion faster! 24 | 25 | ![benchmark: inserting in the middle](https://art-w.github.io/varray/insert.png) 26 | 27 | You can expect the following constant factors on random access: 28 | 29 | | | Array | Circular | Root | Root2 | Root3 | Root4 | Root5 | 30 | |----:|------:|---------:|-----:|-----------------:|-----------------:|-----------------:|-----------------:| 31 | | get | 1x | 3x | 8x | 17x | 27x | 31x | 33x | 32 | | set | 1x | 2x | 4x | 8x | 12x | 14x | 15x | 33 | 34 | The memory usage is competitive: 35 | 36 | - `push_front`, `push_back` and their respective `pop`, are *amortized* 37 | constant time, since they frequently need to allocate small chunks of 38 | O(k√N) up to O(k k√N) memory as the varray grows or 39 | shrinks. 40 | - The growth strategy is incremental: the worst case slowdown following a 41 | resize is also O(k k√N) which is unobtrusive for k>1. There is no 42 | "stop the world while every elements is moved to a larger array". 43 | - The amount of memory used for bookkeeping and allocated in anticipation of a 44 | growth is pretty tight. In particular for k=2, the O(√N) memory overhead is 45 | optimal if random access and `push_back` are to be O(1). 46 | 47 | If you only care about fast random access and resizing at the right end with 48 | `{push,pop}_back`, then the pre-existing libraries provide smaller constant 49 | factors : (in alphabetical order) [BatDynArray] from Batteries, [CCVector] from 50 | Containers, [RES] as a standalone library or even [vector] as a single module. 51 | 52 | [Tiered Vectors: Efficient Dynamic Arrays for Rank-Based Sequences]: https://www.ics.uci.edu/~goodrich/pubs/wads99.pdf 53 | [Online Documentation]: https://art-w.github.io/varray/varray 54 | [BatDynArray]: https://ocaml-batteries-team.github.io/batteries-included/hdoc2/BatDynArray.html 55 | [CCVector]: https://c-cube.github.io/ocaml-containers/last/containers/CCVector/index.html 56 | [RES]: https://github.com/mmottl/res 57 | [vector]: https://github.com/backtracking/vector 58 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (dirs src tests) 2 | 3 | (env 4 | (release 5 | (flags (:standard -noassert)))) 6 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (generate_opam_files true) 3 | 4 | (name varray) 5 | (source (github art-w/varray)) 6 | (license MIT) 7 | (authors "Arthur Wendling") 8 | (maintainers "art.wendling@gmail.com") 9 | (version 0.2) 10 | 11 | (package 12 | (name varray) 13 | (synopsis "Resizable arrays with fast insertion/deletion") 14 | (depends 15 | (ocaml (>= "4.08")) 16 | (monolith :with-test)) 17 | (description 18 | " 19 | - O(1) constant time for random access `arr.(i)` and updates `arr.(i) <- v` 20 | - O(1) amortized for `push_front` and `pop_front`, `push_back` and `pop_back` to add or remove an element to the start or the end 21 | - O(sqrt N) for `insert_at arr i x` and `delete_at arr i` to insert or delete an element anywhere else 22 | 23 | This datastructure was invented by Goodrich and Kloss and is described in their paper \"Tiered Vectors: Efficient Dynamic Arrays for Rank-Based Sequences\".") 24 | ) 25 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | .PHONY: test 2 | test: 3 | dune exec --force tests/array_like_test.exe 4 | 5 | .PHONY: bench_access 6 | bench_access: 7 | dune exec --force --profile=release tests/bench_access.exe 8 | 9 | .PHONY: cover 10 | cover: clean 11 | dune exec --force --instrument-with bisect_ppx tests/array_like_test.exe 12 | bisect-ppx-report html 13 | bisect-ppx-report summary 14 | 15 | .PHONY: doc 16 | doc: odoc.css 17 | rm -rf _doc 18 | dune build @doc 19 | cp -r _build/default/_doc _doc 20 | [ -f odoc.css ] && cp -f odoc.css _doc/_html/odoc.css 21 | 22 | .PHONY: clean 23 | clean: 24 | dune clean 25 | rm -rf _doc 26 | rm -rf _coverage 27 | rm -f bisect*.coverage 28 | 29 | .PHONY: width80 30 | width80: 31 | find . -name '*.ml*' \ 32 | | grep -e '^./src' -e '^./tests' \ 33 | | grep -e '\.mli\?$$' \ 34 | | xargs grep --color -E -e '^.{80,}| $$' \ 35 | || echo 'OK' 36 | 37 | .PHONY: print 38 | print: 39 | find . -name '*.ml' \ 40 | | grep -e '^./src' \ 41 | | xargs grep --color -e 'print' \ 42 | || echo 'OK' 43 | -------------------------------------------------------------------------------- /src/array_like.ml: -------------------------------------------------------------------------------- 1 | module Make (Arg : Varray_sig.VARRAY) 2 | : Varray_sig.S with type 'a elt = 'a Arg.elt and type 'a array = 'a Arg.array 3 | = struct 4 | 5 | include Arg 6 | 7 | let sub t pos len = 8 | if pos < 0 || len < 0 || pos + len > length t 9 | then invalid_arg "Varray.sub" ; 10 | init len (fun i -> get t (pos + i)) 11 | 12 | let copy t = sub t 0 (length t) 13 | 14 | let fill t i n x = 15 | if i < 0 || n < 0 || i + n >= length t 16 | then invalid_arg "Varray.fill" ; 17 | for j = i to i + n - 1 do 18 | set t j x 19 | done 20 | 21 | let blit src src_pos dst dst_pos len = 22 | if src = dst && src_pos < dst_pos 23 | then for j = len - 1 downto 0 do 24 | set dst (j + dst_pos) (get src (j + src_pos)) 25 | done 26 | else for j = 0 to len - 1 do 27 | set dst (j + dst_pos) (get src (j + src_pos)) 28 | done 29 | 30 | let append a b = 31 | match length a, length b with 32 | | 0, _ -> copy b 33 | | _, 0 -> copy a 34 | | a_len, b_len -> 35 | let x = get a 0 in 36 | let t = make (a_len + b_len) x in 37 | blit a 1 t 1 (a_len - 1) ; 38 | blit b 0 t a_len b_len ; 39 | t 40 | 41 | let rec concat = function 42 | | [] -> empty () 43 | | t :: ts when is_empty t -> concat ts 44 | | (t :: _) as lst -> 45 | let len = 46 | List.fold_left (fun acc t -> acc + length t) 0 lst 47 | in 48 | let x = get t 0 in 49 | let result = make len x in 50 | let _ = 51 | List.fold_left 52 | (fun acc t -> 53 | let n = length t in 54 | blit t 0 result acc n ; 55 | acc + n) 56 | 0 57 | lst 58 | in 59 | result 60 | 61 | let iter f t = 62 | protect t @@ fun () -> 63 | for i = 0 to length t - 1 do 64 | f (get t i) 65 | done 66 | 67 | let iteri f t = 68 | protect t @@ fun () -> 69 | for i = 0 to length t - 1 do 70 | f i (get t i) 71 | done 72 | 73 | let map f t = match length t with 74 | | 0 -> empty () 75 | | n -> 76 | let x = f (get t 0) in 77 | let r = make n x in 78 | for i = 1 to n - 1 do 79 | set r i (f (get t i)) 80 | done ; 81 | r 82 | 83 | let map f t = protect t (fun () -> map f t) 84 | 85 | let mapi f t = match length t with 86 | | 0 -> empty () 87 | | n -> 88 | let x = f 0 (get t 0) in 89 | let r = make n x in 90 | for i = 1 to n - 1 do 91 | set r i (f i (get t i)) 92 | done ; 93 | r 94 | 95 | let mapi f t = protect t (fun () -> mapi f t) 96 | 97 | let fold_left f z t = 98 | let acc = ref z in 99 | for i = 0 to length t - 1 do 100 | acc := f !acc (get t i) 101 | done ; 102 | !acc 103 | 104 | let fold_left f z t = protect t (fun () -> fold_left f z t) 105 | 106 | let fold_right f t z = 107 | let acc = ref z in 108 | for i = length t - 1 downto 0 do 109 | acc := f (get t i) !acc 110 | done ; 111 | !acc 112 | 113 | let fold_right f t z = protect t (fun () -> fold_right f t z) 114 | 115 | let fold_left_map f z t = match length t with 116 | | 0 -> z, empty () 117 | | n -> 118 | let z, x = f z (get t 0) in 119 | let r = make n x in 120 | let acc = ref z in 121 | for i = 1 to n - 1 do 122 | let z, x = f !acc (get t i) in 123 | acc := z ; 124 | set r i x 125 | done ; 126 | !acc, r 127 | 128 | let fold_left_map f z t = protect t (fun () -> fold_left_map f z t) 129 | 130 | let iter2 f xs ys = 131 | let n, ys_len = length xs, length ys in 132 | if n <> ys_len then invalid_arg "Varray.iter2" ; 133 | for i = 0 to n - 1 do 134 | f (get xs i) (get ys i) 135 | done 136 | 137 | let iter2 f xs ys = 138 | protect xs (fun () -> protect ys (fun () -> iter2 f xs ys)) 139 | 140 | let map2 f xs ys = 141 | let n, ys_len = length xs, length ys in 142 | if n <> ys_len 143 | then invalid_arg "Varray.map2" 144 | else if n = 0 145 | then empty () 146 | else begin 147 | let x = f (get xs 0) (get ys 0) in 148 | let t = make n x in 149 | for i = 1 to n - 1 do 150 | let x = f (get xs i) (get ys i) in 151 | set t i x 152 | done ; 153 | t 154 | end 155 | 156 | let map2 f xs ys = 157 | protect xs (fun () -> protect ys (fun () -> map2 f xs ys)) 158 | 159 | exception Abort 160 | 161 | let for_all f t = 162 | try iter (fun x -> if not (f x) then raise Abort) t ; 163 | true 164 | with Abort -> false 165 | 166 | let for_all2 f xs ys = 167 | try iter2 (fun x y -> if not (f x y) then raise Abort) xs ys ; 168 | true 169 | with Abort -> false 170 | 171 | let exists f t = 172 | try iter (fun x -> if f x then raise Abort) t ; 173 | false 174 | with Abort -> true 175 | 176 | let exists2 f xs ys = 177 | try iter2 (fun x y -> if f x y then raise Abort) xs ys ; 178 | false 179 | with Abort -> true 180 | 181 | let mem x t = exists (( = ) x) t 182 | let memq x t = exists (( == ) x) t 183 | 184 | let find_opt (type a) f t = 185 | let exception Found of a elt in 186 | try iter (fun x -> if f x then raise (Found x)) t ; 187 | None 188 | with Found x -> Some x 189 | 190 | let find_map (type a) f t = 191 | let exception Found of a in 192 | let search x = match f x with 193 | | None -> () 194 | | Some y -> raise (Found y) 195 | in 196 | try iter search t ; 197 | None 198 | with Found x -> Some x 199 | 200 | let to_std_array t = Stdlib.Array.init (length t) (get t) 201 | 202 | let sort cmp t = 203 | let arr = to_std_array t in 204 | Stdlib.Array.sort cmp arr ; 205 | Stdlib.Array.iteri (set t) arr 206 | 207 | let stable_sort cmp t = 208 | let arr = to_std_array t in 209 | Stdlib.Array.stable_sort cmp arr ; 210 | Stdlib.Array.iteri (set t) arr 211 | 212 | let fast_sort cmp t = 213 | let arr = to_std_array t in 214 | Stdlib.Array.fast_sort cmp arr ; 215 | Stdlib.Array.iteri (set t) arr 216 | 217 | let of_array arr = 218 | init (Tier.Array.length arr) (Tier.Array.get arr) 219 | 220 | let to_array t = 221 | let n = length t in 222 | let arr = Arg.Tier.Array.create n in 223 | for i = 0 to n - 1 do 224 | Tier.Array.set arr i (get t i) 225 | done ; 226 | arr 227 | 228 | let to_list t = fold_right (fun x xs -> x :: xs) t [] 229 | 230 | let of_list = function 231 | | [] -> empty () 232 | | (x :: _) as lst -> 233 | let len = List.length lst in 234 | let t = make len x in 235 | List.iteri (fun i x -> set t i x) lst ; 236 | t 237 | 238 | let blit src src_pos dst dst_pos len = 239 | if src_pos < 0 || dst_pos < 0 || len < 0 240 | || src_pos + len > length src 241 | || dst_pos + len > length dst 242 | then invalid_arg "Varray.blit" ; 243 | blit src src_pos dst dst_pos len 244 | 245 | let pop_front t = 246 | if is_empty t then raise Not_found ; 247 | pop_front t 248 | 249 | let pop_back t = 250 | if is_empty t then raise Not_found ; 251 | pop_back t 252 | 253 | let pop_at t i = 254 | if i < 0 || i >= length t 255 | then invalid_arg "Varray.pop_at: index out of bounds" ; 256 | pop_at t i 257 | 258 | let delete_at t i = 259 | if i < 0 || i >= length t 260 | then invalid_arg "Varray.delete_at: index out of bounds" ; 261 | delete_at t i 262 | 263 | let insert_at t i = 264 | if i < 0 || i > length t 265 | then invalid_arg "Varray.insert_at: index out of bounds" ; 266 | insert_at t i 267 | 268 | let make n x = 269 | if n < 0 then invalid_arg "Varray.make" ; 270 | make n x 271 | 272 | let init n f = 273 | if n < 0 then invalid_arg "Varray.init" ; 274 | init n f 275 | 276 | end 277 | -------------------------------------------------------------------------------- /src/circular.ml: -------------------------------------------------------------------------------- 1 | let pow2 x = 1 lsl x 2 | 3 | module Make (Arg : Varray_sig.ARRAY) 4 | : sig 5 | include Varray_sig.TIER with type 'a Array.t = 'a Arg.t 6 | and type 'a Array.elt = 'a Arg.elt 7 | 8 | val set_length : 'a t -> int -> unit 9 | val grow_head : lc:int -> 'a t -> unit 10 | val grow_tail : 'a t -> unit 11 | val unsafe_pop_back : lc:int -> 'a t -> unit 12 | val root_capacity : 'a t -> int 13 | end 14 | = struct 15 | 16 | module Array = Arg 17 | type 'a elt = 'a Array.elt 18 | type 'a array = 'a Array.t 19 | 20 | type 'a t = 21 | { mutable head: int 22 | ; mutable length: int 23 | ; buffer: 'a Array.t 24 | } 25 | 26 | let depth = 1 27 | 28 | let length t = t.length 29 | 30 | let is_empty t = t.length = 0 31 | 32 | let capacity ~lc = pow2 lc 33 | 34 | let root_capacity t = Array.length t.buffer 35 | 36 | let is_full ~lc t = t.length = capacity ~lc 37 | 38 | let set_length t len = 39 | assert (len >= 0) ; 40 | t.length <- len 41 | 42 | let empty () = 43 | { head = 0 44 | ; length = 0 45 | ; buffer = Array.empty () 46 | } 47 | 48 | let create ~capacity = 49 | { head = 0 50 | ; length = 0 51 | ; buffer = Array.create capacity 52 | } 53 | 54 | let make ~lc n x = 55 | let buffer = Array.create (capacity ~lc) in 56 | for i = 0 to n - 1 do 57 | Array.set buffer i x 58 | done ; 59 | { head = 0 60 | ; length = n 61 | ; buffer 62 | } 63 | 64 | let init ~lc ~offset n f = 65 | let buffer = Array.create (capacity ~lc) in 66 | for i = 0 to n - 1 do 67 | let x = f (i + offset) in 68 | Array.set buffer i x 69 | done ; 70 | { head = 0 71 | ; length = n 72 | ; buffer 73 | } 74 | 75 | let index ~lc t i = (t.head + i) land (capacity ~lc - 1) 76 | let index_last ~lc t = index ~lc t (t.length - 1) 77 | 78 | let get ~lc t i = 79 | assert (i >= 0 && i < t.length) ; 80 | t.buffer.(index ~lc t i) 81 | 82 | let set ~lc t i x = 83 | assert (i >= 0 && i < t.length) ; 84 | t.buffer.(index ~lc t i) <- x 85 | 86 | let shift_right ~lc t j = 87 | let tail = index ~lc t t.length in 88 | if j <= tail 89 | then Array.blit t.buffer j t.buffer (j + 1) (tail - j) 90 | else begin 91 | let cap = capacity ~lc - 1 in 92 | let last = t.buffer.(cap) in 93 | Array.blit t.buffer j t.buffer (j + 1) (cap - j) ; 94 | Array.blit t.buffer 0 t.buffer 1 tail ; 95 | t.buffer.(0) <- last 96 | end 97 | 98 | let shift_left ~lc t j = 99 | let head = t.head in 100 | let cap = capacity ~lc in 101 | if j >= head 102 | then begin 103 | let prev = (head - 1) land (cap - 1) in 104 | t.buffer.(prev) <- t.buffer.(head) ; 105 | Array.blit t.buffer (head + 1) t.buffer head (j - head) 106 | end 107 | else begin 108 | Array.blit t.buffer head t.buffer (head - 1) (cap - head) ; 109 | t.buffer.(cap - 1) <- t.buffer.(0) ; 110 | Array.blit t.buffer 1 t.buffer 0 j ; 111 | end 112 | 113 | let head_left ~lc t = 114 | let head = index ~lc t (- 1) in 115 | t.head <- head 116 | 117 | let grow_tail t = 118 | t.length <- t.length + 1 119 | 120 | let grow_head ~lc t = 121 | assert (not (is_full ~lc t)) ; 122 | head_left ~lc t ; 123 | grow_tail t 124 | 125 | let push_front ~lc t x = 126 | assert (not (is_full ~lc t)) ; 127 | grow_head ~lc t ; 128 | t.buffer.(t.head) <- x 129 | 130 | let push_back ~lc t x = 131 | assert (not (is_full ~lc t)) ; 132 | grow_tail t ; 133 | t.buffer.(index_last ~lc t) <- x 134 | 135 | let make_room ~lc t i = 136 | assert (not (is_full ~lc t)) ; 137 | if 2 * i >= t.length 138 | then begin 139 | let j = index ~lc t i in 140 | shift_right ~lc t j ; 141 | grow_tail t 142 | end 143 | else begin 144 | let j = index ~lc t i in 145 | shift_left ~lc t j ; 146 | grow_head ~lc t 147 | end 148 | 149 | let insert_at ~lc t i x = 150 | assert (i >= 0 && i <= t.length) ; 151 | assert (not (is_full ~lc t)) ; 152 | make_room ~lc t i ; 153 | set ~lc t i x 154 | 155 | 156 | let shrink_tail t tail = 157 | assert (t.length > 0) ; 158 | Array.erase_at t.buffer tail ; 159 | t.length <- t.length - 1 160 | 161 | let shrink_head ~lc t head = 162 | assert (t.length > 0) ; 163 | assert (head = t.head) ; 164 | Array.erase_at t.buffer t.head ; 165 | t.head <- index ~lc t 1 ; 166 | t.length <- t.length - 1 167 | 168 | let shrink_next_tail ~lc t = 169 | let cap = capacity ~lc in 170 | if t.length + 1 < cap 171 | then let next = (t.head + t.length) land (cap - 1) in 172 | Array.erase_at t.buffer next 173 | 174 | let unsafe_pop_back ~lc t = 175 | shrink_next_tail ~lc t ; 176 | assert (t.length > 0) ; 177 | t.length <- t.length - 1 178 | 179 | let delete_right ~lc t j = 180 | let tail = index_last ~lc t in 181 | if j = tail 182 | then () 183 | else if j < tail 184 | then Array.blit t.buffer (j + 1) t.buffer j (tail - j) 185 | else begin 186 | let cap = capacity ~lc in 187 | Array.blit t.buffer (j + 1) t.buffer j (cap - 1 - j) ; 188 | t.buffer.(cap - 1) <- t.buffer.(0) ; 189 | Array.blit t.buffer 1 t.buffer 0 tail 190 | end ; 191 | shrink_tail t tail 192 | 193 | let delete_left ~lc t j = 194 | let head = t.head in 195 | if j = head 196 | then () 197 | else if head < j 198 | then Array.blit t.buffer head t.buffer (head + 1) (j - head) 199 | else begin 200 | let cap = capacity ~lc in 201 | let last = t.buffer.(cap - 1) in 202 | Array.blit t.buffer head t.buffer (head + 1) (cap - 1 - head) ; 203 | Array.blit t.buffer 0 t.buffer 1 j ; 204 | t.buffer.(0) <- last ; 205 | end ; 206 | shrink_head ~lc t head 207 | 208 | let delete_at ~lc t i = 209 | let j = index ~lc t i in 210 | if 2 * i >= t.length 211 | then delete_right ~lc t j 212 | else delete_left ~lc t j 213 | 214 | let pop_at ~lc t i = 215 | let x = get ~lc t i in 216 | delete_at ~lc t i ; 217 | x 218 | 219 | let pop_front ~lc t = 220 | assert (t.length > 0) ; 221 | let x = t.buffer.(t.head) in 222 | shrink_head ~lc t t.head ; 223 | x 224 | 225 | let pop_back ~lc t = 226 | assert (t.length > 0) ; 227 | let tail = index_last ~lc t in 228 | let x = t.buffer.(tail) in 229 | shrink_tail t tail ; 230 | x 231 | 232 | let push_front_pop_back ~lc t x = 233 | let tail = index_last ~lc t in 234 | let last = t.buffer.(tail) in 235 | head_left ~lc t ; 236 | t.buffer.(t.head) <- x ; 237 | last 238 | 239 | let push_back_pop_front ~lc t x = 240 | let first = t.buffer.(t.head) in 241 | t.head <- index ~lc t 1 ; 242 | let last = index_last ~lc t in 243 | t.buffer.(last) <- x ; 244 | first 245 | 246 | end 247 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name varray) 3 | (instrumentation (backend bisect_ppx))) 4 | -------------------------------------------------------------------------------- /src/grow.ml: -------------------------------------------------------------------------------- 1 | let ( /^ ) a b = 1 + (a - 1) / b 2 | 3 | let rec log2 = function 4 | | 0 | 1 -> 0 5 | | n -> 1 + log2 (n /^ 2) 6 | 7 | let pow2 n = 1 lsl n 8 | 9 | module Make (V : Varray_sig.TIER) 10 | : Varray_sig.VARRAY with type 'a elt = 'a V.elt and type 'a array = 'a V.array 11 | = struct 12 | 13 | module Tier = V 14 | 15 | module Array = V.Array 16 | type 'a elt = 'a V.elt 17 | type 'a array = 'a V.array 18 | 19 | type 'a t = 20 | { mutable lc : int 21 | ; mutable protected : bool 22 | ; mutable small : 'a V.t 23 | ; mutable large : 'a V.t 24 | } 25 | 26 | let length t = 27 | V.length t.small + V.length t.large 28 | 29 | let lc_for = function 30 | | n when n <= 0 -> 1 31 | | n -> log2 n /^ V.depth 32 | 33 | let empty () = 34 | { lc = 0 35 | ; protected = false 36 | ; small = V.create ~capacity:1 37 | ; large = V.empty () 38 | } 39 | 40 | let is_empty t = V.is_empty t.small && V.is_empty t.large 41 | 42 | let make n x = 43 | let lc = lc_for n in 44 | { lc 45 | ; protected = false 46 | ; small = V.make ~lc n x 47 | ; large = V.empty () 48 | } 49 | 50 | let init n f = 51 | let lc = lc_for n in 52 | { lc 53 | ; protected = false 54 | ; small = V.init ~lc ~offset:0 n f 55 | ; large = V.empty () 56 | } 57 | 58 | let protect t f = 59 | if t.protected 60 | then f () 61 | else begin 62 | t.protected <- true ; 63 | match f () with 64 | | v -> t.protected <- false ; v 65 | | exception e -> t.protected <- false ; raise e 66 | end 67 | 68 | let check_protection t = 69 | if t.protected 70 | then failwith "Varray modification during protected traversal" 71 | 72 | let get t i = 73 | let lc = t.lc in 74 | match i - V.length t.small with 75 | | j when i >= 0 && j < 0 -> 76 | V.get ~lc t.small i 77 | | j when j >= 0 && j < V.length t.large -> 78 | V.get ~lc:(lc + 1) t.large j 79 | | _ -> 80 | invalid_arg "index out of bounds" 81 | 82 | let set t i x = 83 | let lc = t.lc in 84 | match i - V.length t.small with 85 | | j when i >= 0 && j < 0 -> 86 | V.set ~lc t.small i x 87 | | j when j >= 0 && j < V.length t.large -> 88 | V.set ~lc:(lc + 1) t.large j x 89 | | _ -> 90 | invalid_arg "index out of bounds" 91 | 92 | let do_swap t = 93 | t.lc <- 1 + t.lc ; 94 | t.small <- t.large ; 95 | t.large <- V.empty () 96 | 97 | let swap t = 98 | if V.is_empty t.small && not (V.is_empty t.large) 99 | then do_swap t 100 | 101 | let is_growing t = length t >= V.capacity ~lc:t.lc 102 | 103 | let pow2_depth = pow2 V.depth 104 | 105 | let incr_capacity t = 106 | swap t ; 107 | if is_growing t 108 | then begin 109 | if not (V.is_empty t.large) 110 | then begin 111 | assert (not (V.is_empty t.small)) ; 112 | let lc = t.lc in 113 | let tl = V.pop_back ~lc t.small in 114 | let lc = t.lc + 1 in 115 | V.push_front ~lc t.large tl ; 116 | if V.is_empty t.small 117 | then do_swap t 118 | end 119 | else begin 120 | let tl = V.pop_back ~lc:t.lc t.small in 121 | let lc = 1 + t.lc in 122 | t.large <- V.make ~lc 1 tl 123 | end 124 | end 125 | 126 | let insert_at t i x = 127 | check_protection t ; 128 | incr_capacity t ; 129 | match i - V.length t.small with 130 | | j when j <= 0 -> 131 | V.insert_at ~lc:t.lc t.small i x ; 132 | incr_capacity t 133 | | j -> 134 | V.insert_at ~lc:(t.lc + 1) t.large j x 135 | 136 | let is_shrinking t = 137 | length t * pow2_depth < V.capacity ~lc:t.lc 138 | 139 | let decr_capacity t = 140 | swap t ; 141 | if is_shrinking t 142 | then begin 143 | if not (V.is_empty t.large) 144 | then begin 145 | let lc = t.lc in 146 | assert (not (V.is_full ~lc t.small)) ; 147 | V.push_back ~lc t.small (V.pop_front ~lc:(lc + 1) t.large) 148 | end 149 | else if t.lc > 1 && not (V.is_empty t.small) 150 | then begin 151 | let lc = t.lc in 152 | let hd = V.pop_front ~lc t.small in 153 | let lc = t.lc - 1 in 154 | t.lc <- lc ; 155 | t.large <- t.small ; 156 | t.small <- V.make ~lc 1 hd ; 157 | end 158 | end 159 | 160 | let pop_at t i = 161 | check_protection t ; 162 | decr_capacity t ; 163 | match i - V.length t.small with 164 | | j when j < 0 -> 165 | let x = V.pop_at ~lc:t.lc t.small i in 166 | decr_capacity t ; 167 | x 168 | | j -> 169 | V.pop_at ~lc:(t.lc + 1) t.large j 170 | 171 | let delete_at t i = ignore (pop_at t i) 172 | 173 | let push_back t x = 174 | check_protection t ; 175 | incr_capacity t ; 176 | let lc = t.lc in 177 | if V.is_empty t.large 178 | then V.push_back ~lc t.small x 179 | else V.push_back ~lc:(lc + 1) t.large x 180 | 181 | let push_front t x = 182 | check_protection t ; 183 | incr_capacity t ; 184 | let lc = t.lc in 185 | V.push_front ~lc t.small x ; 186 | incr_capacity t 187 | 188 | let pop_front t = 189 | check_protection t ; 190 | decr_capacity t ; 191 | let x = V.pop_front ~lc:t.lc t.small in 192 | decr_capacity t ; 193 | x 194 | 195 | let pop_back t = 196 | check_protection t ; 197 | decr_capacity t ; 198 | if V.is_empty t.large 199 | then V.pop_back ~lc:t.lc t.small 200 | else V.pop_back ~lc:(t.lc + 1) t.large 201 | 202 | end 203 | -------------------------------------------------------------------------------- /src/root.ml: -------------------------------------------------------------------------------- 1 | let pow2 x = 1 lsl x 2 | 3 | module Make (V : Varray_sig.TIER) 4 | : Varray_sig.TIER with module Array = V.Array 5 | = struct 6 | 7 | module Buffer = Circular.Make (struct 8 | include Array 9 | type 'a elt = 'a V.t 10 | type 'a t = 'a elt array 11 | let get = Array.unsafe_get 12 | let set = Array.unsafe_set 13 | let empty : type a. unit -> a t = fun () -> [| |] 14 | let create n = Array.make n (V.empty ()) 15 | let erase_at t i = set t i (V.empty ()) 16 | end) 17 | 18 | module Array = V.Array 19 | type 'a elt = 'a V.elt 20 | type 'a array = 'a V.array 21 | 22 | type 'a t = 23 | { mutable length : int 24 | ; mutable first : 'a V.t 25 | ; mutable rows : 'a Buffer.t 26 | } 27 | 28 | let empty () = 29 | { length = 0 ; first = V.empty () ; rows = Buffer.empty () } 30 | 31 | let is_empty t = t.length = 0 32 | 33 | let depth = V.depth + 1 34 | 35 | let sector_length ~lc = pow2 (lc * V.depth) 36 | 37 | let capacity ~lc = pow2 (lc * depth) 38 | 39 | let length t = t.length 40 | 41 | let is_full ~lc t = length t = capacity ~lc 42 | 43 | let root_capacity t = Buffer.root_capacity t.rows 44 | 45 | let create ~capacity = 46 | { length = 0 47 | ; first = V.empty () 48 | ; rows = Buffer.create ~capacity 49 | } 50 | 51 | let make ~lc n x = 52 | let capacity = pow2 lc in 53 | assert (capacity > 0) ; 54 | let sector_length = sector_length ~lc in 55 | let remaining, nb_full_parts = 56 | match n mod sector_length with 57 | | 0 when n < sector_length -> n, 0 58 | | 0 -> sector_length, n / sector_length - 1 59 | | rest -> rest, n / sector_length 60 | in 61 | let t = create ~capacity in 62 | t.length <- n ; 63 | Buffer.set_length t.rows nb_full_parts ; 64 | assert (remaining <= n) ; 65 | assert ((n > 0) = (remaining > 0)) ; 66 | assert (n = remaining + sector_length * nb_full_parts) ; 67 | t.first <- V.make ~lc remaining x ; 68 | for i = 0 to nb_full_parts - 1 do 69 | let row = V.make ~lc sector_length x in 70 | Buffer.set ~lc t.rows i row 71 | done ; 72 | t 73 | 74 | let init ~lc ~offset n f = 75 | let capacity = pow2 lc in 76 | assert (capacity > 0) ; 77 | let sector_length = sector_length ~lc in 78 | let remaining, nb_full_parts = 79 | match n mod sector_length with 80 | | 0 when n < sector_length -> n, 0 81 | | 0 -> sector_length, n / sector_length - 1 82 | | rest -> rest, n / sector_length 83 | in 84 | let t = create ~capacity in 85 | t.length <- n ; 86 | Buffer.set_length t.rows nb_full_parts ; 87 | assert (remaining <= n) ; 88 | assert ((n > 0) = (remaining > 0)) ; 89 | assert (n = remaining + sector_length * nb_full_parts) ; 90 | t.first <- V.init ~lc ~offset remaining f ; 91 | let offset = offset + remaining in 92 | for i = 0 to nb_full_parts - 1 do 93 | let offset = offset + i * sector_length in 94 | let row = V.init ~lc ~offset sector_length f in 95 | Buffer.set ~lc t.rows i row 96 | done ; 97 | t 98 | 99 | let has_capacity child = V.root_capacity child > 0 100 | 101 | let create_child ~lc t i x = 102 | let row = V.make ~lc 1 x in 103 | Buffer.set ~lc t.rows i row 104 | 105 | let initialize ~lc t = 106 | assert (Buffer.root_capacity t.rows = pow2 lc) 107 | 108 | let push_front_new ~lc t x = 109 | initialize ~lc t ; 110 | Buffer.grow_head ~lc t.rows ; 111 | let fst = Buffer.get ~lc t.rows 0 in 112 | assert (V.is_empty fst) ; 113 | assert (V.is_full ~lc t.first) ; 114 | Buffer.set ~lc t.rows 0 t.first ; 115 | t.first <- 116 | if has_capacity fst 117 | then (V.push_front ~lc fst x ; fst) 118 | else V.make ~lc 1 x 119 | 120 | let push_front ~lc t x = 121 | assert (not (is_full ~lc t)) ; 122 | begin 123 | if is_empty t 124 | then if has_capacity t.first 125 | then V.push_front ~lc t.first x 126 | else t.first <- V.make ~lc 1 x 127 | else if V.is_full ~lc t.first 128 | then push_front_new ~lc t x 129 | else V.push_front ~lc t.first x 130 | end ; 131 | t.length <- t.length + 1 ; 132 | assert (V.length t.first > 0) 133 | 134 | let push_back_new ~lc t x = 135 | initialize ~lc t ; 136 | let last_idx = Buffer.length t.rows in 137 | Buffer.grow_tail t.rows ; 138 | let fst = Buffer.get ~lc t.rows last_idx in 139 | assert (V.is_empty fst) ; 140 | if has_capacity fst 141 | then V.push_back ~lc fst x 142 | else create_child ~lc t last_idx x 143 | 144 | let push_back ~lc t x = 145 | assert (not (is_full ~lc t)) ; 146 | let n = Buffer.length t.rows - 1 in 147 | begin 148 | if n < 0 149 | then if not (has_capacity t.first) || V.is_full ~lc t.first 150 | then push_back_new ~lc t x 151 | else V.push_back ~lc t.first x 152 | else let tail = Buffer.get ~lc t.rows n in 153 | if V.is_full ~lc tail 154 | then push_back_new ~lc t x 155 | else V.push_back ~lc tail x 156 | end ; 157 | t.length <- t.length + 1 158 | 159 | let clean_front ~lc t = 160 | if V.is_empty t.first && Buffer.length t.rows > 0 161 | then t.first <- Buffer.pop_front ~lc t.rows 162 | 163 | let pop_front ~lc t = 164 | let first = t.first in 165 | let v = V.pop_front ~lc first in 166 | clean_front ~lc t ; 167 | t.length <- t.length - 1 ; 168 | v 169 | 170 | let clean_back ~lc t last = 171 | if V.is_empty last 172 | then begin 173 | assert (Buffer.length t.rows > 0) ; 174 | Buffer.unsafe_pop_back ~lc t.rows 175 | end 176 | 177 | let pop_back ~lc t = 178 | t.length <- t.length - 1 ; 179 | let i = Buffer.length t.rows - 1 in 180 | if i < 0 181 | then begin 182 | let x = V.pop_back ~lc t.first in 183 | clean_front ~lc t ; 184 | x 185 | end 186 | else begin 187 | let last = Buffer.get ~lc t.rows i in 188 | let v = V.pop_back ~lc last in 189 | clean_back ~lc t last ; 190 | v 191 | end 192 | 193 | let indexes' ~lc t i = 194 | let first = t.first in 195 | let first_len = V.length first in 196 | if i < first_len 197 | then 0, i 198 | else let i = i - first_len in 199 | let lcd = lc * V.depth in 200 | let j = 1 + i lsr lcd in 201 | let i = i land (pow2 lcd - 1) in 202 | j, i 203 | 204 | let indexes ~lc t i = 205 | if i = 0 206 | then 0, 0 207 | else indexes' ~lc t i 208 | 209 | let buffer_get ~lc t j = 210 | if j = 0 211 | then t.first 212 | else Buffer.get ~lc t.rows (j - 1) 213 | 214 | let get ~lc t i = 215 | assert (i >= 0 && i < length t) ; 216 | let j, i = indexes' ~lc t i in 217 | let row = buffer_get ~lc t j in 218 | V.get ~lc row i 219 | 220 | let set ~lc t i x = 221 | assert (i >= 0 && i < length t) ; 222 | let j, i = indexes' ~lc t i in 223 | let row = buffer_get ~lc t j in 224 | V.set ~lc row i x 225 | 226 | let collapse ~lc t j row = 227 | let len = Buffer.length t.rows in 228 | if 2 * j < len 229 | then begin 230 | let first = t.first in 231 | let v = ref (V.pop_back ~lc first) in 232 | for k = 0 to j - 2 do 233 | let row = Buffer.get ~lc t.rows k in 234 | v := V.push_front_pop_back ~lc row !v 235 | done ; 236 | V.push_front ~lc row !v ; 237 | clean_front ~lc t ; 238 | assert (V.length t.first > 0) ; 239 | for i = 0 to Buffer.length t.rows - 2 do 240 | let row = Buffer.get ~lc t.rows i in 241 | assert (V.length row = sector_length ~lc) 242 | done 243 | 244 | end 245 | else begin 246 | let len = len - 1 in 247 | let last = Buffer.get ~lc t.rows len in 248 | let v = ref (V.pop_front ~lc last) in 249 | for k = len - 1 downto j do 250 | let row = Buffer.get ~lc t.rows k in 251 | v := V.push_back_pop_front ~lc row !v ; 252 | done ; 253 | V.push_back ~lc row !v ; 254 | clean_back ~lc t last 255 | end 256 | 257 | let pop_at ~lc t i = 258 | assert (i >= 0 && i < length t) ; 259 | let j, i = indexes ~lc t i in 260 | let row = buffer_get ~lc t j in 261 | assert (j >= 0 && j <= Buffer.length t.rows) ; 262 | assert (i >= 0 && i < V.length row) ; 263 | let x = V.pop_at ~lc row i in 264 | t.length <- t.length - 1 ; 265 | if j = 0 266 | then clean_front ~lc t 267 | else if j >= Buffer.length t.rows 268 | then clean_back ~lc t row 269 | else collapse ~lc t j row ; 270 | x 271 | 272 | let push_front_pop_back ~lc t x = 273 | let y = pop_back ~lc t in 274 | push_front ~lc t x ; 275 | y 276 | 277 | let push_back_pop_front ~lc t x = 278 | let y = pop_front ~lc t in 279 | push_back ~lc t x ; 280 | y 281 | 282 | let insert_at ~lc t i x = 283 | assert (not (is_full ~lc t)) ; 284 | if i = 0 285 | then push_front ~lc t x 286 | else begin 287 | let j, i = indexes ~lc t i in 288 | let len = Buffer.length t.rows in 289 | if j = 0 290 | then begin 291 | t.length <- t.length + 1 ; 292 | if V.is_full ~lc t.first 293 | then begin 294 | assert (i > 0) ; 295 | let y = V.pop_front ~lc t.first in 296 | V.insert_at ~lc t.first (i - 1) x ; 297 | push_front_new ~lc t y 298 | end 299 | else V.insert_at ~lc t.first i x 300 | end 301 | else if j > len 302 | then push_back ~lc t x 303 | else begin 304 | let j = j - 1 in 305 | let row = Buffer.get ~lc t.rows j in 306 | if 2 * j < len 307 | then begin 308 | let v = 309 | if i = 0 310 | then x 311 | else begin 312 | let y = V.pop_front ~lc row in 313 | V.insert_at ~lc row (i - 1) x ; 314 | y 315 | end 316 | in 317 | let v = ref v in 318 | for k = j - 1 downto 0 do 319 | let row = Buffer.get ~lc t.rows k in 320 | v := V.push_back_pop_front ~lc row !v 321 | done ; 322 | v := V.push_back_pop_front ~lc t.first !v ; 323 | push_front ~lc t !v 324 | end 325 | else begin 326 | let v = 327 | if i = V.length row 328 | then x 329 | else begin 330 | let y = V.pop_back ~lc row in 331 | V.insert_at ~lc row i x ; 332 | y 333 | end 334 | in 335 | let v = ref v in 336 | for k = j + 1 to len - 1 do 337 | let row = Buffer.get ~lc t.rows k in 338 | v := V.push_front_pop_back ~lc row !v 339 | done ; 340 | push_back ~lc t !v 341 | end 342 | end 343 | end 344 | 345 | end 346 | -------------------------------------------------------------------------------- /src/varray.ml: -------------------------------------------------------------------------------- 1 | module Array_backend 2 | : Varray_sig.ARRAY with type 'a elt = 'a 3 | and type 'a t = 'a array 4 | = struct 5 | include Array 6 | type 'a elt = 'a 7 | let get = Array.unsafe_get 8 | let set = Array.unsafe_set 9 | let empty : type a. unit -> a t = fun () -> [| |] 10 | let placeholder : type a. a elt = Obj.magic () 11 | let create n = Array.make n placeholder 12 | let erase_at t i = set t i placeholder 13 | end 14 | 15 | module type ARRAY = Varray_sig.ARRAY 16 | 17 | module type ARRAY_TYPES = sig 18 | type 'a array_elt 19 | type 'a array_t 20 | end 21 | 22 | module Internals (X : ARRAY_TYPES) = struct 23 | module type UNSAFE = Varray_sig.TIER with type 'a Array.elt = 'a X.array_elt 24 | and type 'a Array.t = 'a X.array_t 25 | end 26 | 27 | module type S = sig 28 | include Varray_sig.S 29 | module Backend : sig 30 | type 'a array_elt = 'a elt 31 | type 'a array_t = 'a array 32 | end 33 | module Unsafe : Internals(Backend).UNSAFE 34 | end 35 | 36 | module Grow (Arg : Varray_sig.TIER) 37 | : S with type 'a elt = 'a Arg.elt and type 'a array = 'a Arg.array 38 | = struct 39 | module V = Grow.Make (Arg) 40 | include Array_like.Make (V) 41 | module Backend = struct 42 | type 'a array_elt = 'a elt 43 | type 'a array_t = 'a array 44 | end 45 | module Unsafe : Internals(Backend).UNSAFE = V.Tier 46 | end 47 | 48 | module Make (Array : ARRAY) 49 | : S with type 'a array = 'a Array.t and type 'a elt = 'a Array.elt 50 | = Grow (Circular.Make (Array)) 51 | 52 | module Root (V : S) 53 | : S with type 'a array = 'a V.array and type 'a elt = 'a V.elt 54 | = Grow (Root.Make (V.Unsafe)) 55 | 56 | module Circular 57 | : S with type 'a array = 'a Stdlib.Array.t and type 'a elt = 'a 58 | = Make (Array_backend) 59 | 60 | include Root (Circular) 61 | -------------------------------------------------------------------------------- /src/varray.mli: -------------------------------------------------------------------------------- 1 | (** 2 | A varray is a {b var}iable sized {b array}, also known as a resizable or 3 | dynamic array. 4 | 5 | Just like an array, random access / update is {b O(1)}. But you can also grow 6 | the varray by appending or prepending an element in constant time. 7 | Insertion and deletion at a specific index cost {b O({%html:k%}√N)} 8 | for any constant [k ≥ 1] of your choosing. 9 | 10 | For convenience, the recommended complexity tradeoff between time and memory is 11 | provided below with the constant parameter [k = 2]. You will find the internal 12 | building blocks at the end of this documentation to create a custom Varray with 13 | different asymptotics. 14 | *) 15 | 16 | include Varray_sig.S with type 'a elt = 'a 17 | and type 'a array = 'a Stdlib.Array.t (** @inline *) 18 | 19 | (** {1 Signature} *) 20 | 21 | module Internals (X : sig type 'a array_elt type 'a array_t end) : sig 22 | module type UNSAFE 23 | end 24 | (** The signature of the internal operations, required by the {! Root} functor 25 | below. *) 26 | 27 | module type S = sig 28 | include Varray_sig.S (** @inline *) 29 | 30 | (** {1 Internals} *) 31 | 32 | (** This part can be ignored as it exposes no user-facing functionality!.. 33 | but the design pattern is neat. The {! Root} functor requires access to 34 | internal operations, that should neither be called nor implemented by a 35 | user of this library. 36 | *) 37 | 38 | module Backend : sig 39 | type 'a array_elt = 'a elt 40 | type 'a array_t = 'a array 41 | end 42 | (** The ['a array] and ['a elt] types. *) 43 | 44 | module Unsafe : Internals(Backend).UNSAFE 45 | (** The internal operations, safely concealed behind an abstract signature! 46 | *) 47 | 48 | (** 49 | This could not have been written as: 50 | 51 | {[ module Unsafe : UNSAFE with type 'a array = 'a array 52 | and type 'a elt = 'a elt ]} 53 | 54 | Since the signature [UNSAFE] can't be type constrained without also 55 | having all its internal functions be public. The {! Internals} functor 56 | circumvent this rule by exposing an opaque signature parametrized by 57 | the type constraints. *) 58 | end 59 | (** The signature of a varray. *) 60 | 61 | (** {1 Build your own} *) 62 | 63 | (** The family of varrays is defined by calling the {! Root} functor as many 64 | times as required: *) 65 | 66 | (** 67 | 68 | {%html: 69 | 79 | 80 | 81 | 82 | 83 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 |
Moduleget, set 84 |
85 | push, pop		insert_at
delete_at		Memory overhead
CircularO(1)O(N)O(N)
Root (Circular)O(1)O(2√N)O(2√N)
Root (Root (Circular))O(1)O(3√N)O(N2/3)
Rootk-1 (Circular)O(k)O(k2 × k√N)O(Nk-1 / k)
117 | %} 118 | 119 | *) 120 | 121 | (** The first step is to choose a backend [Array] that will be used to store 122 | the elements: *) 123 | 124 | module type ARRAY = sig 125 | include Varray_sig.ARRAY (** @inline *) 126 | end 127 | 128 | (** Some good candidates from the standard library are [Array] for polymorphic 129 | values, [BigArray.Array1] for numbers, [Bytes] for characters, 130 | or [Weak] for weak pointers. *) 131 | 132 | module Make (Array : ARRAY) 133 | : S with type 'a array = 'a Array.t and type 'a elt = 'a Array.elt 134 | (** [Make (Array)] returns a circular varray using [Array] as its backend. 135 | The resulting varray has parameter [k = 1], meaning that [push] and [pop] 136 | at both ends is O(1) but random insertion and deletions are O(N). *) 137 | 138 | module Circular : S with type 'a array = 'a Array.t and type 'a elt = 'a 139 | 140 | (** [Circular] is a predefined circular varray using a polymorphic 141 | [Stdlib.Array]. *) 142 | 143 | module Root (V : S) : S with type 'a array = 'a V.array 144 | and type 'a elt = 'a V.elt 145 | (** [Root (Varray)] nests an existing [Varray] to improve the performances of 146 | random insertion and deletion. 147 | However, it does so at the price that random access and insertion and 148 | deletion at the ends will be a constant time slower! *) 149 | -------------------------------------------------------------------------------- /src/varray_sig.ml: -------------------------------------------------------------------------------- 1 | module type ARRAY = sig 2 | (** The array will be used partially, with some elements in an undefined 3 | state. It is guaranteed that all operations always use valid indexes. 4 | *) 5 | 6 | type 'a t 7 | (** The type of an array. *) 8 | 9 | type 'a elt 10 | (** The type of elements contained in the array. *) 11 | 12 | val length : 'a t -> int 13 | (** The size of the array; the maximum number of elements that can be stored 14 | inside. *) 15 | 16 | val empty : unit -> 'a t 17 | (** An empty array of length [0]. *) 18 | 19 | val create : int -> 'a t 20 | (** [create n] returns an array of length [n]. Its elements are all in 21 | an undefined state and will not be accessed by {! get} before being 22 | defined by {! set} or {! blit}. *) 23 | 24 | val get : 'a t -> int -> 'a elt 25 | (** [get t i] returns the [i]th element of the array. 26 | The elements are numbered from [0] to [length t - 1] and the index [i] is 27 | always within this bound: this function can be implemented as an 28 | [unsafe_get]) if available. *) 29 | 30 | val set : 'a t -> int -> 'a elt -> unit 31 | (** [set t i v] modifies [t] in place, replacing the element at position [i] 32 | with the value [v]. From now on, the element at this index is defined. 33 | Again, this can be implemented as an [unsafe_set] without bound checking. 34 | *) 35 | 36 | val erase_at : 'a t -> int -> unit 37 | (** [erase_at t i] resets the element at position [i]. It is an opportunity 38 | to free the memory of the value [t.(i)]. From now on, the element is 39 | undefined and this index will not be accessed again until a write is 40 | done. *) 41 | 42 | val blit : 'a t -> int -> 'a t -> int -> int -> unit 43 | (** [blit src i dst j n] copies the elements from the range [i,i+n-1] from 44 | the array [src] to the range [j,j+n-1] of the array [dst]. All the 45 | elements copied from [src] are guaranteed to be in a defined state. 46 | After this operation, the corresponding range in [dst] will be defined. 47 | The copied ranges will be valid for each array. Special care is required 48 | during the copy since [src] will often be the same array as [dst] and the 49 | ranges can overlap. *) 50 | end 51 | 52 | module type TIER = sig 53 | module Array : ARRAY 54 | type 'a elt = 'a Array.elt 55 | type 'a array = 'a Array.t 56 | 57 | type 'a t 58 | 59 | val depth : int 60 | 61 | val empty : unit -> 'a t 62 | val is_empty : 'a t -> bool 63 | val root_capacity : 'a t -> int 64 | 65 | val create : capacity:int -> 'a t 66 | val make : lc:int -> int -> 'a elt -> 'a t 67 | val init : lc:int -> offset:int -> int -> (int -> 'a elt) -> 'a t 68 | 69 | val length : 'a t -> int 70 | val capacity : lc:int -> int 71 | 72 | val get : lc:int -> 'a t -> int -> 'a elt 73 | val set : lc:int -> 'a t -> int -> 'a elt -> unit 74 | 75 | val pop_front : lc:int -> 'a t -> 'a elt 76 | val pop_back : lc:int -> 'a t -> 'a elt 77 | val pop_at : lc:int -> 'a t -> int -> 'a elt 78 | 79 | val push_front : lc:int -> 'a t -> 'a elt -> unit 80 | val push_back : lc:int -> 'a t -> 'a elt -> unit 81 | 82 | val is_full : lc:int -> 'a t -> bool 83 | 84 | val push_front_pop_back : lc:int -> 'a t -> 'a elt -> 'a elt 85 | val push_back_pop_front : lc:int -> 'a t -> 'a elt -> 'a elt 86 | 87 | val insert_at : lc:int -> 'a t -> int -> 'a elt -> unit 88 | end 89 | 90 | module type VARRAY = sig 91 | type 'a t 92 | type 'a elt 93 | type 'a array 94 | 95 | val push_back : 'a t -> 'a elt -> unit 96 | val pop_back : 'a t -> 'a elt 97 | 98 | val push_front : 'a t -> 'a elt -> unit 99 | val pop_front : 'a t -> 'a elt 100 | 101 | val insert_at : 'a t -> int -> 'a elt -> unit 102 | val pop_at : 'a t -> int -> 'a elt 103 | val delete_at : 'a t -> int -> unit 104 | 105 | val get : 'a t -> int -> 'a elt 106 | val set : 'a t -> int -> 'a elt -> unit 107 | 108 | val length : 'a t -> int 109 | val make : int -> 'a elt -> 'a t 110 | val init : int -> (int -> 'a elt) -> 'a t 111 | val empty : unit -> 'a t 112 | val is_empty : 'a t -> bool 113 | 114 | val protect : 'a t -> (unit -> 'b) -> 'b 115 | 116 | module Tier : TIER with type 'a Array.elt = 'a elt 117 | and type 'a Array.t = 'a array 118 | end 119 | 120 | module type S = sig 121 | 122 | type 'a t 123 | (** The type of a varray. *) 124 | 125 | type 'a elt 126 | (** The type of elements stored in the varray. *) 127 | 128 | (** {1 Dynamic collection} *) 129 | 130 | val push_back : 'a t -> 'a elt -> unit 131 | (** [push_back t x] adds a new element [x] at the end of the varray [t]. 132 | {b O(k)} amortized. *) 133 | 134 | val pop_back : 'a t -> 'a elt 135 | (** [pop_back t] removes and returns the rightmost element of the varray [t]. 136 | {b O(k)} amortized. *) 137 | 138 | val push_front : 'a t -> 'a elt -> unit 139 | (** [push_front t x] inserts a new element [x] at position [0], on the left 140 | side of the varray [t]. Every previous element of [t] is shifted one to 141 | the right. {b O(k)} amortized. *) 142 | 143 | val pop_front : 'a t -> 'a elt 144 | (** [pop_front t] removes and returns the leftmost element at position [0] of 145 | the varray [t]. Every element of [t] is shifted one to the right. 146 | {b O(k)} amortized. *) 147 | 148 | val insert_at : 'a t -> int -> 'a elt -> unit 149 | (** [insert_at t i x] inserts the element [x] at position [i] in the varray 150 | [t]. Every element on the right of [i] is shifted by one. 151 | {b O(k² × {%html:k%}√N)} 152 | 153 | - [insert_at t 0 x] is the same as [push_front t x] 154 | - [insert_at t (length t) x] is the same as [push_back t x] 155 | 156 | @raise Invalid_argument if [i] is negative or larger than [length t]. 157 | *) 158 | 159 | val pop_at : 'a t -> int -> 'a elt 160 | (** [pop_at t i] removes and returns the element [t.(i)]. Every element on 161 | the right of [i] is shifted by one to the left. 162 | {b O(k² × {%html:k%}√N)} 163 | 164 | - [pop_at t 0] is the same as [pop_front t] 165 | - [pop_at t (length t - 1)] is the same as [pop_back t] 166 | 167 | @raise Invalid_argument if [i] is negative or larger than [length t - 1]. 168 | *) 169 | 170 | val delete_at : 'a t -> int -> unit 171 | (** [delete_at t i] removes the element [t.(i)]. Every element on the right 172 | of [i] is shifted by one to the left. 173 | {b O(k² × {%html:k%}√N)} 174 | 175 | @raise Invalid_argument if [i] is negative or larger than [length t - 1]. 176 | *) 177 | 178 | (** {1 Freeze during traversals} *) 179 | 180 | (** The previous operations all fail when the varray is being traversed: *) 181 | 182 | val protect : 'a t -> (unit -> 'b) -> 'b 183 | (** [protect t fn] marks [t] as protected during the execution of [fn ()]. 184 | All operations that would update the length of [t] by pushing or poping 185 | elements will raise a [Failure] indicating that the traversal is unsafe. 186 | *) 187 | 188 | (** {1 Array} *) 189 | 190 | val get : 'a t -> int -> 'a elt 191 | (** [get t i] returns the [i]th element of the varray. Indexing starts from 192 | [0] upto [length t - 1]. {b O(k)} 193 | 194 | @raise Invalid_argument if [i] is negative 195 | or larger than [length t - 1]. 196 | *) 197 | 198 | val set : 'a t -> int -> 'a elt -> unit 199 | (** [set t i v] updates the value of the [i]th element to [x]. {b O(k)} 200 | 201 | @raise Invalid_argument if [i] is negative 202 | or larger than [length t - 1]. 203 | *) 204 | 205 | val length : 'a t -> int 206 | (** [length t] returns the number of elements stored in [t]. {b O(1)} *) 207 | 208 | val make : int -> 'a elt -> 'a t 209 | (** [make n x] returns a new varray of length [n], where all the elements are 210 | initialized to the value [x]. 211 | 212 | @raise Invalid_argument if [n] is negative. 213 | *) 214 | 215 | val init : int -> (int -> 'a elt) -> 'a t 216 | (** [init n f] returns a new array of length [n], where the element at 217 | position [i] is initialized to [f i]. 218 | 219 | @raise Invalid_argument if [n] is negative. 220 | *) 221 | 222 | val empty : unit -> 'a t 223 | (** [empty ()] is a new varray of length [0]. *) 224 | 225 | val is_empty : 'a t -> bool 226 | (** [is_empty t] returns true when the varray [t] has length [0]. *) 227 | 228 | (** {1 Copying elements} *) 229 | 230 | val append : 'a t -> 'a t -> 'a t 231 | (** [append a b] returns a new varray by concatening the elements of [a] with 232 | those of [b]. *) 233 | 234 | val concat : 'a t list -> 'a t 235 | (** [concat ts] returns a new varray whose elements are in the same order as 236 | the values from the list of varrays [ts]. *) 237 | 238 | val sub : 'a t -> int -> int -> 'a t 239 | (** [sub t i n] returns a new varray of length [n], containing the elements 240 | from the range [i, i+n-1] of the varray [t]. 241 | 242 | @raise Invalid_argument if the range [i, i + n - 1] is invalid for [t]. 243 | *) 244 | 245 | val copy : 'a t -> 'a t 246 | (** [copy t] returns a new varray containing the same sequence of 247 | elements as [t]. *) 248 | 249 | val fill : 'a t -> int -> int -> 'a elt -> unit 250 | (** [fill t pos len x] modifies the varray [t] in place, by setting the value 251 | [x] in the range [pos, pos + len - 1]. 252 | 253 | @raise Invalid_argument if the range [pos, pos + len -1] is invalid. 254 | *) 255 | 256 | val blit : 'a t -> int -> 'a t -> int -> int -> unit 257 | (** [blit src src_pos dst dst_pos len] updates the varray [dst] in place, by 258 | copying the range [src_pos, src_pos + len - 1] of values from [src] into 259 | the destination range [dst_pos, dst_pos + len - 1] of [dst]. 260 | 261 | @raise Invalid_argument if the ranges are invalid for either varray. 262 | *) 263 | 264 | (** {1 Traversals} *) 265 | 266 | val iter : ('a elt -> unit) -> 'a t -> unit 267 | (** [iter f t] calls the function [f] on all elements of [t], from left to 268 | right. *) 269 | 270 | val iteri : (int -> 'a elt -> unit) -> 'a t -> unit 271 | (** [iteri f t] calls [f i t.(i)] on all the indexes [i] of [t], 272 | from left to right. *) 273 | 274 | val map : ('a elt -> 'b elt) -> 'a t -> 'b t 275 | (** [map f t] returns a new varray, whose elements are [f x] for each [x] 276 | from the varray [t]. *) 277 | 278 | val mapi : (int -> 'a elt -> 'b elt) -> 'a t -> 'b t 279 | (** [mapi f t] returns a new varray, whose elements are [f i t.(i)] for each 280 | index [i] of the varray [t]. *) 281 | 282 | val fold_left : ('a -> 'b elt -> 'a) -> 'a -> 'b t -> 'a 283 | (** [fold_left f z t] computes 284 | [f (... (f (f z t.(0)) t.(1)) ...) t.(length t - 1)]. *) 285 | 286 | val fold_right : ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b 287 | (** [fold_right f t z] computes 288 | [f t.(0) (f t.(1) (... (f z t.(length t - 1))))]. *) 289 | 290 | val fold_left_map : ('a -> 'b elt -> 'a * 'c elt) -> 'a -> 'b t -> 'a * 'c t 291 | (** [fold_left_map] is a combination of [fold_left] and [map], 292 | that threads an accumulator. *) 293 | 294 | (** {1 Iterators on two varrays} *) 295 | 296 | val iter2 : ('a elt -> 'b elt -> unit) -> 'a t -> 'b t -> unit 297 | (** [iter2 f xs ys] calls [f xs.(i) ys.(i)] for each index [i] from left to 298 | right. 299 | 300 | @raise Invalid_argument if the two varrays have different lengths. 301 | *) 302 | 303 | val map2 : ('a elt -> 'b elt -> 'c elt) -> 'a t -> 'b t -> 'c t 304 | (** [map2 f xs ys] returns a new varray whose [i]th element is 305 | [f xs.(i) ys.(i)]. 306 | 307 | @raise Invalid_argument if the two varrays have different lengths. 308 | *) 309 | 310 | (** {1 Predicates} *) 311 | 312 | val for_all : ('a elt -> bool) -> 'a t -> bool 313 | (** [for_all f t] holds when [f] is satisfied by all the elements of [t]. *) 314 | 315 | val for_all2 : ('a elt -> 'b elt -> bool) -> 'a t -> 'b t -> bool 316 | (** [for_all2 f xs ys] holds when [f xs.(i) ys.(i)] is satisfied by all 317 | indexes [i]. 318 | 319 | @raise Invalid_argument if the two varrays have different lengths. 320 | *) 321 | 322 | val exists : ('a elt -> bool) -> 'a t -> bool 323 | (** [exists f t] holds when [f] is satisfied by one of the elements of 324 | [t]. *) 325 | 326 | val exists2 : ('a elt -> 'b elt -> bool) -> 'a t -> 'b t -> bool 327 | (** [exists2 f xs ys] holds when an index [i] exists such that 328 | [f xs.(i) ys.(i)] is satisfied. 329 | 330 | @raise Invalid_argument if the two varrays have different lengths. 331 | *) 332 | 333 | val find_opt : ('a elt -> bool) -> 'a t -> 'a elt option 334 | (** [find_opt f t] returns the leftmost element of [t] that satisfies [f]. *) 335 | 336 | val find_map : ('a elt -> 'b option) -> 'a t -> 'b option 337 | (** [find_map f t] returns the first result of [f] of the form [Some v]. *) 338 | 339 | val mem : 'a elt -> 'a t -> bool 340 | (** [mem x t] is true when [x] is equal [( = )] to an element of the varray 341 | [t]. *) 342 | 343 | val memq : 'a elt -> 'a t -> bool 344 | (** Same as [mem], but [memq x t] uses physical equality [( == )] for 345 | comparison. *) 346 | 347 | (** {1 Sort} *) 348 | 349 | val sort : ('a elt -> 'a elt -> int) -> 'a t -> unit 350 | (** [sort cmp t] updates [t] inplace by sorting the elements in increasing 351 | order according to [cmp]. *) 352 | 353 | val stable_sort : ('a elt -> 'a elt -> int) -> 'a t -> unit 354 | (** Same as [sort], but equal elements are kept in the same relative 355 | order. *) 356 | 357 | val fast_sort : ('a elt -> 'a elt -> int) -> 'a t -> unit 358 | (** Same as [sort]. *) 359 | 360 | (** {1 Conversions} *) 361 | 362 | type 'a array 363 | (** The array type used behind the scene as a backend by the varray. *) 364 | 365 | val of_array : 'a array -> 'a t 366 | (** [of_array arr] returns a new varray containing all the elements of the 367 | array [arr]. *) 368 | 369 | val to_array : 'a t -> 'a array 370 | (** [to_array t] returns a new array containing all the elements of the 371 | varray [t]. *) 372 | 373 | val of_list : 'a elt list -> 'a t 374 | (** [of_list xs] returns a new varray containing all the elements of the list 375 | [xs]. *) 376 | 377 | val to_list : 'a t -> 'a elt list 378 | (** [to_list t] returns a list of all the elements of [t]. *) 379 | end 380 | -------------------------------------------------------------------------------- /tests/array_like_test.ml: -------------------------------------------------------------------------------- 1 | let make_f () = 2 | let calls = ref [] in 3 | let f x = 4 | calls := x :: !calls ; 5 | x 6 | in 7 | f, calls 8 | 9 | let make_fs () = 10 | let f, fc = make_f () in 11 | let g, gc = make_f () in 12 | let check () = 13 | if !fc <> !gc then failwith "different call order" ; 14 | !fc = [] 15 | in 16 | f, g, check 17 | 18 | let test name fn = 19 | try fn () ; 20 | Printf.printf "OK %s\n%!" name 21 | with err -> 22 | Printf.fprintf stderr "ERROR %s\n%s\n%!" name (Printexc.to_string err) ; 23 | Printexc.print_backtrace stderr ; 24 | raise err 25 | 26 | module Test (V : Varray.S with type 'a elt = 'a and type 'a array = 'a Array.t) 27 | = struct 28 | 29 | let () = Random.self_init () 30 | 31 | let random_array size = 32 | let t = V.empty () in 33 | for _ = 1 to size do 34 | let x = Random.bits () in 35 | if Random.bool () 36 | then V.push_front t x 37 | else V.push_back t x 38 | done ; 39 | let nb = 1_000 in 40 | for _ = 1 to nb do 41 | let x = Random.bits () in 42 | if Random.bool () 43 | then V.push_front t x 44 | else V.push_back t x 45 | done ; 46 | assert (V.length t = size + nb) ; 47 | let j = Random.int (V.length t + 1) in 48 | for _ = 1 to nb do 49 | let x = Random.bits () in 50 | V.insert_at t j x 51 | done ; 52 | assert (V.length t = size + 2 * nb) ; 53 | for _ = 1 to nb do 54 | let j = Random.int (V.length t + 1) in 55 | let x = Random.bits () in 56 | V.insert_at t j x 57 | done ; 58 | assert (V.length t = size + 3 * nb) ; 59 | for _ = 1 to nb do 60 | if Random.bool () 61 | then ignore (V.pop_front t) 62 | else ignore (V.pop_back t) 63 | done ; 64 | assert (V.length t = size + 2 * nb) ; 65 | for _ = 1 to 2 * nb do 66 | let j = Random.int (V.length t) in 67 | V.delete_at t j 68 | done ; 69 | assert (V.length t = size) ; 70 | t, V.to_array t 71 | 72 | let with_random_array f = 73 | List.iter 74 | (fun s -> f (random_array s)) 75 | [ 0 ; 10 ; 100 ; 1000 ] 76 | 77 | let catch f = match f () with 78 | | _ -> None 79 | | exception e -> Some e 80 | 81 | let () = test "get" @@ fun () -> 82 | with_random_array @@ fun (t, arr) -> 83 | let n = Array.length arr in 84 | for i = 0 to n - 1 do 85 | assert (arr.(i) = V.get t i) 86 | done ; 87 | let arr_exn = catch @@ fun () -> arr.(-1) in 88 | let var_exn = catch @@ fun () -> V.get t (-1) in 89 | assert (arr_exn = var_exn) ; 90 | let arr_exn = catch @@ fun () -> arr.(n) in 91 | let var_exn = catch @@ fun () -> V.get t n in 92 | assert (arr_exn = var_exn) 93 | 94 | let () = test "set" @@ fun () -> 95 | with_random_array @@ fun (t, arr) -> 96 | let n = Array.length arr in 97 | for _ = 0 to n - 1 do 98 | let j = Random.int n in 99 | let x = Random.bits () in 100 | arr.(j) <- x ; 101 | V.set t j x 102 | done ; 103 | assert (arr = V.to_array t) ; 104 | let arr_exn = catch @@ fun () -> arr.(-1) <- 0 in 105 | let var_exn = catch @@ fun () -> V.set t (-1) 0 in 106 | assert (arr_exn = var_exn) ; 107 | let arr_exn = catch @@ fun () -> arr.(n) <- 0 in 108 | let var_exn = catch @@ fun () -> V.set t n 0 in 109 | assert (arr_exn = var_exn) 110 | 111 | let () = test "length" @@ fun () -> 112 | with_random_array @@ fun (t, arr) -> 113 | let n = V.length t in 114 | assert (n = Array.length arr) ; 115 | V.push_front t 0 ; 116 | assert (V.length t = n + 1) ; 117 | V.push_back t 0 ; 118 | assert (V.length t = n + 2) ; 119 | let _ = V.pop_front t in 120 | assert (V.length t = n + 1) ; 121 | let _ = V.pop_back t in 122 | assert (V.length t = n) ; 123 | assert (V.to_array t = arr) 124 | 125 | let () = test "init" @@ fun () -> 126 | let f, g, check = make_fs () in 127 | List.iter 128 | (fun size -> 129 | let t = V.init size f in 130 | let arr = Array.init size g in 131 | assert (V.to_array t = arr) ; 132 | assert ((size = 0) = check ())) 133 | [ 0 ; 10 ; 100 ; 1000 ] 134 | 135 | let () = test "empty" @@ fun () -> 136 | let t = V.empty () in 137 | assert (V.is_empty t) ; 138 | assert (V.length t = 0) ; 139 | assert (V.to_array t = [| |]) 140 | 141 | let pr_array t = 142 | Printf.printf "<%i> " (Array.length t) ; 143 | Array.iter (Printf.printf " %i") t 144 | 145 | let () = test "copy" @@ fun () -> 146 | with_random_array @@ fun (t0, arr0) -> 147 | let t1 = V.copy t0 in 148 | let arr1 = Array.copy arr0 in 149 | for i = 0 to V.length t1 - 1 do 150 | V.set t1 i (- i) ; 151 | Array.set arr1 i (- i) ; 152 | done ; 153 | assert (V.to_array t0 = arr0) ; 154 | assert (V.to_array t1 = arr1) 155 | 156 | let () = test "append" @@ fun () -> 157 | with_random_array @@ fun (t0, arr0) -> 158 | with_random_array @@ fun (t1, arr1) -> 159 | let t01 = V.append t0 t1 in 160 | let arr01 = Array.append arr0 arr1 in 161 | assert (V.length t01 = Array.length arr01) ; 162 | assert (V.to_array t01 = arr01) ; 163 | for i = 0 to V.length t01 - 1 do 164 | V.set t01 i (- i) 165 | done ; 166 | assert (V.to_array t0 = arr0) ; 167 | assert (V.to_array t1 = arr1) 168 | 169 | let () = test "concat + sub" @@ fun () -> 170 | with_random_array @@ fun (t, arr) -> 171 | let n = V.length t in 172 | let rec make_parts i = 173 | if i >= n 174 | then [] 175 | else let size = Random.int (n - i + 1) in 176 | let t = V.sub t i size in 177 | let arr = Array.sub arr i size in 178 | (t, arr) :: make_parts (i + size) 179 | in 180 | let ts, arrs = List.split @@ make_parts 0 in 181 | assert (Array.concat arrs = arr) ; 182 | assert (V.to_array (V.concat ts) = arr) ; 183 | let ts, arrs = List.rev ts, List.rev arrs in 184 | assert (V.to_array (V.concat ts) = Array.concat arrs) 185 | 186 | let () = test "fill" @@ fun () -> 187 | with_random_array @@ fun (t, arr) -> 188 | let len = V.length t in 189 | if len > 0 190 | then begin 191 | for step = 0 to 100 do 192 | let i = Random.int len in 193 | let s = Random.int (len - i) in 194 | V.fill t i s step ; 195 | Array.fill arr i s step ; 196 | assert (V.to_array t = arr) 197 | done 198 | end ; 199 | 200 | let et = catch @@ fun () -> V.fill t 0 (-1) 42 in 201 | let at = catch @@ fun () -> Array.fill arr 0 (-1) 42 in 202 | assert (et = Some (Invalid_argument "Varray.fill")) ; 203 | assert (at = Some (Invalid_argument "Array.fill")) ; 204 | 205 | let et = catch @@ fun () -> V.fill t (len + 1) 0 42 in 206 | let at = catch @@ fun () -> Array.fill arr (len + 1) 0 42 in 207 | assert (et = Some (Invalid_argument "Varray.fill")) ; 208 | assert (at = Some (Invalid_argument "Array.fill")) ; 209 | 210 | let et = catch @@ fun () -> V.fill t 1 len 42 in 211 | let at = catch @@ fun () -> Array.fill arr 1 len 42 in 212 | assert (et = Some (Invalid_argument "Varray.fill")) ; 213 | assert (at = Some (Invalid_argument "Array.fill")) ; 214 | 215 | assert (V.to_array t = arr) 216 | 217 | let () = test "blit" @@ fun () -> 218 | with_random_array @@ fun (t0, arr0) -> 219 | with_random_array @@ fun (t1, arr1) -> 220 | let size = Random.int (1 + min (V.length t0) (V.length t1)) in 221 | let src_pos = Random.int (1 + V.length t0 - size) in 222 | let dst_pos = Random.int (1 + V.length t1 - size) in 223 | V.blit t0 src_pos t1 dst_pos size ; 224 | Array.blit arr0 src_pos arr1 dst_pos size ; 225 | assert (V.to_array t1 = arr1) ; 226 | 227 | let et = catch @@ fun () -> V.blit t0 (-1) t1 0 0 in 228 | let at = catch @@ fun () -> Array.blit arr0 (-1) arr1 0 0 in 229 | assert (et = Some (Invalid_argument "Varray.blit")) ; 230 | assert (at = Some (Invalid_argument "Array.blit")) ; 231 | 232 | let et = catch @@ fun () -> V.blit t0 0 t1 (-1) 0 in 233 | let at = catch @@ fun () -> Array.blit arr0 0 arr1 (-1) 0 in 234 | assert (et = Some (Invalid_argument "Varray.blit")) ; 235 | assert (at = Some (Invalid_argument "Array.blit")) ; 236 | 237 | let et = catch @@ fun () -> V.blit t0 0 t1 0 (-1) in 238 | let at = catch @@ fun () -> Array.blit arr0 0 arr1 0 (-1) in 239 | assert (et = Some (Invalid_argument "Varray.blit")) ; 240 | assert (at = Some (Invalid_argument "Array.blit")) ; 241 | 242 | let len1, len0 = V.length t1, V.length t0 in 243 | let et = catch @@ fun () -> V.blit t0 0 t1 len1 len0 in 244 | let at = catch @@ fun () -> Array.blit arr0 0 arr1 len1 len0 in 245 | let fail = not (V.is_empty t0) in 246 | assert (fail = (at = Some (Invalid_argument "Array.blit"))) ; 247 | assert (fail = (et = Some (Invalid_argument "Varray.blit"))) ; 248 | 249 | assert (V.to_array t0 = arr0) ; 250 | assert (V.to_array t1 = arr1) 251 | 252 | let () = test "to_list + of_list" @@ fun () -> 253 | with_random_array @@ fun (t, arr) -> 254 | let xs = V.to_list t in 255 | let ys = Array.to_list arr in 256 | assert (xs = ys) ; 257 | let t' = V.of_list xs in 258 | let arr' = Array.of_list ys in 259 | assert (arr = arr') ; 260 | assert (t <> t') ; 261 | assert (V.to_array t' = arr') ; 262 | assert (V.for_all2 ( == ) t t') 263 | 264 | let () = test "iter" @@ fun () -> 265 | with_random_array @@ fun (t, arr) -> 266 | let f, g, check = make_fs () in 267 | V.iter (fun x -> ignore (f x)) t ; 268 | Array.iter (fun x -> ignore (g x)) arr ; 269 | assert (V.is_empty t = check ()) 270 | 271 | let () = test "iteri" @@ fun () -> 272 | with_random_array @@ fun (t, arr) -> 273 | let f, g, check = make_fs () in 274 | V.iteri (fun i x -> ignore (f (i, x))) t ; 275 | Array.iteri (fun i x -> ignore (g (i, x))) arr ; 276 | assert (V.is_empty t = check ()) 277 | 278 | let () = test "map" @@ fun () -> 279 | with_random_array @@ fun (t, arr) -> 280 | let f, g, check = make_fs () in 281 | let t' = V.map f t in 282 | let arr' = Array.map g arr in 283 | assert (V.to_array t' = arr') ; 284 | assert (V.is_empty t = check ()) 285 | 286 | let () = test "mapi" @@ fun () -> 287 | with_random_array @@ fun (t, arr) -> 288 | let f, g, check = make_fs () in 289 | let t' = V.mapi (fun i x -> f (i, x)) t in 290 | let arr' = Array.mapi (fun i x -> g (i, x)) arr in 291 | assert (V.to_array t' = arr') ; 292 | assert (V.is_empty t = check ()) 293 | 294 | let () = test "fold_left" @@ fun () -> 295 | with_random_array @@ fun (t, arr) -> 296 | let f, g, check = make_fs () in 297 | let f acc x = ignore (f (acc, x)) ; x in 298 | let x = V.fold_left f min_int t in 299 | let g acc x = ignore (g (acc, x)) ; x in 300 | let y = Array.fold_left g min_int arr in 301 | assert (x = y) ; 302 | assert (x = if V.is_empty t then min_int else V.get t (V.length t - 1)) ; 303 | assert (V.is_empty t = check ()) 304 | 305 | let () = test "fold_right" @@ fun () -> 306 | with_random_array @@ fun (t, arr) -> 307 | let f, g, check = make_fs () in 308 | let f x acc = ignore (f (acc, x)) ; x in 309 | let x = V.fold_right f t min_int in 310 | let g x acc = ignore (g (acc, x)) ; x in 311 | let y = Array.fold_right g arr min_int in 312 | assert (x = y) ; 313 | assert (x = if V.is_empty t then min_int else V.get t 0) ; 314 | assert (V.is_empty t = check ()) 315 | 316 | let () = test "fold_left_map" @@ fun () -> 317 | with_random_array @@ fun (t, _arr) -> 318 | (* requires ocaml 4.13.0 *) 319 | (* let f, g, check = make_fs () in *) 320 | let f acc x = (* ignore (f (acc, x)) ; *) x, acc in 321 | let x, t' = V.fold_left_map f min_int t in 322 | assert (x = if V.is_empty t then min_int else V.get t (V.length t - 1)) ; 323 | (* 324 | let g acc x = ignore (g (acc, x)) ; x, acc in 325 | let y, arr' = Array.fold_left_map g min_int arr in 326 | assert (x = y) ; 327 | assert (V.is_empty t = check ()) ; 328 | assert (V.to_array t' = arr') ; 329 | assert (V.is_empty t = check ()) ; 330 | *) 331 | V.push_front t min_int ; 332 | let _ = V.pop_back t in 333 | assert (V.to_array t = V.to_array t') 334 | 335 | let () = test "index_out_of_bounds" @@ fun () -> 336 | with_random_array @@ fun (t, _arr) -> 337 | let is_invalid fn = 338 | match fn () with 339 | | exception Invalid_argument _ -> () 340 | | _ -> failwith "expected Invalid_argument exception" 341 | in 342 | is_invalid (fun () -> V.make (-1) 42) ; 343 | is_invalid (fun () -> V.get t (-1)) ; 344 | is_invalid (fun () -> V.get t (V.length t)) ; 345 | is_invalid (fun () -> V.set t (-1) 42) ; 346 | is_invalid (fun () -> V.set t (V.length t) 42) ; 347 | is_invalid (fun () -> V.pop_at t (-1)) ; 348 | is_invalid (fun () -> V.pop_at t (V.length t)) ; 349 | is_invalid (fun () -> V.delete_at t (-1)) ; 350 | is_invalid (fun () -> V.delete_at t (V.length t)) ; 351 | is_invalid (fun () -> V.insert_at t (-1) 42) ; 352 | is_invalid (fun () -> V.insert_at t (V.length t + 1) 42) ; 353 | is_invalid (fun () -> V.blit t (-1) t 0 1) ; 354 | is_invalid (fun () -> V.blit t 0 t (-1) 1) ; 355 | is_invalid (fun () -> V.blit t 0 t 0 (-1)) ; 356 | is_invalid (fun () -> V.blit t 0 t 0 (V.length t + 1)) ; 357 | is_invalid (fun () -> V.blit t 1 t 0 (V.length t)) ; 358 | is_invalid (fun () -> V.blit t 0 t 1 (V.length t)) ; 359 | is_invalid (fun () -> V.sub t 1 (V.length t)) ; 360 | is_invalid (fun () -> V.sub t (-1) 1) ; 361 | is_invalid (fun () -> V.sub t (V.length t) 1) ; 362 | is_invalid (fun () -> V.sub t (V.length t + 1) 0) ; 363 | assert (V.length (V.sub t 0 0) = 0) ; 364 | assert (V.length (V.sub t (V.length t) 0) = 0) ; 365 | is_invalid (fun () -> V.fill t 1 (V.length t) 42) ; 366 | is_invalid (fun () -> V.fill t (-1) 1 42) ; 367 | is_invalid (fun () -> V.fill t (V.length t) 1 42) ; 368 | is_invalid (fun () -> V.fill t (V.length t + 1) 0 42) 369 | end 370 | 371 | let header i = Printf.printf "------------ V%i ------------\n%!" i 372 | 373 | open Varray 374 | 375 | let () = header 1 376 | module V1 = Circular 377 | module T1 = Test (V1) 378 | 379 | let () = header 2 380 | module V2 = Root (V1) 381 | module T2 = Test (V2) 382 | 383 | let () = header 3 384 | module V3 = Root (V2) 385 | module T3 = Test (V3) 386 | 387 | let () = header 4 388 | module V4 = Root (V3) 389 | module T4 = Test (V4) 390 | 391 | let () = header 5 392 | module V5 = Root (V4) 393 | module T5 = Test (V5) 394 | 395 | let () = header 6 396 | module V6 = Root (V5) 397 | module T6 = Test (V6) 398 | 399 | let () = header 7 400 | module V7 = Root (V6) 401 | module T7 = Test (V7) 402 | -------------------------------------------------------------------------------- /tests/bench_access.ml: -------------------------------------------------------------------------------- 1 | let size = 1_000_000 2 | let input = Array.init size (fun i -> i) 3 | 4 | let bench f = 5 | let t0 = Unix.gettimeofday () in 6 | ignore (f ()) ; 7 | let t1 = Unix.gettimeofday () in 8 | t1 -. t0 9 | 10 | module type ARRAY = sig 11 | type 'a t 12 | val get : 'a t -> int -> 'a 13 | val set : 'a t -> int -> 'a -> unit 14 | val length : 'a t -> int 15 | val of_array : 'a array -> 'a t 16 | end 17 | 18 | let bench_get (module Array : ARRAY) = 19 | let t = Array.of_array input in 20 | let len = Array.length t in 21 | let expected = len * (len - 1) / 2 in 22 | bench begin fun () -> 23 | let total = ref 0 in 24 | for i = 0 to len - 1 do 25 | total := !total + t.(i) 26 | done ; 27 | assert (!total = expected) 28 | end 29 | 30 | let bench_set (module Array : ARRAY) = 31 | let t = Array.of_array input in 32 | bench begin fun () -> 33 | for i = 0 to Array.length t - 1 do 34 | t.(i) <- i 35 | done 36 | end 37 | 38 | module Stdarray = struct include Array let of_array t = t end 39 | module V1 = Varray.Circular 40 | module V2 = Varray.Root (V1) 41 | module V3 = Varray.Root (V2) 42 | module V4 = Varray.Root (V3) 43 | module V5 = Varray.Root (V4) 44 | module V6 = Varray.Root (V5) 45 | 46 | let all = 47 | [ (module Stdarray : ARRAY) 48 | ; (module V1 : ARRAY) 49 | ; (module V2 : ARRAY) 50 | ; (module V3 : ARRAY) 51 | ; (module V4 : ARRAY) 52 | ; (module V5 : ARRAY) 53 | ; (module V6 : ARRAY) 54 | ] 55 | 56 | let results_get = List.map bench_get all 57 | let results_set = List.map bench_set all 58 | 59 | let table column results = 60 | let base = List.hd results in 61 | let norm x = x /. base in 62 | List.iteri 63 | (fun i dt -> 64 | let s = Printf.sprintf " %.0fx " (norm dt) in 65 | let missing = String.length column.(i + 1) - String.length s in 66 | let padding = String.make missing ' ' in 67 | Printf.printf "%s%s|" padding s 68 | ) 69 | results ; 70 | Printf.printf "\n%!" 71 | 72 | let () = 73 | let columns = 74 | Array.init (1 + List.length all) 75 | (function 76 | | 0 -> " " 77 | | 1 -> " Array " 78 | | 2 -> " Circular " 79 | | 3 -> " Root " 80 | | n -> Printf.sprintf " Root%i " (n - 2)) 81 | in 82 | Array.iter (Printf.printf "|%s") columns ; 83 | Printf.printf "|\n%!" ; 84 | Array.iter 85 | (fun n -> 86 | let len = String.length n - 1 in 87 | Printf.printf "|%s:" (String.make len '-')) 88 | columns ; 89 | Printf.printf "|\n%!" ; 90 | Printf.printf "| get |" ; 91 | table columns results_get ; 92 | Printf.printf "| set |" ; 93 | table columns results_set 94 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names array_like_test) 3 | (modules array_like_test) 4 | (libraries varray)) 5 | 6 | (executable 7 | (name bench_access) 8 | (modules bench_access) 9 | (libraries varray unix)) 10 | 11 | (executable 12 | (name exhaust) 13 | (modules exhaust) 14 | (libraries varray monolith)) 15 | -------------------------------------------------------------------------------- /tests/exhaust.ml: -------------------------------------------------------------------------------- 1 | (* module V = Varray *) 2 | module V = Varray.Root (Varray.Root (Varray.Circular)) 3 | 4 | (* 5 | module Naive = struct 6 | include Varray.Circular 7 | let check varray t = 8 | assert (length t = V.length varray) ; 9 | iteri (fun i v -> assert (V.get varray i = v)) t 10 | end 11 | *) 12 | 13 | module Naive = struct 14 | type 'a elt = 'a 15 | type 'a t = 'a list ref 16 | 17 | let check varray t = 18 | assert (List.length !t = V.length varray) ; 19 | List.iteri (fun i v -> assert (V.get varray i = v)) !t 20 | 21 | let make n x = ref (List.init n (fun _ -> x)) 22 | 23 | let push_front t x = t := x :: !t 24 | 25 | let push_back t x = t := !t @ [x] 26 | 27 | let pop_front t = match !t with 28 | | [] -> raise Not_found 29 | | x :: xs -> t := xs ; x 30 | 31 | let pop_back t = match List.rev !t with 32 | | [] -> raise Not_found 33 | | x :: xs -> t := List.rev xs ; x 34 | 35 | let insert_at t i x = 36 | let rec go i = function 37 | | xs when i = 0 -> x :: xs 38 | | x :: xs -> x :: go (i - 1) xs 39 | | [] -> invalid_arg "index out of bounds" 40 | in 41 | t := go i !t 42 | 43 | let pop_at t i = 44 | let rec go acc i = function 45 | | [] -> invalid_arg "index out of bounds" 46 | | x :: xs when i = 0 -> x, List.rev_append acc xs 47 | | x :: xs -> go (x::acc) (i - 1) xs 48 | in 49 | let elt, xs = go [] i !t in 50 | t := xs ; 51 | elt 52 | end 53 | 54 | open Monolith 55 | 56 | let element = sequential () 57 | 58 | let check model = Naive.check model, constant "check" 59 | 60 | let varray = declare_abstract_type ~check () 61 | 62 | let length = le 1024 63 | 64 | let () = 65 | let spec = length ^> element ^> varray in 66 | declare "make" spec V.make Naive.make ; 67 | 68 | let spec = varray ^!> element in 69 | declare "pop_front" spec V.pop_front Naive.pop_front ; 70 | declare "pop_back" spec V.pop_back Naive.pop_back ; 71 | 72 | let spec = varray ^> element ^> unit in 73 | declare "push_front" spec V.push_front Naive.push_front ; 74 | declare "push_back" spec V.push_back Naive.push_back ; 75 | 76 | let spec = varray ^>> (fun v -> lt (V.length v) ^> element) in 77 | declare "pop_at" spec V.pop_at Naive.pop_at ; 78 | 79 | let spec = varray ^>> (fun v -> le (V.length v) ^> element ^> unit) in 80 | declare "insert_at" spec V.insert_at Naive.insert_at ; 81 | 82 | main 5 83 | -------------------------------------------------------------------------------- /varray.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.2" 4 | synopsis: "Resizable arrays with fast insertion/deletion" 5 | description: """ 6 | 7 | - O(1) constant time for random access `arr.(i)` and updates `arr.(i) <- v` 8 | - O(1) amortized for `push_front` and `pop_front`, `push_back` and `pop_back` to add or remove an element to the start or the end 9 | - O(sqrt N) for `insert_at arr i x` and `delete_at arr i` to insert or delete an element anywhere else 10 | 11 | This datastructure was invented by Goodrich and Kloss and is described in their paper "Tiered Vectors: Efficient Dynamic Arrays for Rank-Based Sequences".""" 12 | maintainer: ["art.wendling@gmail.com"] 13 | authors: ["Arthur Wendling"] 14 | license: "MIT" 15 | homepage: "https://github.com/art-w/varray" 16 | bug-reports: "https://github.com/art-w/varray/issues" 17 | depends: [ 18 | "dune" {>= "2.8"} 19 | "ocaml" {>= "4.08"} 20 | "monolith" {with-test} 21 | "odoc" {with-doc} 22 | ] 23 | build: [ 24 | ["dune" "subst"] {dev} 25 | [ 26 | "dune" 27 | "build" 28 | "-p" 29 | name 30 | "-j" 31 | jobs 32 | "@install" 33 | "@runtest" {with-test} 34 | "@doc" {with-doc} 35 | ] 36 | ] 37 | dev-repo: "git+https://github.com/art-w/varray.git" 38 | --------------------------------------------------------------------------------