new code for graph with history

src/grew_base.ml

@@ -294,6 +294,16 @@ module List_ = struct
     | (k,v)::t when key>k -> (k,v) :: (sort_remove_assoc key t)
     | (_,v)::t -> t
 
+  let rec sort_remove_assoc_opt key = function
+    | [] -> None
+    | (k,_)::_ when key<k -> None
+    | (k,v)::t when key>k ->
+      (match sort_remove_assoc_opt key t with
+        | None -> None
+        | Some new_t -> Some ((k,v) :: new_t)
+      )
+    | (_,v)::t (* key = k *) -> Some t
+
   exception Usort
 
   let rec usort_remove key = function

src/grew_base.mli

@@ -162,6 +162,8 @@ module List_: sig
       if [key] not found, the unchanged input list is returned *)
   val sort_remove_assoc: 'a -> ('a * 'b) list -> ('a * 'b) list
 
+  val sort_remove_assoc_opt: 'a -> ('a * 'b) list -> ('a * 'b) list option
+
   val foldi_left: (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a
 
   val prev_next_iter: (?prev:'a -> ?next:'a -> 'a -> unit) -> 'a list -> unit

src/grew_domain.ml

@@ -177,6 +177,12 @@ module Feature_domain = struct
       | _ -> false
     ) feature_domain
 
+  let is_num feature_domain feature_name =
+    List.exists (function
+      | Ast.Num fn when fn = feature_name -> true
+      | _ -> false
+    ) feature_domain
+
   let sub feature_domain name1 name2 =
     match (get name1 feature_domain, get name2 feature_domain) with
         | (_, Ast.Open _) -> true
@@ -270,6 +276,10 @@ module Domain = struct
   | Some (Feature feature_domain) | Some (Both (_, feature_domain)) -> Feature_domain.is_open feature_domain name
   | _ -> true
 
+  let is_num ?domain name = match domain with
+  | Some (Feature feature_domain) | Some (Both (_, feature_domain)) -> Feature_domain.is_num feature_domain name
+  | _ -> false
+
   let check_feature ?loc ?domain name value = match domain with
   | Some (Feature feature_domain) | Some (Both (_, feature_domain)) -> Feature_domain.check_feature ?loc ~feature_domain name value
   | _ -> ()

src/grew_domain.mli

@@ -68,9 +68,13 @@ module Domain : sig
   val get_label_style: ?domain:t -> int -> Label_domain.style option
 
   val edge_id_from_string: ?loc:Loc.t -> ?domain:t -> string -> int option
+
   (** [is_open_feature domain feature_name] returns [true] iff no domain is set or if [feature_name] is defined to be open in the current domain. *)
   val is_open_feature: ?domain: t -> feature_name -> bool
 
+  (** [is_num domain feature_name] returns [true] iff the domain is set and [feature_name] is defined to be numerical *)
+  val is_num: ?domain: t -> feature_name -> bool
+
   (** [check_feature ~loc domain feature_name feature_value] fails iff a domain is set and [feature_name,feature_value] is not defined in the current domain. *)
   val check_feature: ?loc:Loc.t -> ?domain: t -> feature_name -> feature_atom -> unit
 

src/grew_fs.ml

@@ -194,7 +194,7 @@ module G_fs = struct
     in loop t
 
   (* ---------------------------------------------------------------------- *)
-  let del_feat = List_.sort_remove_assoc
+  let del_feat = List_.sort_remove_assoc_opt
 
   (* ---------------------------------------------------------------------- *)
   let get_atom = List_.sort_assoc

src/grew_fs.mli

@@ -35,8 +35,8 @@ module G_fs: sig
   val set_feat: ?loc:Loc.t -> ?domain:Domain.t -> feature_name -> string -> t ->  t
 
   (** [del_feat feature_name t] remove the feature with name [feature_name] in [t].
-      If [t] does not contain such a feature, [t] is returned unchanged. *)
-  val del_feat:  string -> t ->  t
+      If [t] does not contain such a feature, None is returned. *)
+  val del_feat:  string -> t ->  t option
 
   val get_atom: string -> t -> value option
 

src/grew_graph.ml

@@ -590,7 +590,9 @@ module G_graph = struct
 
   (* -------------------------------------------------------------------------------- *)
   (* move out-edges (which respect cst [labels,neg]) from id_src are moved to out-edges out off node id_tar *)
-  let shift_out loc ?domain src_gid tar_gid is_gid_local label_cst graph =
+  let shift_out loc ?domain strict src_gid tar_gid is_gid_local label_cst graph =
+    let del_edges = ref [] and add_edges = ref [] in
+
     let src_node = Gid_map.find src_gid graph.map in
     let tar_node = Gid_map.find tar_gid graph.map in
 
@@ -603,24 +605,33 @@ module G_graph = struct
         if Label_cst.match_ ?domain label_cst edge && not (is_gid_local next_gid)
         then
           match Massoc_gid.add_opt next_gid edge acc_tar_next with
-          | Some new_acc_tar_next -> (Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
-          | None -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
+          | None when strict -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
+          | None ->
+            del_edges := (src_gid,edge,next_gid) :: !del_edges;
+            (Massoc_gid.remove next_gid edge acc_src_next, acc_tar_next)
+          | Some new_acc_tar_next ->
+            del_edges := (src_gid,edge,next_gid) :: !del_edges;
+            add_edges := (tar_gid,edge,next_gid) :: !add_edges;
+            (Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
         else (acc_src_next,acc_tar_next)
       )
       (src_next, tar_next) src_next in
 
-    { graph with map =
-      graph.map
+    let new_map = graph.map
       |> (Gid_map.add src_gid (G_node.set_next new_src_next src_node))
-      |> (Gid_map.add tar_gid (G_node.set_next new_tar_next tar_node))
-    }
+      |> (Gid_map.add tar_gid (G_node.set_next new_tar_next tar_node)) in
+    ( { graph with map = new_map },
+      !del_edges,
+      !add_edges
+    )
 
   (* -------------------------------------------------------------------------------- *)
-  let shift_in loc ?domain src_gid tar_gid is_gid_local label_cst graph =
-    { graph with map =
+  let shift_in loc ?domain strict src_gid tar_gid is_gid_local label_cst graph =
+    let del_edges = ref [] and add_edges = ref [] in
+    let new_map =
       Gid_map.mapi
         (fun node_id node ->
-          if is_gid_local node_id
+          if is_gid_local node_id (* shift does not move pattern edges *)
           then node
           else
             let node_next = G_node.get_next node in
@@ -634,8 +645,15 @@ module G_graph = struct
                 if Label_cst.match_ ?domain label_cst edge
                 then
                   match List_.usort_insert edge acc_node_tar_edges with
-                  | None -> Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
-                  | Some l -> (List_.usort_remove edge acc_node_src_edges, l)
+                  | None when strict ->
+                    Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
+                  | None ->
+                    del_edges := (node_id,edge,src_gid) :: !del_edges;
+                    (List_.usort_remove edge acc_node_src_edges, acc_node_tar_edges)
+                  | Some l ->
+                    del_edges := (node_id,edge,src_gid) :: !del_edges;
+                    add_edges := (node_id,edge,tar_gid) :: !add_edges;
+                    (List_.usort_remove edge acc_node_src_edges, l)
                 else (acc_node_src_edges,acc_node_tar_edges)
               )
               (node_src_edges, node_tar_edges) node_src_edges in
@@ -644,14 +662,17 @@ module G_graph = struct
                 |> (Massoc_gid.replace src_gid new_node_src_edges)
                 |> (Massoc_gid.replace tar_gid new_node_tar_edges) in
               G_node.set_next new_next node
-          ) graph.map
-    }
+          ) graph.map in
+    ( { graph with map = new_map },
+      !del_edges,
+      !add_edges
+    )
 
   (* -------------------------------------------------------------------------------- *)
-  let shift_edges loc ?domain src_gid tar_gid is_gid_local label_cst graph =
-    graph
-    |> (shift_in loc ?domain src_gid tar_gid is_gid_local label_cst)
-    |> (shift_out loc ?domain src_gid tar_gid is_gid_local label_cst)
+  let shift_edges loc ?domain strict src_gid tar_gid is_gid_local label_cst graph =
+    let (g1,de1,ae1) = shift_in loc ?domain strict src_gid tar_gid is_gid_local label_cst graph in
+    let (g2,de2,ae2) = shift_in loc ?domain strict src_gid tar_gid is_gid_local label_cst g1 in
+    (g2, de1 @ de2, ae1 @ ae2)
 
   (* -------------------------------------------------------------------------------- *)
   let set_feat ?loc ?domain graph node_id feat_name new_value =
@@ -690,8 +711,9 @@ module G_graph = struct
   (* -------------------------------------------------------------------------------- *)
   let del_feat graph node_id feat_name =
     let node = Gid_map.find node_id graph.map in
-    let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
-    { graph with map = Gid_map.add node_id (G_node.set_fs new_fs node) graph.map }
+    match G_fs.del_feat feat_name (G_node.get_fs node) with
+      | Some new_fs -> Some { graph with map = Gid_map.add node_id (G_node.set_fs new_fs node) graph.map }
+      | None -> None
 
   (* -------------------------------------------------------------------------------- *)
   let to_gr ?domain graph =
@@ -921,3 +943,76 @@ module G_graph = struct
     let conll = to_conll ?domain graph in
     Conll.to_dot conll
 end (* module G_graph *)
+
+
+
+(* ================================================================================ *)
+(* The module [Delta] defines a type for recording the effect of a set of commands on a graph *)
+(* It is used a key to detect egal graphs based on rewriting history *)
+module Delta = struct
+  type status = Add | Del
+
+  exception Inconsistent of string
+
+  (* the tree list are ordered *)
+  type t = {
+    del_nodes: Gid.t list;
+    edges: ((Gid.t * Label.t * Gid.t) * status) list;
+    feats: ((Gid.t * feature_name) * (value option)) list;
+  }
+
+  let empty = { del_nodes=[]; edges=[]; feats=[]; }
+
+  let del_node gid t =
+    match List_.usort_insert gid t.del_nodes with
+    | None -> raise (Inconsistent "del_node")
+    | Some new_del_nodes -> {
+      del_nodes= new_del_nodes;
+      edges = List.filter (fun ((g1,_,g2),_) -> g1 <> gid && g2 <> gid) t.edges;
+      feats = List.filter (fun ((g,_),_) -> g <> gid) t.feats;
+    }
+
+  let add_edge src lab tar t =
+    let rec loop = fun old -> match old with
+    | []                                                 -> ((src,lab,tar),Add)::old
+    | ((s,l,t),stat)::tail when (src,lab,tar) < (s,l,t)  -> ((src,lab,tar),Add)::old
+    | ((s,l,t),stat)::tail when (src,lab,tar) > (s,l,t)  -> ((s,l,t),stat)::(loop tail)
+    | ((s,l,t), Add)::tail (* (src,lab,tar) = (s,l,t) *) -> raise (Inconsistent "add_edge")
+    | ((s,l,t), Del)::tail (* (src,lab,tar) = (s,l,t) *) -> tail in
+    { t with edges = loop t.edges }
+
+  let del_edge src lab tar t =
+    let rec loop = fun old -> match old with
+    | []                                                 -> ((src,lab,tar),Del)::old
+    | ((s,l,t),stat)::tail when (src,lab,tar) < (s,l,t)  -> ((src,lab,tar),Del)::old
+    | ((s,l,t),stat)::tail when (src,lab,tar) > (s,l,t)  -> ((s,l,t),stat)::(loop tail)
+    | ((s,l,t), Del)::tail (* (src,lab,tar) = (s,l,t) *) -> raise (Inconsistent "del_edge")
+    | ((s,l,t), Add)::tail (* (src,lab,tar) = (s,l,t) *) -> tail in
+    { t with edges = loop t.edges }
+
+  let set_feat seed_graph gid feat_name new_val_opt t =
+    (* equal_orig is true iff new val is the same as the one in seed_graph *)
+    let equal_orig = (new_val_opt = G_fs.get_atom feat_name (G_node.get_fs (G_graph.find gid seed_graph))) in
+    let rec loop = fun old -> match old with
+    | [] when equal_orig                                             -> []
+    | []                                                             -> [(gid,feat_name), new_val_opt]
+    | ((g,f),_)::tail when (gid,feat_name) < (g,f) && equal_orig     -> old
+    | ((g,f),v)::tail when (gid,feat_name) < (g,f)                   -> ((gid,feat_name), new_val_opt)::old
+    | ((g,f),v)::tail when (gid,feat_name) > (g,f)                   -> ((g,f),v)::(loop tail)
+    | ((g,f),_)::tail when (* (g,f)=(gid,feat_name) && *) equal_orig -> tail
+    | ((g,f),_)::tail (* when (g,f)=(gid,feat_name) *)               -> ((g,f), new_val_opt) :: tail in
+    { t with feats = loop t.feats }
+end (* module Delta *)
+
+module Graph_with_history = struct
+  type t = {
+    seed: G_graph.t;
+    delta: Delta.t;
+    graph: G_graph.t;
+  }
+
+  (* WARNING: compare is correct only on data with the same seed! *)
+  let compare t1 t2 = Pervasives.compare t1.delta t2.delta
+end
+
+module Graph_with_history_set = Set.Make (Graph_with_history)

src/grew_graph.mli

@@ -136,14 +136,50 @@ module G_graph: sig
   val add_after: Gid.t -> t -> (Gid.t * t)
   val add_unordered: t -> (Gid.t * t)
 
-  (** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
-  val shift_in: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
-
-  (** move all out-edges from id_src are moved to out-edges out off node id_tar *)
-  val shift_out: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
-
-  (** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
-  val shift_edges: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
+  (** shift all crown-edges ending in [src_gid] to edges ending in [tar_gid] *)
+  val shift_in:
+    Loc.t ->            (* localization of the command *)
+    ?domain:Domain.t ->
+    bool ->             (* true iff strict rewriting *)
+    Gid.t ->            (* [src_gid] the source gid of the "shift_in" *)
+    Gid.t ->            (* [tar_gid] the target gid of the "shift_in" *)
+    (Gid.t -> bool) ->  (* a locality test: true iff the node is a pattern node *)
+    Label_cst.t ->      (* what are the constraint on edge label *)
+    t ->                (* input graph *)
+      ( t *                                (* output graph *)
+        (Gid.t * G_edge.t * Gid.t) list *  (* list of really deleted edges *)
+        (Gid.t * G_edge.t * Gid.t) list    (* list of really added edges *)
+      )
+
+  (** shift all crown-edges starting from [src_gid] to edges starting from [tar_gid] *)
+  val shift_out:
+    Loc.t ->            (* localization of the command *)
+    ?domain:Domain.t ->
+    bool ->             (* true iff strict rewriting *)
+    Gid.t ->            (* [src_gid] the source gid of the "shift_out" *)
+    Gid.t ->            (* [tar_gid] the target gid of the "shift_out" *)
+    (Gid.t -> bool) ->  (* a locality test: true iff the node is a pattern node *)
+    Label_cst.t ->      (* what are the constraint on edge label *)
+    t ->                (* input graph *)
+      ( t *                                (* output graph *)
+        (Gid.t * G_edge.t * Gid.t) list *  (* list of really deleted edges *)
+        (Gid.t * G_edge.t * Gid.t) list    (* list of really added edges *)
+      )
+
+  (** move all incident crown-edges from/to [src_gid] are moved to incident edges on node [tar_gid] from graph *)
+  val shift_edges:
+    Loc.t ->            (* localization of the command *)
+    ?domain:Domain.t ->
+    bool ->             (* true iff strict rewriting *)
+    Gid.t ->            (* [src_gid] the source gid of the "shift_edges" *)
+    Gid.t ->            (* [tar_gid] the target gid of the "shift_edges" *)
+    (Gid.t -> bool) ->  (* a locality test: true iff the node is a pattern node *)
+    Label_cst.t ->      (* what are the constraint on edge label *)
+    t ->                (* input graph *)
+      ( t *                                (* output graph *)
+        (Gid.t * G_edge.t * Gid.t) list *  (* list of really deleted edges *)
+        (Gid.t * G_edge.t * Gid.t) list    (* list of really added edges *)
+      )
 
   (** [update_feat domain 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].
@@ -153,8 +189,8 @@ module G_graph: sig
   val set_feat: ?loc:Loc.t -> ?domain:Domain.t -> t -> Gid.t -> string -> string -> t
 
   (** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
-      If the feature is not present, [graph] is returned. *)
-  val del_feat: t -> Gid.t -> string -> t
+      If the feature is not present, None is returned. *)
+  val del_feat: t -> Gid.t -> string -> t option
 
   (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
   (* Output functions *)
@@ -166,3 +202,26 @@ module G_graph: sig
   val to_conll: ?domain:Domain.t -> t -> Conll.t
   val to_conll_string: ?domain:Domain.t -> t -> string
 end (* module G_graph *)
+
+module Delta : sig
+  type t
+
+  val empty: t
+
+  val del_node: Gid.t -> t -> t
+  val add_edge: Gid.t -> Label.t -> Gid.t -> t -> t
+  val del_edge: Gid.t -> Label.t -> Gid.t -> t -> t
+  val set_feat: G_graph.t -> Gid.t -> feature_name -> value option -> t -> t
+end
+
+module Graph_with_history : sig
+  type t = {
+    seed: G_graph.t;
+    delta: Delta.t;
+    graph: G_graph.t;
+  }
+
+  val compare: t -> t -> int
+end
+
+module Graph_with_history_set : Set.S with type elt = Graph_with_history.t

src/grew_grs.ml

@@ -953,4 +953,4 @@ module Grs = struct
       | New_ast.If (_,s1, s2) -> (loop pointed s1) || (loop pointed s2)
       | New_ast.Try (s) -> loop pointed s in
     loop (top grs) (Parser.strategy strat)
-end
+end (* module Grs *)

src/grew_rule.mli

@@ -128,5 +128,10 @@ module Rule : sig
 
 
 
+  val onf_apply: ?domain: Domain.t -> t -> G_graph.t -> G_graph.t option
+  val gwh_apply: ?domain: Domain.t -> t -> Graph_with_history.t -> Graph_with_history_set.t
+
+
+
 
 end (* module Rule *)