Commits

Anonymous committed 27f8eda

merge_rws tested

  • Participants
  • Parent commits aea48b8

Comments (0)

Files changed (12)

 Library cadastr
   Path:       src
   BuildTools: ocamlbuild
-  Modules:    Cadastr, Monoid, Cd_All, Cd_Int, Cd_List, Cd_Ops, Cd_Byte, Cd_Bytes, Cd_Chars, Cd_Strings
+  Modules:    Cadastr, Monoid, Cd_All, Cd_Int, Cd_List, Cd_Ops, Cd_Byte, Cd_Bytes, Cd_Chars, Cd_Strings, Cd_Array
   
 Executable tests
   Path:       test
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 6b7d314bfcf501314f7fd32f085e4cc2) *)
+(* DO NOT EDIT (digest: 42bf3314808f4cf0d4711dc0cdfdd5ac) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
                            "Cd_Byte";
                            "Cd_Bytes";
                            "Cd_Chars";
-                           "Cd_Strings"
+                           "Cd_Strings";
+                           "Cd_Array"
                         ];
                       lib_internal_modules = [];
                       lib_findlib_parent = None;
 (*
 todo:
+
   trie:
             - merge с параметром-функцией мержа узлов.
             - fold со свёрткой поддеревьев и, затем, узлов с ними.
 *)
 
 
+open Cd_Typeinfo.Typeinfo;
+open Cdt;
+open Cd_Option;
 
-value eq_of_cmp cmp = fun a b -> (0 = cmp a b)
-;
+(******************************************************)
 
 exception Dont_rebuild
 ;
 
 (* non-specific types *)
 
-module T
- =
-  struct
-
     (* [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.
       end
     ;
 
+
+    type map_ro_repr_kind =
+      [= `Assoc_list
+      |  `Tree
+      ]
+    ;
+
+    type map_rw_repr_kind =
+      map_ro_repr_kind
+    ;
+
     class type map_ro ['k, 'v] =
       object
         inherit morphism ['k, 'v];
 
+        method tkey : t 'k;
+        method tval : t 'v;
+
         method get_all : 'k -> list 'v;
 
         inherit map_foldable ['k, 'v];
         (* maybe iter too *)
+
+        method repr_kind : map_ro_repr_kind;
+
+        method to_arrays : unit -> (array 'k * array 'v);
+
       end
     ;
 
     class type monoid ['a] = Monoid.t ['a]
     ;
 
-(*
-    class foldable ['v] =
-      object (self)
-
-        method fold
-         :
-          monoid 'v -> 'v
-         =
-          fun m ->
-            self#fold_map (fun x -> x) m
-        ;
-
-        method fold_map
-         :
-          !'a . ('v -> 'a) -> monoid 'a -> 'a
-         =
-          fun f m ->
-            self#fold (m#map f)
-        ;
-      end
-    ;
-*)
-
-
-  end
-;
-
-
-
-
 
 (* types of functional/pure structures *)
 
      *)
     class type map_rws ['k, 'v] =
       object
-        inherit T.map_ro ['k, 'v];
+        inherit map_ro ['k, 'v];
 
         method empty : map_rws 'k 'v;
         method is_empty : bool;
         method replace : 'k -> 'v -> map_rws 'k 'v;
         method remove : 'k -> map_rws 'k 'v;
 
+        method merge
+        : ('k -> option 'v -> option 'v -> option 'v) ->
+          map_rws 'k 'v -> map_rws 'k 'v;
+
       end
     ;
 
     class type map_rwm ['k, 'v] =
       object
-        inherit T.map_ro ['k, 'v];
+        inherit map_ro ['k, 'v];
 
         method empty : map_rwm 'k 'v;
         method is_empty : bool;
         method add : 'k -> 'v -> map_rwm 'k 'v;
         method remove : 'k -> map_rwm 'k 'v;
 
+        method repr_kind : map_rw_repr_kind;
+
+        method merge
+        : ('k -> list 'v -> list 'v -> list 'v) ->
+          map_rwm 'k 'v -> map_rwm 'k 'v;
+
       end
     ;
 
 ;
 
 
+(* functional/immutable structures (classes/objects, what is exported) *)
+
 (* implementations *)
 
-(* todo: to Cd_List.List.Assoc *)
-
-module Cd_list
- =
-  struct
-
-
-  end
-;
-
-
-(* functional/immutable structures (classes/objects, what is exported) *)
-
 module Sfun
  =
   struct
 
+    (* deepest bindings are [add]ed first, top bindings last,
+       so you can [add] to or [replace] into any [map_rw*]
+       to get desired result. *)
+    class type map_rwm_builder ['k, 'v, 'a, 'r]
+     =
+      object
+        method empty : 'a;
+        method add : 'a -> 'k -> 'v -> 'a;
+        method result : 'a -> 'r;
+      end
+    ;
+
+    class assoc_list_builder ['k, 'v]
+     : map_rwm_builder ['k, 'v, list ('k * 'v), list ('k * 'v)]
+     =
+      object
+        method empty = [];
+        method add a k v = [(k, v) :: a];
+        method result a = a;
+      end
+    ;
+
+
+(*
+    type merge_res 'k 'v 'r =
+      [= `MR_assoc_list of list ('k * 'v)
+      ]
+    ;
+*)
+
+    value merge_maps
+      desc
+     =
+      let merge_into_list ~f ~a ~b =
+
+              let a_keq = a#tkey#topt#eq in
+              let () = assert (a_keq != No.eq) in
+              if a_keq != b#tkey#topt#eq
+              then invalid_arg "Cadastr.Sfun.merge_maps: \
+                                assoc_lists: distinct eq"
+              else
+              let (k1, v1) = a#to_arrays ()
+              and (k2, v2) = b#to_arrays ()
+              and builder = new assoc_list_builder in
+
+              (* let () = Printf.printf "\n\n{\n%!" in *)
+              let r =
+              `MR_assoc_list (Cd_Array.Array.merge_maps
+                ~tkey:a#tkey ~tval:a#tval
+                ~keq:a_keq ~f ~builder ~k1 ~v1 ~k2 ~v2 ())
+              in (* let () = Printf.printf "\n}\n\n%!" in *)
+              r
+      in
+      let merge_into_tree ~f ~a ~b =
+        let add ~acc k ~opt_v1 ~opt_v2 =
+          match f k opt_v1 opt_v2 with
+          [ None -> acc
+          | Some v -> acc#replace k v
+          ]
+        in
+        let acc = a#empty in
+        let (acc, a) = (b :> map_foldable _ _)#fold
+          (fun (acc, a) k v2 ->
+             let opt_v1 = a#get_opt k in
+             let a = a#remove k in
+             ((add ~acc k ~opt_v1 ~opt_v2:(Some v2)), a)
+          )
+          (acc, a)
+        in
+        let acc = (a :> map_foldable _ _)#fold
+          (fun acc k v1 ->
+             add ~acc k ~opt_v1:(Some v1) ~opt_v2:None
+          )
+          acc
+        in
+        `MR_value acc
+
+      in
+
+      match desc with
+      [ `Merge_rwm (f, a, b) ->
+
+          match (a#repr_kind, b#repr_kind) with
+          [ (`Assoc_list, `Assoc_list) ->
+
+              merge_into_list ~f:(`Merge_rwm f)
+                ~a ~b
+
+          | (_, `Tree) | (`Tree, _) ->
+
+              assert False  (* trees can't do map_rw with multiple bindings *)
+
+          | _ ->
+
+              assert False
+          ]
+
+      | `Merge_rws (f, a, b) ->
+
+          match (a#repr_kind, b#repr_kind) with
+          [ (`Assoc_list, (`Assoc_list | `Tree)) ->
+
+              merge_into_list ~f:(`Merge_rws f)
+                ~a ~b
+
+          | (`Tree, (`Assoc_list | `Tree)) ->
+
+              merge_into_tree ~f ~a ~b
+
+          | _ -> assert False
+          ]
+
+      ]
+    ;
+
     module A = Cd_List.List.Assoc;
 
-    class map_ro_assoc ['k, 'v] ~keq cur : T.map_ro ['k, 'v]
+    class map_ro_assoc ['k, 'v] ?tval tkey cur : map_ro ['k, 'v]
     =
       object (_self)
+        method tkey = (tkey :> t 'k);
+        method tval = Option.default (tval :> option (t 'v)) t_no;
+        value keq = tkey#eq;
         method get_exn k = A.get_exn ~keq cur k;
         method get_opt k = A.get_opt ~keq cur k;
         method get_all k = A.get_all ~keq cur k;
               cur
               a
         ;
+        method repr_kind = `Assoc_list;
+        method to_arrays () = A.to_arrays cur;
       end
     ;
 
-    class map_rwm_assoc ['k, 'v] ~keq cur
-    =
+
+    class map_rws_assoc ['k, 'v] ?tval tkey cur
+     =
       object (self)
-        inherit map_ro_assoc ['k, 'v] ~keq cur;
-        method add k v = new map_rwm_assoc ~keq
-          (A.add cur k v);
+        inherit map_ro_assoc ['k, 'v] ?tval tkey cur;
+
+        value keq = tkey#eq;
+
+        method remove k =
+          let new_cur = A.remove ~keq cur k in
+          if cur == new_cur
+          then (self :> map_rws_assoc _ _)
+          else new map_rws_assoc ?tval tkey new_cur
+        ;
+
+        method replace k v =
+          new map_rws_assoc ?tval tkey (A.replace ~keq cur k v)
+        ;
+
+        method empty = new map_rws_assoc ?tval tkey [];
+        method is_empty = (cur = []);
+
+        (* when merging two assoc lists, [eq] function on their types
+           must be physically the same, otherwise the exception
+           [Invalid_arg] is raised
+           (may be this could be turned off by some option later). *)
+        method merge
+         : ('k -> option 'v -> option 'v -> option 'v) ->
+           map_rws_assoc 'k 'v -> map_rws_assoc 'k 'v
+         = fun f m ->
+             let open Cd_Ops in
+             let me = (self :> map_rws_assoc _ _) in
+             merge_maps (`Merge_rws f me m)
+             |> fun x ->
+                  match x with
+                  [ `MR_assoc_list l -> new map_rws_assoc ?tval tkey l
+                  | `MR_value _ -> assert False
+                  ]
+        ;
+
+      end
+    ;
+
+
+    class map_rwm_assoc ['k, 'v] ?tval tkey cur
+     =
+      object (self)
+        inherit map_ro_assoc ['k, 'v] ?tval tkey cur;
+
+        value keq = tkey#eq;
+
+        method add k v =
+          new map_rwm_assoc ?tval tkey (A.add cur k v)
+        ;
+
         method remove k =
           let new_cur = A.remove ~keq cur k in
           if cur == new_cur
           then (self :> map_rwm_assoc _ _)
-          else new map_rwm_assoc ~keq new_cur
+          else new map_rwm_assoc ?tval tkey new_cur
         ;
+
         method replace k v =
-          let removed = A.remove ~keq cur k in
-          let added = A.add removed k v in
-          new map_rwm_assoc ~keq added
+          new map_rwm_assoc ?tval tkey (A.replace ~keq cur k v)
         ;
-        method empty = new map_rwm_assoc ~keq [];
+
+        method empty = new map_rwm_assoc ?tval tkey [];
         method is_empty = (cur = []);
+
+        (* when merging two assoc lists, [eq] function on their types
+           must be physically the same, otherwise the exception
+           [Invalid_arg] is raised
+           (may be this could be turned off by some option later). *)
+        method merge
+         : ('k -> list 'v -> list 'v -> list 'v) ->
+           map_rwm_assoc 'k 'v -> map_rwm_assoc 'k 'v
+         = fun f m ->
+             let open Cd_Ops in
+             merge_maps (`Merge_rwm f self m)
+             |> fun x ->
+                  match x with
+                  [ `MR_assoc_list l -> new map_rwm_assoc ?tval tkey l
+                  | `MR_value v -> v
+                  ]
+        ;
+
       end
     ;
 
 
-    module Tree
-      (Key : Map.OrderedType)
+    (*****************************************************)
+
+    module Tree (Key : TMOD 'a)
      :
       sig
-        class map_ro_tree ['v] : T.map_ro [Key.t, 'v];
-        class map_rws_tree ['v] : Tfun.map_rws [Key.t, 'v];
+
+        class map_ro_tree ['v] : [?tval: #t 'v] -> [unit]
+          -> map_ro [Key.t, 'v]
+        ;
+
+        class map_rws_tree ['v] : [?tval: #t 'v] -> [unit]
+          -> Tfun.map_rws [Key.t, 'v]
+        ;
+
       end
      =
       struct
 
-        module M = Map.Make(Key);
+        value tkey = t_of_tmod (module Key : TMOD with type t = Key.t)
+        ;
+
+        module Kcompare =
+          struct
+            type t = Key.t;
+            value compare a b =
+              match Key.cmp a b with
+              [ LT -> -1
+              | EQ -> 0
+              | GT -> 1
+              ]
+            ;
+          end
+        ;
+
+        module M = Map.Make(Kcompare);
 
         module Cd_tree
          =
-           struct
-             value get_exn cur k = M.find k cur;
-             value get_opt cur k =
-               try Some (get_exn cur k)
-               with [Not_found -> None];
-             value mem cur k = M.mem k 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)
-               cur
-               a
-             ;
-             value empty = M.empty;
-             value is_empty = M.is_empty;
-           end
+          struct
+            value get_exn cur k = M.find k cur;
+            value get_opt cur k =
+              try Some (get_exn cur k)
+              with [Not_found -> None];
+            value mem cur k = M.mem k 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)
+              cur
+              a
+            ;
+            value empty = M.empty;
+            value is_empty = M.is_empty;
+
+            value to_arrays cur =
+              let size = M.cardinal cur in
+              let module BS = Cd_Array.Array.BuildSized in
+              let karr = BS.create ~size
+              and varr = BS.create ~size in
+              let () = M.iter
+                (fun k v ->
+                   ( BS.add k karr
+                   ; BS.add v varr
+                   )
+                )
+                cur
+              in
+                (BS.get karr, BS.get varr)
+            ;
+          end
         ;
 
-
-        class map_ro_tree_cur ['v] cur : T.map_ro [Key.t, 'v]
-        =
+        class map_ro_tree_cur ['v] ?tval cur : map_ro [Key.t, 'v]
+         =
           object (self)
+            method tkey = tkey;
+            method tval = Option.default (tval :> option (t 'v)) t_no;
             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
+            method fold
+             : !'a. ('a -> Key.t -> 'v -> 'a) -> 'a -> 'a
+             = fun f a ->
+                 Cd_tree.fold cur f a
             ;
+            method to_arrays () = Cd_tree.to_arrays cur;
+            method repr_kind = `Tree;
           end
         ;
 
-        class map_rws_tree_cur ['v] cur : Tfun.map_rws [Key.t, 'v]
-        =
-          object (_self)
-            inherit map_ro_tree_cur ['v] cur;
+
+        class map_rws_tree_cur ['v] ?tval (cur : M.t 'v)
+         : Tfun.map_rws [Key.t, 'v]
+         =
+          object (self)
+            inherit map_ro_tree_cur ['v] ?tval cur;
             method replace k v =
               new map_rws_tree_cur (Cd_tree.replace cur k v)
             ;
             method remove 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 empty = new map_rws_tree_cur Cd_tree.empty;
             method is_empty = Cd_tree.is_empty cur;
+            method merge f m =
+              let me = (self :> map_rws_tree_cur _) in
+              let mr = merge_maps (`Merge_rws f me m) in
+              match mr with
+              [ `MR_assoc_list _ -> assert False
+              | `MR_value v -> v
+              ]
+            ;
           end
         ;
 
-        class map_ro_tree ['v]
-        =
-          map_ro_tree_cur ['v] M.empty
+        class map_ro_tree ['v] ?tval ()
+         =
+          map_ro_tree_cur ['v] ?tval M.empty
         ;
 
-        class map_rws_tree ['v]
-        =
-          map_rws_tree_cur ['v] M.empty
+        class map_rws_tree ['v] ?tval ()
+         =
+          map_rws_tree_cur ['v] ?tval M.empty
         ;
-
-      end  (* module Tree *)
+      
+      end  (* Tree *)
     ;
 
 
+    (*****************************************************)
+
     class trie ['k, 'v]
     (node_list : list 'v)
     (level : Tfun.map_rws 'k (trie 'k 'v)) =
 
         method add k v = cur := cur#add k v;
 
+        method repr_kind = fu#repr_kind;
+
       end
     ;
 
 
-    class map_rwm_assoc ['k, 'v] ~keq
+    class map_rwm_assoc ['k, 'v] tkey
     =
-      map_rwm_of_Sfun ['k, 'v] (new Sfun.map_rwm_assoc ~keq [])
+      map_rwm_of_Sfun ['k, 'v] (new Sfun.map_rwm_assoc tkey [])
     ;
 
 
     module Tree
-      (T : Map.OrderedType)
+      (T : TMOD)
      :
       sig
-        class map_rws_tree ['v] : Timp.map_rws [T.t, 'v];
+        class map_rws_tree ['v] : [?tval: t 'v] -> [unit]
+          -> Timp.map_rws [T.t, 'v]
+        ;
       end
      =
       struct
 
         module F = Sfun.Tree(T);
 
-        class map_rws_tree ['v]
+        class map_rws_tree ['v] ?tval ()
         =
-          map_rws_of_Sfun [T.t, 'v] (new F.map_rws_tree)
+          map_rws_of_Sfun [T.t, 'v] (new F.map_rws_tree ?tval ())
         ;
 
       end
           ;
         end
      )
-(*
-     :
-      sig
-        class memo_last ['k, 'v]
-         : (* keq:('k -> 'k -> bool) -> *)
-           ('k -> 'v) ->
-           Timp.memo ['k, 'v]
-        ;
-      end
-*)
      =
       struct
         class memo_last ['k, 'v] ~keq wr : Timp.memo ['k, 'v] =
     ;
 
 
-    class memo_last ['k, 'v] ~keq f
+    class memo_last ['k, 'v] tkey f
     : Timp.memo ['k, 'v]
     =
       object
         value last = ref None;
+        value keq = tkey#eq;
+
         method clear () = (last.val := None);
         method get = fun x ->
           let recalc x =
 
   end
 ;
+

src/cadastr.mllib

 # OASIS_START
-# DO NOT EDIT (digest: 98efee6f5bcc109dc8c6f69f3ad42ddf)
+# DO NOT EDIT (digest: 17a3cf3726ac6916519e3af8e180bdc3)
 Cadastr
 Monoid
 Cd_All
 Cd_Bytes
 Cd_Chars
 Cd_Strings
+Cd_Array
 # OASIS_STOP
 module Byte = Cd_Byte.Byte;
 module Bytes = Cd_Bytes.Bytes;
 module Chars = Cd_Chars.Chars;
+module Array = Cd_Array.Array;
+module Typeinfo = Cd_Typeinfo.Typeinfo;
 
 include Cd_Ops;
+
+type cmp_res = Cdt.cmp_res == [ LT | EQ | GT ]
+;
+
+
+value tint = Typeinfo.tint;
+value tstring = Typeinfo.tstring;
+module Array
+ =
+  struct
+
+    include Array;
+
+    type t 'a = array 'a;
+
+    open Cd_Typeinfo;
+    open Cd_Option;
+    open Printf;
+    open Cd_Ops;
+    open Cdt;
+
+    value map_to_list f arr =
+      inner [] (Array.length arr - 1)
+      where rec inner acc i =
+        if i = -1
+        then acc
+        else inner [(f arr.(i)) :: acc] (i - 1)
+    ;
+
+    value dump ~t arr =
+      arr
+      |> map_to_list (show ~t)
+      |> String.concat " ; "
+      |> sprintf "[| %s |]"
+    ;
+
+    module BuildSized
+     :
+      sig
+        type t 'a;
+        value create : ~size:int -> t 'a;
+        value add : 'a -> t 'a -> unit;
+        value get : t 'a -> array 'a;
+      end
+     =
+      struct
+
+        type t 'a =
+          { size : int
+          ; ofs : mutable int
+          ; arr : mutable array 'a
+          }
+        ;
+
+        value create ~size =
+          if size < 0
+          then
+            invalid_arg "Cd_Array.Array.BuildSized.create: \
+                         size < 0"
+          else if size > Sys.max_array_length
+          then
+            invalid_arg "Cd_Array.Array.BuildSized.create: \
+                         size > Sys.max_array_length"
+          else
+          { size = size
+          ; ofs = 0
+          ; arr = [| |]
+          }
+        ;
+
+        value add x a =
+          let i = a.ofs in
+          if i = a.size
+          then
+            ( a.arr := [| |]
+            ; invalid_arg "Cd_Array.Array.BuildSized.add: \
+                           adding more elements than expected"
+            )
+          else
+          (
+            if i = 0
+            then
+              a.arr := Array.make a.size x  (* fills a.arr.(0) too *)
+            else
+              a.arr.(i) := x
+          ;
+            a.ofs := i + 1
+          )
+        ;
+
+        value get a =
+          let r = a.arr in
+          ( a.arr := [| |]
+          ; if a.ofs = a.size
+            then
+              r
+            else
+              invalid_arg "Cd_Array.Array.BuildSized.get: \
+                           trying to get an incompletely built array"
+          )
+        ;
+
+      end
+    ;
+
+
+    (* to Array: *)
+
+    (* returns arrays paired with arrays of equivalence classes
+       (where [f a b = True]) and the classes count.
+       (array values are in [0 .. count-1]).
+       time = O(sum_of_lengths_of_arrays^2)
+       (named after topological "fibration"). *)
+
+    value arrays_fibration
+    : ('a -> 'a -> bool) ->
+      list (array 'a) ->
+      (list (array 'a * array int) * int)
+    = fun f arrs ->
+
+      let set_cls ~theitem ~thecls ~arr ~cls ~ofs =
+        let jmax = Array.length arr - 1 in
+        for j = ofs to jmax do
+          if cls.(j) = -1
+          then
+            if f theitem arr.(j)
+            then
+              cls.(j) := thecls
+            else
+              ()
+          else
+            ()
+        done
+      in
+
+      let set_clss ~theitem ~thecls ~arr ~cls ~tail_arrsclss ~firstofs =
+        ( set_cls ~theitem ~thecls ~arr ~cls ~ofs:firstofs
+        ; List.iter
+            (fun (arr, cls) ->
+               set_cls ~theitem ~thecls ~arr ~cls ~ofs:0
+            )
+            tail_arrsclss
+        )
+      in
+
+      let orig_arrsclss = List.map
+        (fun a -> (a, Array.make (Array.length a) (-1))) arrs in
+
+      let curcls = ref 0 in
+
+      inner orig_arrsclss
+      where rec inner arrsclss =
+        match arrsclss with
+        [ [] -> (orig_arrsclss, curcls.val)
+        | [(arr, cls) :: tail_arrsclss] ->
+            let len = Array.length arr in
+            let imax = len - 1 in
+            let () =
+              for i = 0 to imax do
+                if cls.(i) = -1
+                then
+                  let thecls = curcls.val in
+                  let () = incr curcls in
+                  let () = cls.(i) := thecls in
+                  set_clss ~theitem:arr.(i) ~thecls ~arr ~cls
+                    ~tail_arrsclss
+                    ~firstofs:(i + 1)
+                else
+                  ()
+              done
+            in
+              inner tail_arrsclss
+        ]
+    ;
+
+(* single array:
+    value array_fibration f arr =
+      let len = Array.length arr in
+      let cls = Array.make len (-1) in
+      let curcls = ref 0 in
+      let () =
+      let imax = len - 1 in
+        for i = 0 to imax do
+          if cls.(i) = -1
+          then
+            let thecls = curcls.val in
+            let () = incr curcls in
+            let () = cls.(i) := thecls in
+            for j = i + 1 to imax do
+              if cls.(j) = -1
+              then
+                if keq arr.(i) arr.(j)
+                then
+                  cls.(j) := thecls
+                else
+                  ()
+              else
+                ()
+          else
+            ()
+      in
+        (cls, curcls.val)
+    ;
+*)
+
+
+    (* todo: поменять на алгоритм, который будет для каждого массива
+       составлять массив, где .(cls) = список элементов с таким классом. *)
+
+    value merge_maps ?tkey ?tval ~builder ~keq ~f ~k1 ~v1 ~k2 ~v2 () =
+
+      let _tkey = Option.default tkey Typeinfo.t_no in
+      let _tval = Option.default tval Typeinfo.t_no in
+
+      (*
+      let () =
+        ( Printf.printf "k1: %s\nv1: %s\nk2: %s\nv2: %s\n"
+            (dump ~t:_tkey k1)
+            (dump ~t:_tval v1)
+            (dump ~t:_tkey k2)
+            (dump ~t:_tval v2)
+        )
+      in
+      *)
+
+      let len1 = Array.length k1 in
+      let () = assert (len1 = Array.length v1) in
+      let len2 = Array.length k2 in
+      let () = assert (len2 = Array.length v2) in
+
+      let (f, first_only) =
+        match f with
+        [ `Merge_rws f_opt ->
+            let opt_of_list l =
+              match l with
+              [ [] -> None
+              | [x] -> Some x
+              | [_ :: _] -> assert False
+              ]
+            in
+            let f_lst k v1lst v2lst =
+              match f_opt k (opt_of_list v1lst) (opt_of_list v2lst) with
+              [ None -> []
+              | Some v -> [v]
+              ]
+            in
+            (f_lst, True)
+        | `Merge_rwm f_lst ->
+            (f_lst, False)
+        ]
+      in
+
+      (* собирает varr.(i) по порядку, чей cls.(i) = cls,
+         начиная с ofs включительно;
+         возвращает собранное и следующий минимальный индекс,
+         с которого начнётся какой-либо следующий класс, или -1,
+         если такого не найдено. *)
+      let gather_cls ~thecls ~cls ~varr ~ofs =
+        let imax = Array.length cls - 1 in
+        inner (-1) [] ofs
+        where rec inner nextcls_ofs acc i =
+          if i > imax
+          then (List.rev acc, nextcls_ofs)
+          else
+            let c = cls.(i) in
+            let nextcls_ofs =
+              if nextcls_ofs = -1 && c > thecls then i else nextcls_ofs in
+            let acc =
+              match ((c = thecls), first_only, acc) with
+              [ (True, False, acc) | (True, True, ([] as acc)) ->
+                  [varr.(i) :: acc]
+              | (False, _, acc) | (True, True, ([_ :: _] as acc)) ->
+                  acc
+              ]
+            in
+              inner nextcls_ofs acc (i + 1)
+      in
+
+      match arrays_fibration keq [k1; k2] with
+      [ ([(_a1, cls1) ; (_a2, cls2)] , maxcls) ->
+
+          (*
+          let () =
+            Typeinfo.
+            ( printf "cls1: %s\ncls2: %s\n%!"
+                (dump ~t:tint cls1)
+                (dump ~t:tint cls2)
+            )
+          in
+          *)
+
+          let acc_add = builder#add in
+
+          let rec return ~acc =
+
+            builder#result acc
+
+          and add ~k ~v1s ~v2s ~acc =
+
+            let addon_vals_top_first = f k v1s v2s in
+
+            (*
+            let () =
+              let show_list lst =
+                lst
+                |> List.map _tval#topt#show
+                |> String.concat " ; "
+                |> sprintf "[%s]" in
+              printf "k=%s v1s=%s v2s=%s\n"
+                 (_tkey#topt#show k) (show_list v1s) (show_list v2s)
+            in
+            *)
+
+            List.fold_right
+              (fun v acc -> acc_add acc k v)
+              addon_vals_top_first
+              acc
+
+          and proc_arr1 ~acc ~curcls ofs =
+
+            (*
+            let () = printf "proc_arr1: curcls=%i, ofs=%i\n%!" curcls ofs in
+            *)
+
+            if curcls = maxcls
+            then
+              return ~acc
+            else
+
+              if ofs = len1
+              then
+
+                proc_arr2 ~curcls ~acc 0
+
+              else
+
+                let (v1s, nextcls1_ofs) =
+                  gather_cls ~thecls:curcls ~cls:cls1 ~varr:v1 ~ofs in
+
+                let (v2s, _nextcls2_ofs) =
+                  gather_cls ~thecls:curcls ~cls:cls2 ~varr:v2 ~ofs:0 in
+
+                let k1k = k1.(ofs) in
+
+                let acc = add ~k:k1k ~v1s ~v2s ~acc in
+
+                let curcls = curcls + 1 in
+
+                if nextcls1_ofs = -1
+                then
+                  proc_arr2 ~curcls ~acc 0
+                else
+                  proc_arr1 ~acc ~curcls nextcls1_ofs
+
+          and proc_arr2 ~acc ~curcls ofs =
+
+            (*
+            let () = printf "proc_arr2: curcls=%i, ofs=%i\n%!"
+              curcls ofs in
+            *)
+
+            if curcls = maxcls
+            then
+              let () = assert (ofs = 0 || ofs = -1) in
+              return ~acc
+            else
+
+              if cls2.(ofs) < curcls
+              then
+
+                proc_arr2 ~acc ~curcls (ofs + 1)
+
+              else
+                let (v2s, nextcls2_ofs) =
+                  gather_cls ~thecls:curcls ~cls:cls2 ~varr:v2 ~ofs in
+
+                let k2k = k2.(ofs) in
+
+                let acc = add ~k:k2k ~v1s:[] ~v2s ~acc in
+
+                let curcls = curcls + 1 in
+
+                let () = assert (
+                  if nextcls2_ofs = -1
+                  then curcls = maxcls
+                  else True
+                ) in
+
+                proc_arr2 ~acc ~curcls nextcls2_ofs
+
+          in
+            proc_arr1 ~curcls:0 ~acc:builder#empty 0
+
+      | _ -> assert False
+      ]
+    ;
+
+
+
+
+  end
+;
 
     include List;
 
+    value rec for_ lst f =
+      match lst with
+      [ [] -> ()
+      | [h :: t] -> (f h; for_ t f)
+      ]
+    ;
+
+
     type t 'a = list 'a;
 
     open Cd_Ops;
     ;
 
 
+    (* returns (shortest_list, longest_list) *)
+    value order_by_length l1 l2 =
+      loop l1 l2
+      where rec loop a b =
+        match (a, b) with
+        [ ([], _) -> (l1, l2)
+        | (_, []) -> (l2, l1)
+        | ([_ :: ta], [_ :: tb]) -> loop ta tb
+        ]
+    ;
+
+
+    value rev_map_append src f dst =
+      inner src dst
+      where rec inner src dst =
+        match src with
+        [ [] -> dst
+        | [h :: t] -> inner t [(f h) :: dst]
+        ]
+    ;
+
+
     module Assoc
      =
       struct
           ]
         ;
 
+        (* (* todo: optimize? *)
+        value rec remove_all ~keq cur k =
+          let r = remove ~keq cur k in
+          if r == cur
+          then r
+          else remove_all ~keq r k
+        ;*)
+
+(* doesn't work!  (works assymetrically, longest lists' items absent
+   in shortest list are not processed; I leave the code here in case
+   when such behaviour will be needed later.)
+
+
+        value rec   assym_   merge_rwm2 ~keq ~f ~lshort ~llong ~acc =
+          match lshort with
+          [ [] -> acc
+          | [(hk, _) :: _] ->
+              let (lshort_eq, lshort_neq) =
+                partition (fun (k, _v) -> keq hk k) lshort in
+              let lshort_vals = List.map (fun (_k, v) -> v) lshort_eq in
+              let llong_vals = get_all ~keq llong hk in
+              let res_vals = f hk lshort_vals llong_vals in
+              let res_bindings_rev = List.rev_map (fun v -> (hk,v)) res_vals in
+              let res_acc = List.rev_append res_bindings_rev acc in
+              merge_rwm2 ~keq ~f ~lshort:lshort_neq ~llong ~acc:res_acc
+          ]
+        ;
+
+        value   assym_   merge_rwm ~keq ~f ~l1 ~l2 =
+          let (lshort, llong) = order_by_length l1 l2 in
+          merge_rwm2 ~keq ~lshort ~llong ~acc:[]
+            ~f:(if l1 == lshort then f else fun x y z -> f x z y)
+        ;
+*)
+
+
+        value to_arrays
+        : list ('k * 'v) -> (array 'k * array 'v)
+        = fun lst ->
+          match lst with
+          [ [] -> ([| |], [| |])
+          | [(k0, v0) :: _] ->
+              let len = List.length lst in
+              let karr = Array.make len k0
+              and varr = Array.make len v0 in
+              inner lst 0
+              where rec inner lst i =
+                match lst with
+                [ [] -> (karr, varr)
+                | [(k, v) :: t] ->
+                    ( karr.(i) := k
+                    ; varr.(i) := v
+                    ; inner t (i + 1)
+                    )
+                ]
+          ]
+        ;
+
+
+        value replace ~keq cur k v =
+          let removed = remove ~keq cur k in
+          let added = add removed k v in
+          added
+        ;
+
+
+      end  (* Assoc *)
+    ;
+
+
+    open Cd_Types;
+
+    module Monad : MONAD with type t 'a = list 'a
+     =
+      struct
+        type t 'a = list 'a;
+        value return x = [x];
+        value bind_rev m f = List.concat (List.map f m);  (* todo... *)
+        value ( >>= ) = bind_rev;
+        value bind f m = bind_rev m f;
       end
     ;
 
+module Option
+ =
+  struct
+
+    type t 'a = option 'a;
+
+    value default opt def =
+      match opt with
+      [ None -> def
+      | Some v -> v
+      ]
+    ;
+
+  end
+;

src/cd_Typeinfo.ml

+module Typeinfo
+ =
+  struct
+
+    open Cdt;
+
+    value cmp_of_compare compare =
+      fun a b ->
+        match compare a b with
+        [ 0 -> EQ
+        | x when x < 0 -> LT
+        | _ -> GT
+        ]
+    ;
+
+    value perv_cmp = fun x y ->
+      match Pervasives.compare x y with
+      [ 0 -> EQ
+      | x when x < 0 -> LT
+      | _ -> GT
+      ]
+    ;
+
+    value perv_hash = Hashtbl.hash;
+
+
+    (* [No "eq"] for example *)
+    exception No of string
+    ;
+
+    value exn_no_eq = No "eq"
+      and exn_no_cmp = No "cmp"
+      and exn_no_hash = No "hash"
+    ;
+
+    module No =
+      struct
+        value eq : 'a -> 'a -> bool = fun _ _ -> raise exn_no_eq;
+        value cmp : 'a -> 'a -> cmp_res = fun _ _ -> raise exn_no_cmp;
+        value hash : 'a -> int = fun _ -> raise exn_no_hash;
+        value show : 'a -> string = fun _ -> "<abstract>";
+      end
+    ;
+
+
+    (*********************)
+
+    value topt (type tt) ?cmp ?eq ?hash ?show () =
+      let opt ov def =
+        match ov with
+        [ None -> def
+        | Some a -> a
+        ]
+      in
+      let eq = opt eq No.eq
+      and cmp = opt cmp No.cmp
+      and hash = opt hash No.hash
+      and show = opt show No.show in
+
+      let module Tmod =
+        struct
+          type t = tt;
+          value eq = eq;
+          value cmp = cmp;
+          value hash = hash;
+          value show = show;
+        end
+      in
+
+      let tmod = (module Tmod : TMOD with type t = tt)
+      and topt =
+      (
+        object
+          method eq = eq;
+          method cmp = cmp;
+          method hash = hash;
+          method show = show;
+        end
+      :
+        tall tt
+      )
+      in
+        (topt, tmod)
+    ;
+
+
+    value t_no : t 'a = fun (type tt) ->
+      object
+        method topt =
+          object
+            method eq (* : tt -> tt -> bool*) = No.eq;
+            method cmp = No.cmp;
+            method hash = No.hash;
+            method show = No.show;
+          end;
+        method tmod =
+          (module
+            (struct
+               type t = tt;
+               value eq = No.eq;
+               value show = No.show;
+               value hash = No.hash;
+               value cmp = No.cmp;
+             end
+            )
+          : TMOD with type t = tt
+          )
+        ;
+      end
+    ;
+
+
+    value teq = fun (type tt) ?show ~eq () ->
+    let (topt, tmod) = topt ?show ~eq () in
+    ((
+      object
+        method topt = topt;
+        method tmod = tmod;
+        method eq = eq;
+      end
+    ) : #teq 'a)
+    ;
+
+
+    value eq_of_opt ?eq ~cmp =
+      match eq with
+      [ None -> fun a b -> EQ == cmp a b
+      | Some eq -> eq
+      ]
+    ;
+
+    (* [?eq] is derived from [~cmp] if not specified *)
+
+    value tcmpeq = fun ?show ?eq ~cmp () -> 
+      let eq = eq_of_opt ?eq ~cmp in
+      let (topt, tmod) = topt ?show ~cmp ~eq () in
+    (((
+      object
+        method topt = topt;
+        method tmod = tmod;
+        method cmp = cmp;
+        method eq = eq;
+      end
+    ) : #teq 'a) : #tcmp 'a)
+    ;
+
+
+    (* receives all possible functions; could be changed in every new version.
+       [?eq] is derived from [~cmp] if not specified
+    *)
+
+    value tfull ~cmp ?eq ~hash ~show () =
+      let eq = eq_of_opt ?eq ~cmp in
+      let (topt, tmod) = topt ~cmp ~eq ~hash ~show () in
+      ((object
+          method topt = topt;
+          method tmod = tmod;
+          method cmp = cmp;
+          method eq = eq;
+          method hash = hash;
+          method show = show;
+        end
+       )
+       :
+       tfull 'a
+      )
+    ;
+
+
+    value topt_of_tmod (type a) (tmod : (module TMOD with type t = a)) : tall a
+     =
+      let module T = (value tmod : TMOD with type t = a) in
+      let cmp = T.cmp
+      and eq = T.eq
+      and hash = T.hash
+      and show = T.show
+      in
+      object
+        method cmp = cmp;
+        method eq = eq;
+        method hash = hash;
+        method show = show;
+      end
+    ;
+
+    value t_of_tmod (type a) (tmod : (module TMOD with type t = a)) : t a =
+      let topt = topt_of_tmod tmod in
+      ((
+      object
+        method tmod = tmod;
+        method topt = topt;
+      end
+      ) : t _)
+    ;
+
+    value tmod_cmp_of_tcmp (type a) tcmp =
+      let cmp = tcmp#cmp in
+      let topt = tcmp#topt in
+      let eq = topt#eq
+      and hash = topt#hash
+      and show = topt#show in
+      (module
+        (struct
+           type t = a;
+           value eq = eq;
+           value cmp = cmp;
+           value hash = hash;
+           value show = show;
+         end
+        )
+      : TMOD_CMP with type t = a
+      )
+    ;
+
+    value teq_of_t ~eq (t : t 'a) : teq 'a =
+      let () = assert (eq == t#topt#eq) in
+      let topt = t#topt
+      and tmod = t#tmod in
+      object
+        method topt = topt;
+        method tmod = tmod;
+        method eq = eq;
+      end
+    ;
+
+    (***************************************************)
+
+    value tint = tfull
+      ~cmp:perv_cmp
+      ~show:string_of_int
+      ~hash:(fun x -> x)
+      ()
+    ;
+
+    value tstring = tfull
+      ~cmp:perv_cmp
+      ~show:String.escaped
+      ~hash:perv_hash
+      ()
+    ;
+
+
+  end  (* Typeinfo *)
+;
+module type MONAD
+ =
+  sig
+    type t 'a;
+    value return : 'a -> t 'a;
+    value bind : ('a -> t 'b) -> t 'a -> t 'b;
+    value bind_rev : t 'a -> ('a -> t 'b) -> t 'b;
+    value ( >>= ) : t 'a -> ('a -> t 'b) -> t 'b;
+  end
+;
+type cmp_res = [ LT | EQ | GT ]
+;
+
+(***************************************************************)
+
+module type TMOD
+ =
+  sig
+    type t;
+    value eq : t -> t -> bool;
+    value cmp : t -> t -> cmp_res;
+    value hash : t -> int;
+    value show : t -> string;
+  end
+;
+
+type tmod 'a = (module TMOD with type t = 'a)
+;
+
+module type TMOD_CMP = TMOD
+;
+
+type tmod_cmp 'a = (module TMOD_CMP with type t = 'a)
+;
+
+(***************************************************************)
+
+class type tall ['a] =
+  object
+    method eq : 'a -> 'a -> bool;
+    method cmp : 'a -> 'a -> cmp_res;
+    method hash : 'a -> int;
+    method show : 'a -> string;
+  end
+;
+
+class type t ['a] =
+  object
+    method topt : tall 'a;
+    method tmod : tmod 'a;
+  end
+;
+
+class type teq ['a] =
+  object
+    inherit t ['a];
+    method eq : 'a -> 'a -> bool;
+  end
+;
+
+class type tcmp ['a] =
+  object
+    inherit t ['a];
+    method cmp : 'a -> 'a -> cmp_res;
+  end
+;
+
+class type thash ['a] =
+  object
+    inherit t ['a];
+    method hash : 'a -> int;
+  end
+;
+
+(* full type = type with all methods + topt + tmod *)
+
+class type tfull ['a] =
+  object
+    inherit t ['a];
+    inherit tall ['a];
+  end
+;
+
+(***************************************************************)
+
+value oeq : !'a . ~t:(#t 'a) -> 'a -> 'a -> bool = fun ~t -> t#topt#eq
+;
+
+value show : !'a . ~t:(#t 'a) -> 'a -> string = fun ~t -> t#topt#show
+;
+(* TODO: проверить, как trie over map будет жить в случае
+     nocasestringmap#merge .. casestringmap -- по идее, должно
+     обломать на сравнении типов map_rw [Nocasestring.t, 'v] vs
+     map_rw [Casestring.t, 'v].
+*)
+
 open OUnit;
 open Printf;
-open Cd_All;
+open Cd_All; open Cdt;
+
 module Cd = Cadastr;
 
 
+open Cd;
+open Typeinfo;
 
-module Test_trie = struct
+value tint_eq = teq
+  ~show:string_of_int
+  ~eq:(fun x y -> 0 = Pervasives.compare x y)
+  ()
+;
+
+value tint_cmp = tcmpeq
+  ~show:string_of_int
+  ~cmp:perv_cmp
+  ()
+;
+
+(* doesn't compile since tint_eq has no [cmp] method
+module TreeWithoutCmp =
+  Sfun.Tree(value (tmod_cmp_of_tcmp tint_eq) : TMOD_CMP with type t = int)
+;
+
+  but this example does compile:
+*)
+module TreeWithCmp =
+  Sfun.Tree(value (tmod_cmp_of_tcmp tint_cmp) : TMOD_CMP with type t = int)
+;
+
+
+value has_opt_cmp t =
+  t#topt#cmp != No.cmp
+;
+
+value tint_eq_has_no_opt_cmp () =
+  assert_equal False (has_opt_cmp tint_eq)
+;
+
+value opt_cmp t : 'a -> 'a -> cmp_res = t#topt#cmp
+;
+
+value tint_eq_cmp_raises () =
+  assert_raises (No "cmp")
+    (fun () -> opt_cmp tint_eq 123 456 = LT)
+;
+
+value tint_cmp_cmp_ok a b exp () =
+  assert_equal exp (opt_cmp tint_cmp a b)
+;
+
+
+value typedefs =
+  [
+    "tint_eq#topt#cmp raises exn" >:: tint_eq_cmp_raises
+  ; "tint_eq has no topt#cmp" >:: tint_eq_has_no_opt_cmp
+
+  ; "tint_cmp: 1<2" >:: tint_cmp_cmp_ok 1 2 LT
+  ; "tint_cmp: 2=2" >:: tint_cmp_cmp_ok 2 2 EQ
+  ; "tint_cmp: 3>2" >:: tint_cmp_cmp_ok 3 2 GT
+
+  ]
+;
+
+
+(*
+moved to cd_Typeinfo.ml:
+
+value tint = tfull
+  ~cmp:perv_cmp
+  ~show:string_of_int
+  ~hash:(fun x -> x)
+  ()
+;
+
+value tstring = tfull
+  ~cmp:perv_cmp
+  ~show:String.escaped
+  ~hash:perv_hash
+  ()
+;
+*)
+
+
+
+module IntTree = Cd.Sfun.Tree((value tint#tmod : TMOD with type t = int))
+;
+
 
 value trie_test_env () =
-  let module Tree = Cd.Sfun.Tree(Int) 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 the_empty = new Cd.Sfun.trie [] (new IntTree.map_rws_tree ()) in
+  let ex1 = (the_empty#replace [1;2] "1;2")#replace [1;3;4] "1;3;4" in
   let ex2 = ex1#remove [1;2] in
   let ex3 = ex1#add [1] "1" in
   let ex4 = ex2#add [1;3;4] "1;3;4 new" in
 ;
 
 
+(*
+
+value map_rwm_assoc_merge
+: ~flip:bool ->
+  ~mk1:(unit -> Cd.Tfun.map_rwm _ _) ->
+  ~mk2:(unit -> Cd.Tfun.map_rwm _ _) ->
+  unit
+= fun ~flip ~mk1 ~mk2 ->
+  let str_of_list : list string -> string
+    = fun lst -> sprintf "[%s]" & String.concat " ; " lst in
+  let m1 = (((mk1 ())#add 1 "1")#add 2 "2")#add 1 "11" in
+  let m2 = ((mk2 ())#add 1 "111")#add 3 "3" in
+  let (m1, m2) =
+    if flip
+    then (m2, m1)
+    else (m1, m2)
+  in
+  let m3 = m1#merge
+    (fun k v1s v2s ->
+       [ sprintf "%i: %s + %s"
+           k (str_of_list v1s) (str_of_list v2s) ]
+    )
+    m2
+  in
+  let sort = List.sort compare in
+  let m3list = sort &
+    m3#fold (fun acc k v -> [(sprintf "%i => %s" k v) :: acc]) [] in
+  let expected_list = sort &
+    [ "1 => 1: [11 ; 1] + [111]"
+    ; "2 => 2: [2] + []"
+    ; "3 => 3: [] + [3]"
+    ] in
+  assert_equal
+    ~printer:printer_list_string
+    m3list
+    expected_list
+;
+*)
+
+
+value map_rws_assoc_merge
+: ~flip:bool ->
+  ~mk1:(unit -> Cd.Tfun.map_rws _ _) ->
+  ~mk2:(unit -> Cd.Tfun.map_rws _ _) ->
+  ~scenario:([= `Some1 | `First_empty | `Second_empty | `Both_empty ]) ->
+  unit
+= fun ~flip ~mk1 ~mk2 ~scenario ->
+  let str_of_opt : option string -> string
+    = fun opt ->
+        match opt with
+        [ None -> "<none>"
+        | Some s -> s
+        ]
+  in
+  let m1 = mk1 ()
+  and m2 = mk2 () in
+  let m1 =
+    match scenario with
+    [ `Some1 | `Second_empty ->
+        ((m1#replace 1 "1")#replace 2 "2")#replace 1 "11"
+    | `First_empty | `Both_empty ->
+        m1
+    ]
+  and m2 =
+    match scenario with
+    [ `Some1 | `First_empty ->
+        (m2#replace 1 "111")#replace 3 "3"
+    | `Second_empty | `Both_empty ->
+        m2
+    ]
+  in
+  let (m1, m2) =
+    if flip
+    then (m2, m1)
+    else (m1, m2)
+  in
+  let m3 = m1#merge
+    (fun k v1o v2o ->
+       Some (sprintf "%i: %s + %s"
+              k (str_of_opt v1o) (str_of_opt v2o))
+    )
+    m2
+  in
+  let sort = List.sort compare in
+  let m3list = sort &
+    m3#fold (fun acc k v -> [(sprintf "%i => %s" k v) :: acc]) [] in
+  let expected_list = sort &
+    match (flip, scenario) with
+    [ (False, `Some1) ->
+        [ "1 => 1: 11 + 111"
+        ; "2 => 2: 2 + <none>"
+        ; "3 => 3: <none> + 3"
+        ]
+    | (False, `Second_empty) ->
+        [ "1 => 1: 11 + <none>"
+        ; "2 => 2: 2 + <none>"
+        ]
+    | (False, `First_empty) ->
+        [ "1 => 1: <none> + 111"
+        ; "3 => 3: <none> + 3"
+        ]
+
+    | (_, `Both_empty) ->
+        [
+        ]
+
+    | (True, `Some1) ->
+        [ "1 => 1: 111 + 11"
+        ; "2 => 2: <none> + 2"
+        ; "3 => 3: 3 + <none>"
+        ]
+
+    (* результаты такие, потому что сначала заполнение m1,m2,
+       а только потом их обмен при flip=True. *)
+    | (True, `Second_empty) ->
+        [ "1 => 1: <none> + 11"
+        ; "2 => 2: <none> + 2"
+        ]
+
+    | (True, `First_empty) ->
+        [ "1 => 1: 111 + <none>"
+        ; "3 => 3: 3 + <none>"
+        ]
+    ]
+  in
+  assert_equal
+    ~printer:printer_list_string
+    expected_list
+    m3list
+;
+
+
+value map_rws_merge =
+  let makes =
+    [ ("assoc", fun () ->
+        new Cd.Sfun.map_rws_assoc tint ~tval:tstring [])
+    ; ("tree", fun () ->
+        new IntTree.map_rws_tree ~tval:tstring ())
+    ]
+  and scenarios_txt =
+    [ (`Some1, "Some1")
+    ; (`First_empty, "First_empty")
+    ; (`Second_empty, "Second_empty")
+    ; (`Both_empty, "Both empty")
+    ]
+  in
+  let open Cd_List.List.Monad in
+  [False; True] >>= fun flip ->
+  makes >>= fun (n1, mk1) ->
+  makes >>= fun (n2, mk2) ->
+  scenarios_txt >>= fun (scenario, sc_txt) ->
+  return &
+    (sprintf "map_rws_assoc#merge %s%s%s (%s)"
+      n1 (if flip then "->" else "<-") n2
+      sc_txt
+    )
+     >:: (fun () -> map_rws_assoc_merge ~flip ~mk1 ~mk2 ~scenario)
+;
+
+
+(**********************************************************)
+
+
 value trie =
   [ "trie_test1" >:: trie_test1
   ; "trie_test2" >:: trie_test2
 ;
 
 
-value suite = 
-  "all" >:::
-    ( trie
-    @ strings
-    )
-;
-
-value (_ : list test_result) = 
-  run_test_tt_main suite
-;
-
-end;
-
-
 (* must not compile:
 module Q = struct
 open Strings.Utf8;
 end;
 *)
 
+(****************************************************************)
+
+value () = Printexc.record_backtrace True
+;
+
+
+value suite =
+  "all" >:::
+    ( []
+
+    @ trie
+    @ strings
+    @ map_rws_merge
+
+    @ typedefs
+    )
+;
+
+value (_ : list test_result) = 
+  run_test_tt_main suite
+;
+