Commits

Anonymous committed e4a4855

sorted arrays: moved from amall

Comments (0)

Files changed (2)

src/sortedArray.ml

+(* реализация пока очень дубовая, но использует уже написанный код. *)
+
+module S = SortedArraySet.SortedArraySet
+;
+
+type t 'k = S.t 'k ('k * int)
+;
+
+value (create : ('k -> 'k -> int) -> array 'k -> t 'k) cmpf src =
+(*
+  let cmpf' = fun (a, _ai) (b, _bi) -> cmpf a b in
+*)
+  let src_copied = Array.copy src in
+  let () = Array.sort cmpf src_copied in
+  let src_copied_indexed = Array.mapi (fun i x -> (x, i)) src_copied in
+  let r = S.create fst cmpf in
+  ( S.replace_with_array r src_copied_indexed
+  ; r
+  )
+;
+
+value (lookup_index_opt : t 'k -> 'k -> option int) a k =
+  match S.lookup_opt a k with
+  [ None -> None
+  | Some (_k, i) -> Some i
+  ]
+;
+
+
+value get_keys = S.get_keys
+;

src/sortedArraySet.ml

+type cmpf 'k = 'k -> 'k -> int
+;
+
+
+module SortedArraySet
+ :
+  sig
+
+    type t 'k 'v
+    ;
+
+    value create : ('v -> 'k) -> cmpf 'k -> t 'k 'v
+    ;
+
+    (* True if operation was successful. *)
+    value add : t 'k 'v -> 'v -> bool
+    ;
+
+    (* True if operation was successful. *)
+    value remove : t 'k 'v -> 'v -> bool
+    ;
+
+    (* True if exists. *)
+    value mem : t 'k 'v -> 'v -> bool
+    ;
+
+    value mem_by_key : t 'k 'v -> 'k -> bool
+    ;
+
+    value lookup_opt : t 'k 'v -> 'k -> option 'v
+    ;
+
+    value fold : ('a -> 'k -> 'v -> 'a) -> 'a -> t 'k 'v -> 'a
+    ;
+
+    value replace_with_array : t 'k 'v -> array 'v -> unit
+    ;
+
+    value iter_diff :
+      ?only_first : ('k -> 'v1 -> unit) ->
+      ?only_second : ('k -> 'v2 -> unit) ->
+      ?both : ('k -> 'v1 -> 'v2 -> unit) ->
+      ~first : (t 'k 'v1) ->
+      ~second : (t 'k 'v2)
+      -> unit
+    ;
+
+    value get_keys : t 'k 'v -> array 'k
+    ;
+
+  end
+ =
+  struct
+
+    type t 'k 'v =
+      { count : mutable int
+      ; items : mutable array 'v
+      ; key : 'v -> 'k
+      ; compare : cmpf 'k
+      }
+    ;
+
+    (* в items так:
+      - или Array.length items = count, и items = все элементы,
+      - или count = 0 и Array.length items = 0, и ни одного элемента,
+      - или Array.length items > count и items.(count .. length-1) == items.(0)
+     *)
+
+
+    value enlarge_factor = 2
+          (* enlarge array from N to N*enlarge_factor when the enlargement
+             is needed. *)
+      and sortedarray_min_size = 16
+          (* array won't be smaller than sortedarray_min_size. *)
+      and shrink_factor = 8
+          (* array will be shrunk when count will be less-or-equal
+             to size/shrink_factor (if this value is not lesser than
+             sortedarray_min_size). *)
+    ;
+
+
+    value create key cmpf =
+      { count = 0
+      ; key = key
+      ; items = [| |]
+      ; compare = cmpf
+      }
+    ;
+
+
+    (* if result < 0 then (lnot result) is the index
+         where the item should be placed when inserting.
+       else result is the index of found item.
+     *)
+    value binary_search itmkey sa =
+      let len = sa.count
+      and arr = sa.items
+      and cmp = sa.compare
+      and key = sa.key in
+      let () = assert (0 <= len && len < max_int) in
+      inner 0 len
+      where rec inner lo hi =
+        if lo = hi
+        then lnot lo
+        else
+          let mid = (lo + hi) / 2 in
+          match (cmp itmkey (key arr.(mid))) with
+          [ 0 -> mid
+          | r when r < 0 (* itm < arr.(mid) *) -> inner lo mid
+          | _ (* itm > arr.(mid) *) -> inner (mid+1) hi
+          ]
+    ;
+
+    value insert sa ind itm =
+      let count = sa.count
+      and arr = sa.items in
+      let () = assert (ind >= 0 && ind <= count) in
+      let arr_len = Array.length arr in do
+        { if count < arr_len
+          then do
+            { Array.blit arr ind arr (ind+1) (count - ind)
+            }
+          else do
+            { let new_arr = Array.make
+                (max (count * enlarge_factor) sortedarray_min_size)
+                (if count = 0 then itm else arr.(0)) in
+              do
+                { ()
+                ; Array.blit arr 0 new_arr 0 ind
+                ; (*if ind < count
+                  then*) Array.blit arr ind new_arr (ind+1) (count - ind)
+(*
+                  else () (* else there would be Invalid_argument("Array.blit") *)
+*)
+                ; sa.items := new_arr
+                }
+            }
+        ; sa.items.(ind) := itm
+        ; sa.count := count + 1
+        }
+    ;
+
+    value add sa itm =
+      let r = binary_search (sa.key itm) sa in
+      if r < 0
+      then do { insert sa (lnot r) itm; True }
+      else False
+    ;
+
+    value do_shrink sa new_len =
+      let old_items = sa.items
+      and count = sa.count in
+      let old_len = Array.length old_items in
+      let () = assert (count <= new_len && new_len < old_len) in
+      let new_items = Array.make new_len old_items.(0) in
+      let () = Array.blit old_items 1 new_items 1 (count-1) in
+      sa.items := new_items
+    ;
+
+    value do_remove sa ind =
+      let count = sa.count in
+      let new_count = count - 1 in
+      let () = assert (ind >= 0 && ind < count) in do
+        { if new_count = 1
+          then
+            sa.items := [| |]
+          else do
+            { let newlen = (Array.length sa.items) / shrink_factor in
+              if newlen > sortedarray_min_size
+              && new_count <= newlen
+              then
+                let () = assert (not (new_count < newlen))
+                (* т.к. уменьшаем длину sa.items только тут. *)
+                in
+                  do_shrink sa newlen
+              else ()
+            ;
+              Array.blit
+                sa.items (ind + 1)
+                sa.items ind
+                (new_count - ind)
+            }
+        ; sa.count := new_count
+        }
+    ;
+
+    value remove sa itm =
+      let r = binary_search (sa.key itm) sa in
+      if r < 0
+      then False
+      else do { do_remove sa r; True }
+    ;
+
+    value mem_by_key sa itmkey =
+      ((binary_search itmkey sa) >= 0)
+    ;
+
+    value mem sa itm =
+      mem_by_key sa (sa.key itm)
+    ;
+
+    value lookup_opt sa k =
+      let i = binary_search k sa in
+      if i < 0
+      then None
+      else Some (sa.items.(i))
+    ;
+
+    value fold func init sa =
+      let cnt = sa.count
+      and items = sa.items
+      and key = sa.key in
+      inner init 0
+      where rec inner acc i =
+        if i = cnt
+        then
+          acc
+        else
+          let itm = items.(i) in
+          inner (func acc (key itm) itm) (i+1)
+    ;
+
+    value replace_with_array sa a =
+      let new_items = Array.copy a in
+      let cmp = sa.compare
+      and key = sa.key in do
+        { Array.sort
+            (fun a b -> cmp (key a) (key b))
+            new_items
+        ; sa.count := Array.length new_items
+        ; sa.items := new_items
+        }
+    ;
+
+
+    value ignore2 _ _ = ()
+      and ignore3 _ _ _ = ()
+    ;
+
+    value iter_diff
+      ?only_first
+      ?only_second
+      ?both
+      ~first ~second
+      =
+        let cmp = first.compare in
+        if cmp != second.compare
+        then failwith "SortedArraySet.iter_diff: sorry, one small limitation."
+        else
+        let nvl opt dflt =
+          match opt with
+          [ None -> dflt
+          | Some v -> v
+          ] in
+        (* фокус затеян затем, чтобы можно было потом оптимизировать
+           разные случаи необходимости вызова итерационных функций
+           (например, когда указано только both, алгоритм может стать
+           быстрее). *)
+        let only_first = nvl only_first ignore2
+        and only_second = nvl only_second ignore2
+        and both = nvl both ignore3 in
+        let c1 = first.count
+        and c2 = second.count
+        and it1 = first.items
+        and it2 = second.items
+        and k1 = first.key
+        and k2 = second.key
+        and iter_range itf kf arr ifrom ito =
+          for i = ifrom to ito do
+            { let v = arr.(i) in itf (kf v) v
+            }
+        in
+        inner 0 0
+        where rec inner i j =
+          if i = c1
+          then
+            if j = c2
+            then
+              (* here: i=c1, j=c2. *)
+              ()
+            else
+              (* here: i=c1, j<c2. *)
+              iter_range only_second k2 it2 j (c2 - 1)
+          else
+            if j = c2
+            then
+              (* here: i<c1, j=c2. *)
+              iter_range only_first k1 it1 i (c1 - 1)
+            else
+              (* here: i<c1, j<c2. *)
+              let v1 = it1.(i) in
+              let k1 = k1 v1 in
+              let v2 = it2.(i) in
+              let k2 = k2 v2 in
+              match (cmp k1 k2) with
+              [ 0 -> (* k1 = k2 *)
+                  do { both k1 v1 v2; inner (i+1) (j+1) }
+              | x when x<0 -> (* k1 < k2 *)
+                  do { only_first k1 v1; inner (i+1) j }
+              | _ (* when x>0 *) -> (* k1 > k2 *)
+                  do { only_second k2 v2; inner i (j+1) }
+              ]
+    ;
+
+
+    value get_keys a =
+      let items = a.items
+      and key = a.key in
+      Array.init a.count (fun i -> key items.(i))
+    ;
+
+  end
+;