add new lexicon in matching type

src/grew_fs.ml

@@ -432,14 +432,14 @@ module P_fs = struct
 
   exception Fail
 
-  let match_ ?param p_fs g_fs =
+  let match_ ?(lexicons=[]) p_fs g_fs =
     let p_fs_wo_pos =
       try List.remove_assoc "position" p_fs
       with Not_found -> p_fs in
     let rec loop acc = function
       | [], _ -> acc
 
-      (* a feature_name present only in instance -> Skip it *)
+      (* a feature_name present only in graph -> Skip it *)
       | ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)
 
       (* Two next cases: p_fs requires for the absence of a feature -> OK *)
@@ -451,26 +451,25 @@ module P_fs = struct
       | ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
 
       (* Next cases: fn_pat = fn *)
-      | ((_, {P_feature.cst=cst; P_feature.in_param=in_param})::t_pat, (_, atom)::t) ->
-
-        (* check for the constraint part and fail if needed *)
-        let () = match cst with
-        | P_feature.Absent -> raise Fail
-        | P_feature.Equal fv when not (List_.sort_mem atom fv) -> raise Fail
-        | P_feature.Different fv when List_.sort_mem atom fv -> raise Fail
-        | _ -> () in
-
-        (* if constraint part don't fail, look for lexical parameters *)
-        match (acc, in_param) with
-          | (_,[]) -> loop acc (t_pat,t)
-          | (None,_) -> Log.bug "[P_fs.match_] Parametrized constraint in a non-parametrized rule"; exit 2
-          | (Some param, [index]) ->
-            (match Lex_par.select index (string_of_value atom) param with
-              | [] -> raise Fail
-              | new_param -> loop (Some new_param) (t_pat,t)
-            )
-          | _ -> Error.bug "[P_fs.match_] several different parameters contraints for the same feature is not implemented" in
-    loop param (p_fs_wo_pos,g_fs)
+      | ((_, {P_feature.cst=P_feature.Absent})::_, (_, atom)::t) -> raise Fail
+      | ((_, {P_feature.cst=P_feature.Equal fv})::_, (_, atom)::t) when not (List_.sort_mem atom fv) -> raise Fail
+      | ((_, {P_feature.cst=P_feature.Different fv})::_, (_, atom)::t) when List_.sort_mem atom fv -> raise Fail
+
+      | ((_, {P_feature.cst=P_feature.Equal_lex (lex_name,field)})::t_pat, (_, atom)::t) ->
+        begin
+          try
+            let lexicon = List.assoc lex_name acc in
+            match Lexicon.select field (string_of_value atom) lexicon with
+            | None -> raise Fail
+            | Some new_lexicon ->
+              let new_acc = (lex_name, new_lexicon) :: (List.remove_assoc lex_name acc) in
+              loop new_acc (t_pat, t)
+          with
+          | Not_found -> failwith "TODO"
+        end
+      | _ -> acc
+
+    in loop lexicons (p_fs_wo_pos,g_fs)
 
   exception Fail_unif
   let unif fs1 fs2 =

src/grew_fs.mli

@@ -92,7 +92,9 @@ module P_fs: sig
       If [param] is [None], it returns [None] if matching succeeds and else raise [Fail].
       If [param] is [Some p], it returns [Some p'] if matching succeeds and else raise [Fail].
    *)
-  val match_: ?param:Lex_par.t -> t -> G_fs.t -> Lex_par.t option
+  val match_:
+        ?lexicons:(string * Grew_types.Lexicon.t) list ->
+        t -> G_fs.t -> (string * Grew_types.Lexicon.t) list
 
   (** [check_position ?parma position pfs] checks wheter [pfs] is compatible with a node at [position].
       It returns [true] iff [pfs] has no requirement about position ok if the requirement is satisfied. *)

src/grew_node.ml

@@ -173,13 +173,14 @@ module P_node = struct
     | Some l -> Some {t with next = l}
     | None -> None
 
-  let match_ ?param p_node g_node =
+
+  let match_ ?lexicons p_node g_node =
     (* (match param with None -> printf "<None>" | Some p -> printf "<Some>"; Lex_par.dump p); *)
     match G_node.get_position g_node with
-    | G_node.Unordered _ -> None
+    | G_node.Unordered _ -> raise P_fs.Fail (* TOOO: check this return !! *)
     | G_node.Ordered p ->
-      if P_fs.check_position ?param (Some p) p_node.fs
-      then P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
+      if P_fs.check_position (Some p) p_node.fs
+      then P_fs.match_ ?lexicons p_node.fs (G_node.get_fs g_node)
       else raise P_fs.Fail
 
   let compare_pos t1 t2 = Pervasives.compare t1.loc t2.loc

src/grew_node.mli

@@ -106,7 +106,9 @@ module P_node: sig
 
   val add_edge: P_edge.t -> Pid.t -> t -> t option
 
-  val match_: ?param: Lex_par.t -> t -> G_node.t -> Lex_par.t option
+  val match_:
+   ?lexicons:(string * Grew_types.Lexicon.t) list ->
+   t -> G_node.t -> (string * Grew_types.Lexicon.t) list
 
   val compare_pos: t -> t -> int
 end

src/grew_rule.mli

@@ -110,7 +110,7 @@ module Rule : sig
   val node_matching: pattern -> G_graph.t -> matching -> (string * float) list
 
   (** [match_in_graph rule graph] returns the list of matching of the pattern of the rule into the graph *)
-  val match_in_graph: ?domain:Domain.t -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
+  val match_in_graph: ?domain:Domain.t -> ?lexicons: (string * Lexicon.t) list -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
 
   (** [match_deco rule matching] builds the decoration of the [graph] illustrating the given [matching] of the [rule] *)
   (* NB: it can be computed independly from the graph itself! *)

src/grew_types.ml

@@ -171,6 +171,7 @@ module Lexicon = struct
   | (x::xs) :: xss -> (x :: List.map List.hd xss) :: transpose (xs :: List.map List.tl xss)
 
   let build items =
+    if items = [] then Error.bug "[Lexicon.build] a lexicon must not be empty";
     let tr = transpose items in
     let sorted_tr = List.sort (fun l1 l2 -> Pervasives.compare (List.hd l1) (List.hd l2)) tr in
     match transpose sorted_tr with
@@ -204,7 +205,21 @@ module Lexicon = struct
     match List_.index head lex.header with
     | None -> Error.build "[Lexicon.select] cannot find %s in lexicon" head
     | Some index ->
-      { lex with lines = Line_set.filter (fun line -> List.nth line index = value) lex.lines}
+      let new_set = Line_set.filter (fun line -> List.nth line index = value) lex.lines in
+      if Line_set.is_empty new_set
+      then None
+      else ( Printf.printf "###>>> Lexicon select %d --> %d\n%!" (Line_set.cardinal lex.lines) (Line_set.cardinal new_set);
+      Some { lex with lines = new_set }
+      )
+
+  let unselect head value lex =
+    match List_.index head lex.header with
+    | None -> Error.build "[Lexicon.unselect] cannot find %s in lexicon" head
+    | Some index ->
+      let new_set = Line_set.filter (fun line -> List.nth line index <> value) lex.lines in
+      if Line_set.is_empty new_set
+      then None
+      else Some { lex with lines = new_set }
 
   let projection head lex =
     match List_.index head lex.header with
@@ -215,14 +230,14 @@ module Lexicon = struct
   exception Not_functional_lexicon
   let read head lex =
     match String_set.elements (projection head lex) with
-    | [] -> None
-    | [one] -> Some one
+    | [] -> Error.bug "[Lexicon.read] a lexicon must not be empty"
+    | [one] -> one
     | _ -> raise Not_functional_lexicon
 
   let read_multi head lex =
     match String_set.elements (projection head lex) with
-    | [] -> None
-    | l -> Some (String.concat "/" l)
+    | [] -> Error.bug "[Lexicon.read] a lexicon must not be empty"
+    | l -> String.concat "/" l
 end (* module Lexicon *)
 
 (* ================================================================================ *)

src/grew_types.mli

@@ -126,23 +126,20 @@ module Lexicon : sig
       It supposed that the two lexicons define the same columns *)
   val union: t -> t -> t
 
-  (** [select head value] returns the sublexicon with only items where the [head] column is equals to [value] *)
-  val select: string -> string -> t -> t
+  (** [select head value] returns the sublexicon with only items where the [head] column is equal to [value] if any, else returns None *)
+  val select: string -> string -> t -> t option
+
+  (** [unselect head value] returns the sublexicon with only items where the [head] column is different to [value] if any, else returns None *)
+  val unselect: string -> string -> t -> t option
 
   exception Not_functional_lexicon
 
-  (** [read head lexicon] returns
-      * None if [lexicon] is empty;
-      * Some value if all items have a [head] column equals to [value]
-      * raise [Not_functional_lexicon] if several values are defined
-      *)
-  val read: string -> t -> string option
-
-  (** [read_multi head lexicon] returns
-      * None if [lexicon] is empty;
-      * Some "v_1/…/v_k" where v_i are the values of the [head] column
-      *)
-  val read_multi: string -> t -> string option
+  (** [read head lexicon] return [value] if all items have in the [head] column equals to [value]
+      * raise [Not_functional_lexicon] if several values are defined *)
+  val read: string -> t -> string
+
+  (** [read_multi head lexicon] returns "v_1/…/v_k" where v_i are the values of the [head] column *)
+  val read_multi: string -> t -> string
 end (* module Lexicon *)
 
 (* ================================================================================ *)