Commits

Anonymous committed 66df945

map_rw_* -> map_rw{s,m}_*

  • Participants
  • Parent commits 6df5354

Comments (0)

Files changed (2)

File src/cadastr.ml

 ;
 
 
+class type map_foldable ['k, 'v] =
+  object
+    (* in case of shadowed values, they are passed to
+       user function in order of their appearance
+       (so, simple combination of fold and construction
+       functions will make possible mapping that preserves
+       shadowed bindings). *)
+    method fold : !'a . ('a -> 'k -> 'v -> 'a) -> 'a -> 'a;
+  end
+;
+
 (* non-specific types *)
 
 module T
  =
   struct
 
-    class type map_ro ['k, 'v] =
+    (* [map 'k 'v] is a collection of bindings of key of type 'k
+       to values of type 'v.  Note that the bindings added with
+       [add] method will shadow previous bindings of this key.
+       For consistency, map over standard [Map.Make().t] has only
+       [replace] method.
+     *)
+
+    class type morphism ['k, 'v] =
       object
         method get_exn : 'k -> 'v;
         method get_opt : 'k -> option 'v;
         method mem : 'k -> bool;
-        (* no methods like iter/fold, because map can be
-          just a function or even dns-lookup, so we don't know
-          or should not know the keys.
-          either:
-            - change map_ro to morphism for not-knowing-the-key, or
-            - change map_ro to collection_ro for these who know its keys
-         *)
+      end
+    ;
+
+    class type map_ro ['k, 'v] =
+      object
+        inherit morphism ['k, 'v];
+
+        method get_all : 'k -> list 'v;
+
+        inherit map_foldable ['k, 'v];
+        (* maybe iter too *)
       end
     ;
 
 ;
 
 
-class type map_foldable ['k, 'v] =
-  object
-    (* in case of shadowed values, they are passed to
-       user function in order of their appearance
-       (so, simple combination of fold and construction
-       functions will make possible mapping that preserves
-       shadowed bindings). *)
-    method fold : !'a . ('a -> 'k -> 'v -> 'a) -> 'a -> 'a;
-  end
-;
-
 
 
 
  =
   struct
 
-    class type map_rw ['k, 'v] =
+    (* [map_rws] = map readable/writeable with single binding
+       (no shadowing, no [add] method, only [replace])
+     *)
+    class type map_rws ['k, 'v] =
       object
         inherit T.map_ro ['k, 'v];
-(*
-       get_exn : 'k -> 'v
-      ; get_opt : 'k -> option 'v
-      ; mem : 'k -> bool
-*)
 
-        method empty : map_rw 'k 'v;
+        method empty : map_rws 'k 'v;
         method is_empty : bool;
 
-        method add : 'k -> 'v -> map_rw 'k 'v;
-        method remove : 'k -> map_rw 'k 'v;
-        method replace : 'k -> 'v -> map_rw 'k 'v;
-
-        inherit map_foldable ['k, 'v];
+        method replace : 'k -> 'v -> map_rws 'k 'v;
+        method remove : 'k -> map_rws 'k 'v;
 
       end
     ;
 
+    class type map_rwm ['k, 'v] =
+      object
+        inherit T.map_ro ['k, 'v];
+
+        method empty : map_rwm 'k 'v;
+        method is_empty : bool;
+
+        method replace : 'k -> 'v -> map_rwm 'k 'v;
+        method add : 'k -> 'v -> map_rwm 'k 'v;
+        method remove : 'k -> map_rwm 'k 'v;
+
+      end
+    ;
+
+
     class type trie ['k, 'v] =
       object
-        inherit map_rw [list 'k, 'v];
+        inherit map_rwm [list 'k, 'v];
         (* + fold_levels *)
       end
     ;
  =
   struct
 
-    class type map_rw ['k, 'v] =
+    class type map_rws ['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;
         inherit map_foldable ['k, 'v];
       end
     ;
 
+    class type map_rwm ['k, 'v] =
+      object
+        inherit map_rws ['k, 'v];
+        method add : 'k -> 'v -> unit;
+      end
+    ;
+
     class type memo ['k, 'v] =
       object
         method get : 'k -> 'v;
 
 (* implementations *)
 
+(* todo: to Cd_List.List.Assoc *)
+
 module Cd_list
  =
   struct
 
-    value map_rw_assoc_stack_limit = 1000
+    value map_rwm_assoc_stack_limit = 1000
     ;
 
     value list_assoc_index_opt ~keq lst k =
         loop cur
     ;
 
+    value list_assoc_get_all ~keq cur k =
+      let rec loop rev_acc lst =
+        match lst with
+        [ [] -> List.rev rev_acc
+        | [(hk, hv) :: tl] ->
+            loop (if keq k hk then [hv :: rev_acc] else rev_acc) tl
+        ]
+      in
+        loop [] cur
+    ;
+
     value list_assoc_get_opt ~keq cur k =
       try Some (list_assoc_get_exn ~keq cur k)
       with [Not_found -> None]
             loop cur
     ;
 
-    value map_rw_assoc_add cur k v =
+    value map_rwm_assoc_add cur k v =
       [(k, v) :: cur]
     ;
 
-    value map_rw_assoc_remove ~keq cur k =
+    value map_rwm_assoc_remove ~keq cur k =
       match list_assoc_index_opt ~keq cur k with
       [ None -> cur
       | Some i ->
           let res_list =
-            if i < map_rw_assoc_stack_limit
+            if i < map_rwm_assoc_stack_limit
             then list_remove_nth_fast cur i
             else list_remove_nth_tailrec cur i
           in
       object (_self)
         method get_exn k = Cd_list.list_assoc_get_exn ~keq cur k;
         method get_opt k = Cd_list.list_assoc_get_opt ~keq cur k;
+        method get_all k = Cd_list.list_assoc_get_all ~keq cur k;
         method mem k = Cd_list.list_assoc_mem ~keq cur k;
-      end
-    ;
-
-    class map_rw_assoc ['k, 'v] ~keq cur : Tfun.map_rw ['k, 'v]
-    =
-      object (self)
-        inherit map_ro_assoc ['k, 'v] ~keq cur;
-        method add k v = new map_rw_assoc ~keq
-          (Cd_list.map_rw_assoc_add cur k v);
-        method remove k =
-          let new_cur = Cd_list.map_rw_assoc_remove ~keq cur k 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 = Cd_list.map_rw_assoc_remove ~keq cur k in
-          let added = Cd_list.map_rw_assoc_add removed k v in
-          new map_rw_assoc ~keq added
-        ;
         method fold
         : !'a. ('a -> 'k -> 'v -> 'a) -> 'a -> 'a
         = fun f a ->
               cur
               a
         ;
-        method empty = new map_rw_assoc ~keq [];
+      end
+    ;
+
+    class map_rwm_assoc ['k, 'v] ~keq cur
+    =
+      object (self)
+        inherit map_ro_assoc ['k, 'v] ~keq cur;
+        method add k v = new map_rwm_assoc ~keq
+          (Cd_list.map_rwm_assoc_add cur k v);
+        method remove k =
+          let new_cur = Cd_list.map_rwm_assoc_remove ~keq cur k in
+          if cur == new_cur
+          then (self :> map_rwm_assoc _ _)
+          else new map_rwm_assoc ~keq new_cur
+        ;
+        method replace k v =
+          let removed = Cd_list.map_rwm_assoc_remove ~keq cur k in
+          let added = Cd_list.map_rwm_assoc_add removed k v in
+          new map_rwm_assoc ~keq added
+        ;
+        method empty = new map_rwm_assoc ~keq [];
         method is_empty = (cur = []);
       end
     ;
      :
       sig
         class map_ro_tree ['v] : T.map_ro [Key.t, 'v];
-        class map_rw_tree ['v] : Tfun.map_rw [Key.t, 'v];
+        class map_rws_tree ['v] : Tfun.map_rws [Key.t, 'v];
       end
      =
       struct
                try Some (get_exn cur k)
                with [Not_found -> None];
              value mem cur k = M.mem k cur;
-             value add cur k v = M.add k v cur;
+             value replace cur k v = M.add k v cur;
              value remove cur k = M.remove k cur;
              value fold cur f a = M.fold
                (fun k v a -> f a k v)
 
         class map_ro_tree_cur ['v] cur : T.map_ro [Key.t, 'v]
         =
-          object (_self)
+          object (self)
             method get_exn k = Cd_tree.get_exn cur k;
             method get_opt k = Cd_tree.get_opt cur k;
+            method get_all k = try [self#get_exn k] with [Not_found -> []];
             method mem k = Cd_tree.mem cur k;
+            method fold : !'a. ('a -> 'k -> 'v -> 'a) -> 'a -> 'a = fun f a ->
+              Cd_tree.fold cur f a
+            ;
           end
         ;
 
-        class map_rw_tree_cur ['v] cur : Tfun.map_rw [Key.t, 'v]
+        class map_rws_tree_cur ['v] cur : Tfun.map_rws [Key.t, 'v]
         =
           object (_self)
             inherit map_ro_tree_cur ['v] cur;
-            method add k v = new map_rw_tree_cur (Cd_tree.add cur k v);
+            method replace k v =
+              new map_rws_tree_cur (Cd_tree.replace cur k v)
+            ;
             method remove k =
-              new map_rw_tree_cur (Cd_tree.remove cur k)
+              new map_rws_tree_cur (Cd_tree.remove cur k)
             ;
-            method replace k v =
-              let removed = Cd_tree.remove cur k in
-              let added = Cd_tree.add removed k v in
-              new map_rw_tree_cur added
-            ;
-            method fold : !'a. ('a -> 'k -> 'v -> 'a) -> 'a -> 'a = fun f a ->
-              Cd_tree.fold cur f a
-            ;
-            method empty = new map_rw_tree_cur Cd_tree.empty;
+            (*
+             * method replace k v =
+             *   let removed = Cd_tree.remove cur k in
+             *   let added = Cd_tree.add removed k v in
+             *   new map_rw_tree_cur added
+             * ;
+             *)
+            method empty = new map_rws_tree_cur Cd_tree.empty;
             method is_empty = Cd_tree.is_empty cur;
           end
         ;
           map_ro_tree_cur ['v] M.empty
         ;
 
-        class map_rw_tree ['v]
+        class map_rws_tree ['v]
         =
-          map_rw_tree_cur ['v] M.empty
+          map_rws_tree_cur ['v] M.empty
         ;
 
       end  (* module Tree *)
 
     class trie ['k, 'v]
     (node_list : list 'v)
-    (level : Tfun.map_rw 'k (trie 'k 'v)) =
+    (level : Tfun.map_rws 'k (trie 'k 'v)) =
       object (self)
 
         method empty = new trie [] level#empty;
         (* raises Not_found when level does not exist *)
         method get_down
         : !'a . list 'k ->
-                ~get:(list 'v -> Tfun.map_rw 'k (trie 'k 'v) -> 'a) ->
+                ~get:(list 'v -> Tfun.map_rws 'k (trie 'k 'v) -> 'a) ->
                 'a
         = fun k ~get ->
           match k with
               | Some trie ->
                   ( trie
                     : < get_down : !'a . list 'k ->
-                       ~get:(list 'v -> Tfun.map_rw 'k (trie 'k 'v) -> 'a) ->
+                       ~get:(list 'v -> Tfun.map_rws 'k (trie 'k 'v) -> 'a) ->
                        'a ; .. >
                   )#get_down tk ~get
               ]
             self#fold_prefix f init []
         ;
 
+(*
+        method merge
+        : (list 'v -> list 'v -> list 'v) -> trie 'k 'v -> trie 'k 'v
+        = fun merge_nodes t ->
+          
+        ;
+*)
+
       end
     ;
 
  =
   struct
 
-    class map_rw_of_Sfun ['k, 'v] (fu : Tfun.map_rw 'k 'v)
-    : Timp.map_rw ['k, 'v]
+    class map_rws_of_Sfun ['k, 'v] (fu : Tfun.map_rws 'k 'v)
+    : Timp.map_rws ['k, 'v]
     =
       object (_self)
 
         method get_opt k = cur#get_opt k;
         method mem k = cur#mem k;
 
-        method add k v = cur := cur#add k v;
-
         method remove k =
           let new_cur = cur#remove k in
           if new_cur == cur
         ;
 
         method fold : !'a. ('a -> 'k -> 'v -> 'a) -> 'a -> 'a =
-          cur#fold
+          (cur :> map_foldable _ _)#fold
         ;
 
       end
     ;
 
-    class map_rw_assoc ['k, 'v] ~keq
+    class map_rwm_of_Sfun ['k, 'v] (fu : Tfun.map_rwm 'k 'v)
     =
-      map_rw_of_Sfun ['k, 'v] (new Sfun.map_rw_assoc ~keq [])
+      object (_self)
+
+        value mutable cur = fu;
+
+        method empty = cur#empty;
+        method is_empty = cur#is_empty;
+        method get_all = cur#get_all;
+
+        method get_exn k = cur#get_exn k;
+        method get_opt k = cur#get_opt k;
+        method mem k = cur#mem k;
+
+        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) =
+          cur := cur#replace k v
+        ;
+
+        method fold : !'a. ('a -> 'k -> 'v -> 'a) -> 'a -> 'a =
+          (cur :> map_foldable _ _)#fold
+        ;
+
+        method add k v = cur := cur#add k v;
+
+      end
+    ;
+
+
+    class map_rwm_assoc ['k, 'v] ~keq
+    =
+      map_rwm_of_Sfun ['k, 'v] (new Sfun.map_rwm_assoc ~keq [])
     ;
 
 
       (T : Map.OrderedType)
      :
       sig
-        class map_rw_tree ['v] : Timp.map_rw [T.t, 'v];
+        class map_rws_tree ['v] : Timp.map_rws [T.t, 'v];
       end
      =
       struct
 
         module F = Sfun.Tree(T);
 
-        class map_rw_tree ['v]
+        class map_rws_tree ['v]
         =
-          map_rw_of_Sfun [T.t, 'v] (new F.map_rw_tree)
+          map_rws_of_Sfun [T.t, 'v] (new F.map_rws_tree)
         ;
 
       end
       end
     ;
 
+    (* todo: другие мемоизации *)
+
 
   end
 ;

File test/test.ml

 
 value trie_test_env () =
   let module Tree = Cd.Sfun.Tree(Int) in
-  let the_empty = new Cd.Sfun.trie [] (new Tree.map_rw_tree) in
+  let the_empty = new Cd.Sfun.trie [] (new Tree.map_rws_tree) in
   let ex1 = (the_empty#add [1;2] "1;2")#add [1;3;4] "1;3;4" in
   let ex2 = ex1#remove [1;2] in
   let ex3 = ex1#add [1] "1" in