1. Dmitry Grebeniuk
  2. cadastr

Commits

Dmitry Grebeniuk  committed f037736

from 'amall' project: interfaces for map read-only, map read-write; implementations for assoc lists and stdlib's Make

  • Participants
  • Parent commits 8c30842
  • Branches default

Comments (0)

Files changed (2)

File cadastr.ml

View file
  • Ignore whitespace
+value eq_of_cmp cmp = fun a b -> (0 = cmp a b)
+;
+
+(* non-specific types *)
+
+module T
+ =
+  struct
+
+    class map_ro ['k, 'v] =
+      object (self)
+
+        method get_exn (k : 'k) : 'v =
+          match self#get_opt k with
+          [ None -> raise Not_found
+          | Some v -> v
+          ]
+        ;
+
+        method get_opt (k : 'k) : option 'v =
+          try Some (self#get_exn k)
+          with [ Not_found -> None ]
+        ;
+
+        method mem k =
+          try (ignore (self#get_exn k); True) with [Not_found -> False]
+        ;
+
+      end
+    ;
+
+  end
+;
+
+(* types of functional/pure structures *)
+
+module Tfun
+ =
+  struct
+
+(*
+    class virtual map_w ['k, 'v] =
+      object (_self)
+
+        method virtual add : 'k -> 'v -> map_w 'k 'v;
+
+        method virtual remove : 'k -> map_w 'k 'v;
+
+        method virtual replace : 'k -> 'v -> map_w 'k 'v;
+
+      end
+    ;
+*)
+
+    class virtual map_rw ['k, 'v] =
+      object (self)
+
+        inherit T.map_ro ['k, 'v];
+
+        method virtual add : 'k -> 'v -> map_rw 'k 'v;
+
+        method virtual remove : 'k -> map_rw 'k 'v;
+
+        method replace (k : 'k) (v : 'v) =
+          (if self#mem k then self#remove k else (self :> map_rw 'k 'v))
+          # add k v
+        ;
+
+      end
+    ;
+
+    class type t_map_rw ['k, 'v] =
+      object
+        method get_exn : 'k -> 'v;
+        method get_opt : 'k -> option 'v;
+        method mem : 'k -> bool;
+
+        method add : 'k -> 'v -> map_rw 'k 'v;
+        method remove : 'k -> map_rw 'k 'v;
+        method replace : 'k -> 'v -> map_rw 'k 'v;
+      end
+    ;
+
+  end
+;
+
+(* types of imperative/mutable structures *)
+
+module Timp
+ =
+  struct
+
+    class virtual map_rw ['k, 'v] =
+      object (self)
+
+        inherit T.map_ro ['k, 'v];
+
+        method virtual add : 'k -> 'v -> unit;
+
+        method virtual remove : 'k -> unit;
+
+        method replace (k : 'k) (v : 'v) =
+          ( self#remove k
+          ; self#add k v
+          )
+        ;
+
+      end
+    ;
+
+    class type t_map_rw ['k, 'v] =
+      object
+        method get_exn : 'k -> 'v;
+        method get_opt : 'k -> option 'v;
+        method mem : 'k -> bool;
+
+        method add : 'k -> 'v -> unit;
+        method remove : 'k -> unit;
+        method replace : 'k -> 'v -> unit;
+      end
+    ;
+
+  end
+;
+
+
+(* functional/immutable structures (implementations) *)
+
+module Sfun
+ =
+  struct
+
+    value map_rw_assoc_stack_limit = 1000
+    ;
+
+    value list_assoc_index_opt ~keq lst k =
+      loop 0 lst
+      where rec loop i lst =
+        match lst with
+        [ [] -> None
+        | [(hk, _hv) :: tl] ->
+            if keq k hk
+            then Some i
+            else loop (i + 1) tl
+        ]
+    ;
+
+    value list_remove_nth_fast lst i =
+      if i < 0
+      then invalid_arg "list_remove_nth_fast: i<0"
+      else
+        inner lst i
+        where rec inner lst i =
+          match (i, lst) with
+          [ (_, []) -> invalid_arg "list_remove_nth_fast: i>=len"
+          | (0, [_h :: t]) -> t
+          | (i, [h :: t]) -> [h :: inner t (i - 1)]
+          ]
+    ;
+
+    value list_remove_nth_tailrec lst i =
+      let rec inner ~rev_acc lst i =
+        match (i, lst) with
+        [ (_, []) -> invalid_arg "list_remove_nth_tailrec: i>=len"
+        | (0, [_h :: t]) -> (rev_acc, t)
+        | (i, [h :: t]) -> inner ~rev_acc:[h :: rev_acc] t (i - 1)
+        ]
+      in
+      if i < 0
+      then invalid_arg "list_remove_nth_tailrec: i<0"
+      else
+        let (rev_heads, tail) = inner ~rev_acc:[] lst i in
+        List.rev_append rev_heads tail
+    ;
+
+
+    class map_ro_assoc ['k, 'v] ~keq cur
+    =
+      object (_self : #T.map_ro 'k 'v)
+
+        inherit T.map_ro ['k, 'v];
+
+        method! get_exn k =
+          loop cur
+          where rec loop lst =
+            match lst with
+            [ [] -> raise Not_found
+            | [(hk, hv) :: tl] ->
+                if keq k hk
+                then hv
+                else loop tl
+            ]
+        ;
+
+        method! mem k =
+          let rec loop lst =
+            match lst with
+            [ [] -> False
+            | [(hk, _hv) :: tl] ->
+                if keq k hk then True else loop tl
+            ]
+          in
+            loop cur
+        ;
+
+      end
+    ;
+
+    value map_rw_assoc_add k v cur =
+      [(k, v) :: cur]
+    ;
+
+    value map_rw_assoc_remove ~keq k cur =
+      match list_assoc_index_opt ~keq cur k with
+      [ None -> cur
+      | Some i ->
+          let res_list =
+            if i < map_rw_assoc_stack_limit
+            then list_remove_nth_fast cur i
+            else list_remove_nth_tailrec cur i
+          in
+            res_list
+      ]
+    ;
+
+    class map_rw_assoc ['k, 'v] ~keq cur
+    =
+      object (self : #Tfun.map_rw 'k 'v)
+
+        inherit map_ro_assoc ['k, 'v] ~keq cur;
+
+        method add k v = new map_rw_assoc ~keq (map_rw_assoc_add k v cur);
+
+        method remove k =
+          let new_cur = map_rw_assoc_remove ~keq k cur in
+          if cur == new_cur
+          then (self :> map_rw_assoc 'k 'v)
+          else new map_rw_assoc ~keq new_cur
+        ;
+
+        method replace k v =
+          let removed = map_rw_assoc_remove ~keq k cur in
+          let added = map_rw_assoc_add k v removed in
+          new map_rw_assoc ~keq added
+        ;
+
+      end
+    ;
+
+
+    module Tree
+      (T : Map.OrderedType)
+     :
+      sig
+        class map_rw_tree ['v] : Tfun.t_map_rw [T.t, 'v];
+      end
+     =
+      struct
+
+        module M = Map.Make(T);
+
+        class map_rw_tree_cur ['v] cur
+        =
+          object (_self : #Tfun.map_rw 'k 'v)
+            inherit Tfun.map_rw ['k, 'v];
+            method! get_exn k = M.find k cur;
+            method add k v =
+              new map_rw_tree_cur (M.add k v cur)
+            ;
+            method remove k =
+              new map_rw_tree_cur (M.remove k cur)
+            ;
+          end
+        ;
+
+        class map_rw_tree ['v]
+        =
+          map_rw_tree_cur ['v] M.empty
+        ;
+
+      end
+    ;
+
+  end
+;
+
+
+(* imperative/mutable structures (implementations) *)
+
+module Simp
+ =
+  struct
+
+    class map_rw_of_Sfun ['k, 'v] (fu : Tfun.map_rw 'k 'v)
+    =
+      object (_self : #Timp.map_rw 'k 'v)
+
+        inherit Timp.map_rw ['k, 'v];
+
+        value mutable cur = fu;
+
+        method add k v = cur := cur#add k v;
+
+        method remove k =
+          let new_cur = cur#remove k in
+          if new_cur == cur
+          then ()
+          else cur := new_cur
+        ;
+
+        method! replace (k : 'k) (v : 'v) =
+          let new_cur = cur#replace k v in
+          if new_cur == cur
+          then ()
+          else cur := new_cur
+        ;
+
+      end
+    ;
+
+    class map_rw_assoc ['k, 'v] ~keq
+    =
+      map_rw_of_Sfun ['k, 'v] (new Sfun.map_rw_assoc ~keq [])
+    ;
+
+
+    module Tree
+      (T : Map.OrderedType)
+     :
+      sig
+        class map_rw_tree ['v] : Timp.t_map_rw [T.t, 'v];
+      end
+     =
+      struct
+
+        module F = Sfun.Tree(T);
+
+        class map_rw_tree ['v]
+        =
+          map_rw_of_Sfun [T.t, 'v] (new F.map_rw_tree)
+        ;
+
+      end
+    ;
+
+
+  end
+;

File cadastr.mli

  • Ignore whitespace
Empty file removed.