move from 'int' to 'Gid.t'/'Pid.t'... it compiles

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7419 7838e531-6607-4d57-9587-6c381814729c

.gitignore

+*.cmo
+*.cmi
+*.o
+*.cmx
+*.annot
+*.a
+*.cma
+*.cmxa
+Makefile
+
+confdefs.h
+config.log
+config.status

src/.gitignore

+# file generated by the Makefile !
+
+libgrew.mli

src/grew_command.ml

@@ -7,8 +7,8 @@ open Grew_edge
 open Grew_fs
 
 module Command  = struct 
-  type pid = int (* the int in the pattern *)
-  type gid = int (* the int in the graph *)
+  type pid = Pid.t
+  type gid = Gid.t
 	
   type cnode =       (* a command node is either: *)
     | Pid of pid     (* a node identified in the pattern *)

src/grew_command.mli

@@ -3,8 +3,8 @@ open Grew_utils
 open Grew_edge
 
 module Command : sig
-  type pid = int (* the int in the pattern *)
-  type gid = int (* the int in the graph *)
+  type pid = Pid.t
+  type gid = Gid.t
 
   type cnode =       (* a command node is either: *)
     | Pid of pid     (* a node identified in the pattern *)

src/grew_graph.mli

@@ -5,14 +5,29 @@ open Grew_node
 open Grew_utils
 open Grew_command
 
-module Deco: sig
-  type t = 
-      { nodes: int list;
-	edges: (int * Label.t * int) list;
+(* ================================================================================ *)
+module P_deco: sig
+  type t =
+      { nodes: Pid.t list;
+	edges: (Pid.t * P_edge.t * Pid.t) list;
       }
+
+  val empty:t
+end
+(* ================================================================================ *)
+
+(* ================================================================================ *)
+module G_deco: sig
+  type t =
+      { nodes: Gid.t list;
+	edges: (Gid.t * G_edge.t * Gid.t) list;
+      }
+
   val empty:t
 end
+(* ================================================================================ *)
 
+(* ================================================================================ *)
 module P_graph: sig
   type t = P_node.t Pid_map.t
 
@@ -41,6 +56,7 @@ module P_graph: sig
   val roots: t -> Pid.t list
 
 end
+(* ================================================================================ *)
 
 
 
@@ -64,37 +80,37 @@ module G_graph: sig
   val of_conll: ?loc:Loc.t -> Conll.line list -> t
 
   val to_gr: t -> string
-  val to_dot: ?main_feat:string -> ?deco:Deco.t -> t -> string
+  val to_dot: ?main_feat:string -> ?deco:G_deco.t -> t -> string
   val to_sentence: ?main_feat:string -> t -> string
-  val to_dep: ?main_feat:string -> ?deco:Deco.t -> t -> string
+  val to_dep: ?main_feat:string -> ?deco:G_deco.t -> t -> string
 
 
   type concat_item =
     | Feat of (Gid.t * string)
     | String of string
 
-  val add_edge: t -> int -> G_edge.t -> int -> t option
-  val del_edge : ?edge_ident: string -> Loc.t -> t -> int -> G_edge.t -> int -> t
-  val del_node : t -> int -> t
+  val add_edge: t -> Gid.t -> G_edge.t -> Gid.t -> t option
+  val del_edge : ?edge_ident: string -> Loc.t -> t -> Gid.t -> G_edge.t -> Gid.t -> t
+  val del_node : t -> Gid.t -> t
 
-  val add_neighbour : Loc.t -> t -> int -> G_edge.t -> (int * t) 
-  val merge_node : Loc.t -> t -> int -> int -> t option
+  val add_neighbour : Loc.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t) 
+  val merge_node : Loc.t -> t -> Gid.t -> Gid.t -> t option
 
-  val shift_in : Loc.t -> t -> int -> int -> t
-  val shift_out : Loc.t -> t -> int -> int -> t
-  val shift_edges : Loc.t -> t -> int -> int -> t
+  val shift_in : Loc.t -> t -> Gid.t -> Gid.t -> t
+  val shift_out : Loc.t -> t -> Gid.t -> Gid.t -> t
+  val shift_edges : Loc.t -> t -> Gid.t -> Gid.t -> t
 
   (** [update_feat tar_id tar_feat_name concat_items] sets the feature of the node [tar_id] 
       with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
       It returns both the new graph and the new feature value produced as the second element *)
-  val update_feat: ?loc:Loc.t -> t -> int -> string -> concat_item list -> (t * string)
+  val update_feat: ?loc:Loc.t -> t -> Gid.t -> string -> concat_item list -> (t * string)
 
-  val set_feat: ?loc:Loc.t -> t -> int -> string -> string -> t
+  val set_feat: ?loc:Loc.t -> t -> Gid.t -> string -> string -> t
 
-  val del_feat: t -> int -> string -> t
+  val del_feat: t -> Gid.t -> string -> t
 
   (** [edge_out t id edge] returns true iff there is an out-edge from the node [id] with a label compatible with [edge] *)
-  val edge_out: t -> int -> P_edge.t -> bool
+  val edge_out: t -> Gid.t -> P_edge.t -> bool
 
   val equals: t -> t -> bool
 

src/grew_node.ml

@@ -10,7 +10,7 @@ module G_node = struct
   type t = {
       fs: G_fs.t;
       pos: int option;
-      next: G_edge.t Massoc.t;
+      next: G_edge.t Massoc_gid.t;
     }
 
   let get_fs t = t.fs
@@ -18,12 +18,12 @@ module G_node = struct
 
   let set_fs t fs = {t with fs = fs}
 
-  let empty = { fs = G_fs.empty; pos = None; next = Massoc.empty }
+  let empty = { fs = G_fs.empty; pos = None; next = Massoc_gid.empty }
 
   let to_string t = 
     Printf.sprintf "  fs=[%s]\n  next=%s\n" 
       (G_fs.to_string t.fs)
-      (Massoc.to_string G_edge.to_string t.next)
+      (Massoc_gid.to_string G_edge.to_string t.next)
 
   let to_gr t = 
     sprintf "%s [%s] " 
@@ -31,7 +31,7 @@ module G_node = struct
       (G_fs.to_gr t.fs)
 
   let add_edge g_edge gid_tar t =
-    match Massoc.add gid_tar g_edge t.next with
+    match Massoc_gid.add gid_tar g_edge t.next with
     | Some l -> Some {t with next = l}
     | None -> None
 
@@ -39,30 +39,30 @@ module G_node = struct
     (ast_node.Ast.node_id, 
      { fs = G_fs.build ast_node.Ast.fs;
        pos = ast_node.Ast.position;
-       next = Massoc.empty;
+       next = Massoc_gid.empty;
      } )
 
   let of_conll line = {
       fs = G_fs.of_conll line;
       pos = Some line.Conll.num;
-      next = Massoc.empty;
+      next = Massoc_gid.empty;
     }
     
     
-  let remove id_tar label t = {t with next = Massoc.remove id_tar label t.next}
+  let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
       
   let remove_key node_id t = 
-    try {t with next = Massoc.remove_key node_id t.next} with Not_found -> t
+    try {t with next = Massoc_gid.remove_key node_id t.next} with Not_found -> t
 
   let merge_key ?(strict=false) src_id tar_id t = 
-    try Some {t with next = Massoc.merge_key src_id tar_id t.next}
-    with Massoc.Duplicate -> if strict then None else Some t
+    try Some {t with next = Massoc_gid.merge_key src_id tar_id t.next}
+    with Massoc_gid.Duplicate -> if strict then None else Some t
 
   let shift_out ?(strict=false) src_t tar_t = 
-    try Some {tar_t with next = Massoc.disjoint_union src_t.next tar_t.next}
-    with Massoc.Not_disjoint -> if strict then None else Some tar_t
+    try Some {tar_t with next = Massoc_gid.disjoint_union src_t.next tar_t.next}
+    with Massoc_gid.Not_disjoint -> if strict then None else Some tar_t
 
-  let rm_out_edges t = {t with next = Massoc.empty}
+  let rm_out_edges t = {t with next = Massoc_gid.empty}
 
 
   let build_neighbour t = {empty with pos = match t.pos with Some x -> Some (x+1) | None -> None}

src/grew_node.mli

@@ -13,21 +13,21 @@ module G_node: sig
   val to_gr: t -> string
 
   val get_fs: t -> G_fs.t
-  val get_next: t -> G_edge.t Massoc.t
+  val get_next: t -> G_edge.t Massoc_gid.t
 
   val set_fs: t -> G_fs.t -> t
 
 (* FIXME move Gid up and replace int by Gid.t *) 
-  val remove: int -> G_edge.t -> t -> t 
+  val remove: Gid.t -> G_edge.t -> t -> t 
 
-  val remove_key: int -> t -> t 
+  val remove_key: Gid.t -> t -> t 
 
-  val merge_key: ?strict:bool -> int -> int -> t -> t option
+  val merge_key: ?strict:bool -> Gid.t -> Gid.t -> t -> t option
   val shift_out: ?strict:bool -> t -> t -> t option
 
   val rm_out_edges: t -> t
 
-  val add_edge: G_edge.t -> int -> t -> t option
+  val add_edge: G_edge.t -> Gid.t -> t -> t option
   val build: Ast.node -> (Id.name * t)
   val of_conll: Conll.line -> t
 

src/grew_rule.ml

@@ -63,7 +63,7 @@ module Rule = struct
   type pid = Pid.t
    
   (* the [gid] type is used for graph identifier *)
-  type gid = int
+  type gid = Gid.t
 
   (* the rewriting depth is bounded to stop rewriting when the system is not terminating *) 
   let max_depth = ref 500
@@ -280,8 +280,8 @@ module Rule = struct
   let a_match_add edge matching = {matching with a_match = edge::matching.a_match }
 
   let up_deco matching = 
-    { Deco.nodes = Pid_map.fold (fun _ gid acc -> gid::acc) matching.n_match [];
-      Deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
+    { G_deco.nodes = Pid_map.fold (fun _ gid acc -> gid::acc) matching.n_match [];
+      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
     }
 
   let find cnode ?loc (matching, created_nodes) =
@@ -296,14 +296,14 @@ module Rule = struct
 
   let down_deco (matching,created_nodes) commands =
     {
-     Deco.nodes = List.fold_left
+     G_deco.nodes = List.fold_left
        (fun acc -> function
          | (Command.UPDATE_FEAT (tar_cn,_,_),loc)
          | (Command.SHIFT_EDGE (_,tar_cn),loc) -> 
              (find tar_cn (matching, created_nodes)) :: acc
          | _ -> acc
        ) [] commands;
-     Deco.edges = List.fold_left
+     G_deco.edges = List.fold_left
        (fun acc -> function 
          | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->  
              (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
@@ -364,7 +364,7 @@ module Rule = struct
         let gid = Pid_map.find pid matching.n_match in
         gid_map_exists (* should be Gid_map.exists with ocaml 3.12 *)
           (fun _ node ->
-            List.exists (fun e -> P_edge.compatible edge e) (Massoc.assoc gid (G_node.get_next node))
+            List.exists (fun e -> P_edge.compatible edge e) (Massoc_gid.assoc gid (G_node.get_next node))
           ) graph.G_graph.map
     | Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
         let gnode1 = Gid_map.find (Pid_map.find pid1 matching.n_match) graph.G_graph.map in
@@ -393,7 +393,7 @@ module Rule = struct
               let src_gid = Pid_map.find src_pid partial.sub.n_match in
               let tar_gid = Pid_map.find tar_pid partial.sub.n_match in
               let src_gnode = G_graph.find src_gid graph in
-              let g_edges = Massoc.assoc tar_gid (G_node.get_next src_gnode) in
+              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
               
               match P_edge.match_list p_edge g_edges with
               | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
@@ -410,7 +410,7 @@ module Rule = struct
             let candidates = (* candidates (of type (gid, matching)) for m(tar_pid) = gid) with new partial matching m *)
               let src_gid = Pid_map.find src_pid partial.sub.n_match in
               let src_gnode = G_graph.find src_gid graph in
-              Massoc.fold_left 
+              Massoc_gid.fold
                 (fun acc gid_next g_edge ->
                   match P_edge.match_ p_edge g_edge with
                   | P_edge.Fail -> (* g_edge does not fit, no new candidate *)

src/grew_types.ml

 open Grew_graph
 
 type graph = G_graph.t
-type deco = Deco.t
+type deco = G_deco.t
 
 type module_name = string
 
 type rule_app = {
     rule_name: string;
-    up: Deco.t;
-    down: Deco.t;
+    up: G_deco.t;
+    down: G_deco.t;
   }
 
 (* the main type for display the result of a rewriting *)
@@ -24,6 +24,6 @@ and big_step = {
     small_step: (G_graph.t * rule_app) list;
   }
 
-let to_dot_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dot ?main_feat graph ~deco
-let to_dep_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dep ?main_feat ~deco graph
+let to_dot_graph ?main_feat ?(deco=G_deco.empty) graph = G_graph.to_dot ?main_feat graph ~deco
+let to_dep_graph ?main_feat ?(deco=G_deco.empty) graph = G_graph.to_dep ?main_feat ~deco graph
 let to_gr_graph graph = G_graph.to_gr graph 

src/grew_types.mli

@@ -4,7 +4,7 @@ open Grew_graph
 
 (**/**)
 type graph = G_graph.t
-type deco = Deco.t
+type deco = G_deco.t
 (**/**)
 
 type module_name = string

src/grew_utils.ml

@@ -104,28 +104,6 @@ module Pid_map =
 (* union of two maps*)
     let union_map m m' = fold (fun k v m'' -> (add k v m'')) m m'
 
-    exception MatchNotInjective
-
-(*
- * union of two injective maps having different ranges :
- * \forall x \neq y \in m: m(x) \neq m(y)
- * \forall x' \neq y' \in m': m'(x) \neq m'(y)W
- * \forall x \in m /\ m': m(x) = m'(x)
- * \forall x \in m : x \not\in\m' => \forall y \in m' m(x) \neq m'(y)
- *)
-    let union_if m m' = 
-      let keys_m = keys m in
-      let keys_m' = keys m' in
-      let inter_keys = IntSet.inter keys_m keys_m' in
-      if IntSet.for_all (fun elt -> (find elt m) = (find elt m')) inter_keys
-      then 
-        let keys_s_m' = IntSet.diff keys_m' inter_keys in
-        let range_m = range keys_m m in 
-        let range_m' = range keys_s_m' m' in
-        if (IntSet.inter range_m range_m') = IntSet.empty
-        then union_map m m'
-        else raise MatchNotInjective
-      else raise MatchNotInjective          
   end (* module Pid_map *)
 (* ================================================================================ *)
     
@@ -133,8 +111,15 @@ module Pid_map =
 
 (* ================================================================================ *)
 module Gid = struct
-  type t = int
+  type t =
+    | Old of int
+    | New of int * int (* identifier for "created nodes" *)
+
   let compare = Pervasives.compare
+
+  let to_string = function
+    | Old i -> sprintf "%d" i
+    | New (i,j) -> sprintf"%d__%d" i j
 end
 
 module Gid_map = Map.Make (Gid)
@@ -361,6 +346,141 @@ module List_ = struct
       )
 end
 
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+
+module type S =
+  sig
+    type key
+
+    type +'a t
+
+    val empty: 'a t
+
+    (* an empty list returned if the key is undefined *) 
+    val assoc: key -> 'a t -> 'a list
+
+    val is_empty: 'a t -> bool
+
+    val to_string: ('a -> string) -> 'a t -> string
+
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+
+    val add: key -> 'a -> 'a t -> 'a t option
+
+    val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
+
+    (* raise Not_found if no (key,elt) *)
+    val remove: key -> 'a -> 'a t -> 'a t
+
+    (* raise Not_found if no (key,elt) *)
+    val remove_key: key -> 'a t -> 'a t
+
+    (* [mem key value t ] test if the couple (key, value) is in the massoc [t]. *)
+    val mem: key -> 'a -> 'a t -> bool
+
+    (* mem_key key t] tests is [key] is associated to at least one value in [t]. *)
+    val mem_key: key -> 'a t -> bool
+
+    exception Not_disjoint
+    val disjoint_union: 'a t -> 'a t -> 'a t 
+
+    exception Duplicate
+    val merge_key: key -> key -> 'a t -> 'a t
+
+    val exists: (key -> 'a -> bool) -> 'a t -> bool
+  end
+
+
+module Massoc_make (Ord: OrderedType) = struct
+  module M = Map.Make (Ord)
+
+  type key = Ord.t
+
+  type 'a t = ('a list) M.t
+
+  let empty = M.empty
+
+  let is_empty t = (t=empty)
+
+  let assoc key t = 
+    try M.find key t 
+    with Not_found -> []
+
+  let to_string _ _ = failwith "Not implemted" 
+
+  let iter fct t =
+    M.iter 
+      (fun key list -> List.iter (fun elt -> fct key elt) list
+      ) t
+
+  let add key elt t = 
+    try
+      let list = M.find key t in
+      match List_.usort_insert elt list with 
+        | Some l -> Some (M.add key l t)
+        | None -> None
+    with Not_found -> Some (M.add key [elt] t)
+
+  let fold fct init t =
+    M.fold
+      (fun key list acc ->
+        List.fold_left 
+          (fun acc2 elt ->
+            fct acc2 key elt)
+          acc list)
+      t init
+      
+  (* Not found raised in the value is not defined *)
+  let remove key value t =
+    match M.find key t with
+      | [one] when one=value -> M.remove key t
+      | old -> M.add key (List_.usort_remove value old) t
+
+  let rec remove_key key t = M.remove key t
+
+  let rec mem key value t =
+    try List_.sort_mem value (M.find key t)
+    with Not_found -> false
+
+  let rec mem_key key t = M.mem key t
+
+  exception Not_disjoint
+
+  let disjoint_union t1 t2 =
+    M.fold 
+      (fun key list acc ->
+        try 
+          let old = M.find key acc in
+          M.add key (List_.sort_disjoint_union list old) acc
+        with
+          | Not_found -> M.add key list acc
+          | List_.Not_disjoint -> raise Not_disjoint
+      ) t1 t2
+
+  exception Duplicate
+    
+  let merge_key i j t =
+    try
+      let old_i = M.find i t in
+      let old_j = try M.find j t with Not_found -> [] in
+      M.add j (List_.sort_disjoint_union old_i old_j) (M.remove i t)
+    with 
+      | Not_found -> (* no key i *) t
+      | List_.Not_disjoint -> raise Duplicate
+
+  let exists fct t =
+    M.exists
+      (fun key list ->
+        List.exists (fun elt -> fct key elt) list
+      ) t
+end (* module Massoc_make *)
+
+module Massoc_gid = Massoc_make (Gid)
 
 module Massoc = struct
   (* Massoc is implemented with caml lists *)
@@ -458,7 +578,7 @@ module Massoc = struct
 
 
   let exists fct t = List.exists (fun (key,list) -> List.exists (fun value -> fct key value) list) t
-end
+end (* module Massoc *)
 
 module Error = struct
 
@@ -478,8 +598,6 @@ module Error = struct
   let bug ?loc = Printf.ksprintf (bug_ ?loc)
 end
 
-
-
 module Id = struct
   type name = string
 

src/grew_utils.mli

@@ -40,14 +40,19 @@ module Pid : sig type t = int end
 (* [Pid_map] is the map used in pattern graphs *)
 module Pid_map : sig
   include Map.S with type key = int
-  exception MatchNotInjective
+
   val exists: (key -> 'a -> bool) -> 'a t -> bool
-  val union_if: int t -> int t -> int t
 end
 
 (* ================================================================================ *)
 (* [Gid] describes identifier used in full graphs *)
-module Gid : sig type t = int end
+module Gid : sig
+  type t = 
+    | Old of int
+    | New of int * int (* identifier for "created nodes" *)
+
+  val to_string: t -> string
+end
 
 (* ================================================================================ *)
 (* [Gid_map] is the map used in full graphs *)
@@ -124,6 +129,67 @@ module List_: sig
   val foldi_left: (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a
 end
 
+module type OrderedType =
+  sig
+    type t
+      (** The type of the map keys. *)
+    val compare : t -> t -> int
+      (** A total ordering function over the keys.
+          This is a two-argument function [f] such that
+          [f e1 e2] is zero if the keys [e1] and [e2] are equal,
+          [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+          and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+          Example: a suitable ordering function is the generic structural
+          comparison function {!Pervasives.compare}. *)
+  end
+(** Input signature of the functor {!Map.Make}. *)
+
+
+module type S =
+  sig
+    type key
+    
+    type +'a t
+
+    val empty: 'a t
+
+    (* an empty list returned if the key is undefined *) 
+    val assoc: key -> 'a t -> 'a list
+
+    val is_empty: 'a t -> bool
+
+    val to_string: ('a -> string) -> 'a t -> string
+
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+
+    val add: key -> 'a -> 'a t -> 'a t option
+
+    val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
+
+    (* raise Not_found if no (key,elt) *)
+    val remove: key -> 'a -> 'a t -> 'a t
+