Skip to content

GitLab

L
libcaml-grew
Commit 1fcba640 authored by bguillaum's avatar bguillaum
Browse files
Options

enforce typing difference between P_graph / G_graph (with the same on node and edge) 

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6721 7838e531-6607-4d57-9587-6c381814729c
parent c7588b98
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 685 additions and 512 deletions
src/grew_command.ml
View file @ 1fcba640
......@@ -21,12 +21,12 @@ module Command = struct
(* the command in pattern *)
type p =
| DEL_NODE of cnode
| DEL_EDGE_EXPL of (cnode * cnode *Edge.t)
| DEL_EDGE_EXPL of (cnode * cnode * G_edge.t)
| DEL_EDGE_NAME of string
| ADD_EDGE of (cnode * cnode * Edge.t)
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| NEW_NEIGHBOUR of (string * Edge.t * pid)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
......@@ -37,12 +37,12 @@ module Command = struct
(* a item in the command history: command applied to a graph *)
type h =
| H_DEL_NODE of gid
| H_DEL_EDGE_EXPL of (gid * gid *Edge.t)
| H_DEL_EDGE_EXPL of (gid * gid *G_edge.t)
| H_DEL_EDGE_NAME of string
| H_ADD_EDGE of (gid * gid * Edge.t)
| H_ADD_EDGE of (gid * gid * G_edge.t)
| H_DEL_FEAT of (gid *string)
| H_UPDATE_FEAT of (gid * string * string)
| H_NEW_NEIGHBOUR of (string * Edge.t * gid)
| H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
......@@ -65,7 +65,7 @@ module Command = struct
match ast_command with
| (Ast.Del_edge_expl (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
let edge = Edge.make ~locals [lab] in
let edge = G_edge.make ~locals lab in
((DEL_EDGE_EXPL (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Del_edge_name id, loc) ->
......@@ -74,7 +74,7 @@ module Command = struct
| (Ast.Add_edge (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
let edge = Edge.make ~locals [lab] in
let edge = G_edge.make ~locals lab in
((ADD_EDGE (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Shift_edge (i, j), loc) ->
......@@ -97,12 +97,12 @@ module Command = struct
check_node loc ancestor kni;
if List.mem name_created kni
then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
let edge = Edge.make ~locals [label] in
let edge = G_edge.make ~locals label in
begin
try ((NEW_NEIGHBOUR (name_created, edge, Id.build ~loc ancestor table), loc), (name_created::kni, kei))
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(Edge.to_string edge)
(G_edge.to_string edge)
ancestor
(Loc.to_string loc)
end
......
src/grew_command.mli
View file @ 1fcba640
......@@ -16,12 +16,12 @@ module Command : sig
type p =
| DEL_NODE of cnode
| DEL_EDGE_EXPL of (cnode * cnode *Edge.t)
| DEL_EDGE_EXPL of (cnode * cnode *G_edge.t)
| DEL_EDGE_NAME of string
| ADD_EDGE of (cnode * cnode * Edge.t)
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| NEW_NEIGHBOUR of (string * Edge.t * pid)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
......@@ -31,12 +31,12 @@ module Command : sig
type t = (p * Loc.t)
type h =
| H_DEL_NODE of gid
| H_DEL_EDGE_EXPL of (gid * gid *Edge.t)
| H_DEL_EDGE_EXPL of (gid * gid *G_edge.t)
| H_DEL_EDGE_NAME of string
| H_ADD_EDGE of (gid * gid * Edge.t)
| H_ADD_EDGE of (gid * gid * G_edge.t)
| H_DEL_FEAT of (gid *string)
| H_UPDATE_FEAT of (gid * string * string)
| H_NEW_NEIGHBOUR of (string * Edge.t * gid)
| H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
......
src/grew_edge.ml
View file @ 1fcba640
open Log
open Printf
open Grew_utils
open Grew_ast
(* ================================================================================ *)
module Label = struct
type decl = string * string option
......@@ -28,90 +30,78 @@ module Label = struct
let get_color l = !colors.(l)
end
(* ================================================================================ *)
module Edge = struct
(* the type of underspecified labels: a positive or negative constraint on a disjunction *)
type under_label =
| Pos of int list
| Neg of int list
(* ================================================================================ *)
module G_edge = struct
type t = Label.t
let to_string = Label.to_string
let make ?(locals=[||]) string = Label.from_string ~locals string
let build ?locals (ast_edge, loc) =
match ast_edge.Ast.negative, ast_edge.Ast.edge_labels with
| (false, [one]) -> Label.from_string ~loc ?locals one
| (true, _) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
| (false, _) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc)
let to_dot ?(deco=false) l =
match Label.get_color l with
| None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
| Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")
let to_dep ?(deco=false) l =
match (deco,Label.get_color l) with
| (false,None) -> Printf.sprintf "{ label = \"%s\"; }" (Label.to_string l)
| (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s; bottom; }" (Label.to_string l) c c
| (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
| (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c
end
(* ================================================================================ *)
(* ================================================================================ *)
module P_edge = struct
type u_label =
| Pos of Label.t list
| Neg of Label.t list
type t = {
id: string option; (* an identifier for naming under_label in patterns *)
under_label: under_label;
u_label: u_label;
}
let get_id t = t.id
let all = {id=None; under_label=Neg []}
let all = {id=None; u_label=Neg []}
let compare = Pervasives.compare
let get_id t = t.id
let make ?(id=None) ?(neg=false) ?(locals=[||]) = function
| l when neg -> {id=id; under_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
| l -> {id=id; under_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}
| l when neg -> {id=id; u_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
| l -> {id=id; u_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}
let build ?locals (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id;
under_label =
u_label =
if ast_edge.Ast.negative
then Neg (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
else Pos (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
}
let from_string string_label =
match string_label with
| s when s.[0] = '^' ->
let s' = String.sub s 1 ((String.length s) - 1) in
{id=None; under_label=Neg (List.map Label.from_string (Str.split (Str.regexp "|") s'))}
| _ -> {id=None; under_label=Pos (List.map Label.from_string (Str.split (Str.regexp "|") string_label))}
let build_edge line =
try
let _ = Str.search_forward(Str.regexp("N\\(.*\\)->")) line 0 in
let i = int_of_string (Str.matched_group 1 line) in
let _ = Str.search_forward(Str.regexp("->N\\(.*\\)\\[")) line 0 in
let j = int_of_string (Str.matched_group 1 line) in
let _ = Str.search_forward(Str.regexp("label=\"\\([\\^|a-zA-Z0-9_\\-]*\\)\"")) line 0 in
let string_label = Str.matched_group 1 line in
(i,j,from_string string_label)
with Not_found | Invalid_argument _ -> failwith (Printf.sprintf "%s is not an edge declaration" line)
let to_string t =
let pref = match t.id with None -> "" | Some i -> "i:" in
match t.under_label with
let to_string t =
let pref = match t.id with None -> "" | Some i -> sprintf "%s:" i in
match t.u_label with
| Pos l -> pref^(List_.to_string Label.to_string "|" l)
| Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)
let as_label t = match t.under_label with
| Pos [one] -> one
| _ -> failwith (Printf.sprintf "[Edge.as_label] edge '%s\' is not a label" (to_string t))
let of_label l = {id=None; under_label=Pos [l]}
let to_dot ?(deco=false) x =
let l = as_label x in
match Label.get_color l with
| None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
| Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")
let to_dep ?(deco=false) x =
let l = as_label x in
match (deco,Label.get_color l) with
| (false,None) -> Printf.sprintf "{ label = \"%s\"; }" (Label.to_string l)
| (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s; bottom; }" (Label.to_string l) c c
| (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
| (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c
let compatible t g_edge = match t.u_label with
| Pos p -> List_.sort_mem g_edge p
| Neg n -> not (List_.sort_mem g_edge n)
let compatible edge1 edge2 = match (edge1.under_label,edge2.under_label) with
| Pos l1, Pos l2 -> not (List_.sort_is_empty_inter l1 l2)
| Pos p, Neg n | Neg n, Pos p -> not (List_.sort_include p n)
| Neg l1, Neg l2 -> failwith "Cannot compare two negative sets"
let is_in graph_edge list =
List.mem (as_label graph_edge) list
type edge_matcher =
......@@ -119,30 +109,30 @@ module Edge = struct
| Ok of Label.t
| Binds of string * Label.t list
let match_ pattern_edge graph_edge =
let graph_label = as_label graph_edge in
let match_ pattern_edge graph_label =
match pattern_edge with
| {id = Some i; under_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
| {id = None; under_label = Pos l} when List.mem graph_label l -> Ok graph_label
| {id = Some i; under_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
| {id = None; under_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
| {id = Some i; u_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
| {id = None; u_label = Pos l} when List.mem graph_label l -> Ok graph_label
| {id = Some i; u_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
| {id = None; u_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
| _ -> Fail
let match_list pattern_edge graph_edge_list =
let graph_labels = List.map as_label graph_edge_list in
match pattern_edge with
| {id = None; under_label = Pos l} when List.exists (fun label -> List.mem label l) graph_labels -> Ok (List.hd graph_labels)
| {id = None; under_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_labels -> Ok (List.hd graph_labels)
| {id = Some i; under_label = Pos l} ->
(match List.filter (fun label -> List.mem label l) graph_labels with
| {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
Ok (List.hd graph_edge_list)
| {id = None; u_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_edge_list ->
Ok (List.hd graph_edge_list)
| {id = Some i; u_label = Pos l} ->
(match List.filter (fun label -> List.mem label l) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
| {id = Some i; under_label = Neg l} ->
(match List.filter (fun label -> not (List.mem label l)) graph_labels with
| {id = Some i; u_label = Neg l} ->
(match List.filter (fun label -> not (List.mem label l)) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
| _ -> Fail
end
(* ================================================================================ *)
src/grew_edge.mli
View file @ 1fcba640
......@@ -16,16 +16,39 @@ module Label : sig
end
module Edge : sig
type t
val as_label: t -> Label.t
val of_label: Label.t -> t
val get_id: t -> string option
(* ================================================================================ *)
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
module G_edge: sig
type t = Label.t
val to_string:t -> string
val make: ?locals:Label.decl array -> string -> t
val build: ?locals:Label.decl array -> Ast.edge -> t
val to_dot: ?deco:bool -> t -> string
val to_dep: ?deco:bool -> t -> string
end
(* ================================================================================ *)
(* ================================================================================ *)
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
module P_edge: sig
type t
(* [all] is the joker pattern edge *)
val all: t
val get_id: t -> string option
val to_string: t -> string
val build: ?locals:Label.decl array -> Ast.edge -> t
val make:
?id: string option ->
?neg:bool ->
......@@ -33,27 +56,17 @@ module Edge : sig
string list ->
t
val build: ?locals:Label.decl array -> Ast.edge -> t
val compare: 'a -> 'a -> int
val build_edge: string -> int * int * t
val to_string: t -> string
val to_dot: ?deco:bool -> t -> string
val to_dep: ?deco:bool -> t -> string
val compatible : t -> t -> bool
val is_in : t -> Label.t list -> bool
val compatible: t -> G_edge.t -> bool
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
val match_: t -> G_edge.t -> edge_matcher
val match_: t -> t -> edge_matcher
val match_list: t -> G_edge.t list -> edge_matcher
val match_list: t -> t list -> edge_matcher
end
(* ================================================================================ *)
src/grew_graph.ml
View file @ 1fcba640
This diff is collapsed.
src/grew_graph.mli
View file @ 1fcba640
......@@ -3,7 +3,6 @@ open Grew_fs
open Grew_edge
open Grew_node
open Grew_utils
open Edge
open Grew_command
module Deco: sig
......@@ -14,19 +13,16 @@ module Deco: sig
val empty:t
end
module Graph : sig
type t = {
map: Node.t IntMap.t; (* node description *)
lub: int; (* least upper bound *)
}
type gid = int
type concat_item =
| Feat of (gid * string)
| String of string
module P_graph: sig
type t = P_node.t Pid_map.t
val empty: t
val find: Pid.t -> t -> P_node.t
type extension = {
ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New" *)
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
val build:
?domain: Ast.domain ->
......@@ -35,30 +31,54 @@ module Graph : sig
Ast.edge list ->
(t * Id.table * (Id.t * Feature_structure.t) list )
(* a type for extension of graph: a former graph exists: in grew the former is a positive pattern and an extension is a "without" *)
type extention = {
ext_map: Node.t IntMap.t; (* node description *)
old_map: Node.t IntMap.t; (* a partial map on old nodes for edge "Old -> New" and/or for new constraints on old nodes "Old [...]" *)
}
val build_extention:
val build_extension:
?domain: Ast.domain ->
?locals: Label.decl array ->
Id.table ->
Ast.node list ->
Ast.edge list ->
(extention * Id.table)
(extension * Id.table)
val roots: t -> Pid.t list
end
module Gid : sig type t = int end
module Gid_map : Map.S with type key = Gid.t
module G_graph: sig
type t = {
map: G_node.t Gid_map.t; (* node description *)
lub: int; (* least upper bound *)
}
val empty: t
val find: int -> t -> Node.t
val find: Gid.t -> t -> G_node.t
val build:
?domain: Ast.domain ->
?locals: Label.decl array ->
Ast.node list ->
Ast.edge list ->
t
val to_gr: t -> string
val to_dot: ?main_feat:string -> ?deco:Deco.t -> t -> string
val to_dep: ?main_feat:string -> ?deco:Deco.t -> t -> string
val add_edge : t -> int -> Edge.t -> int -> t option
val del_edge : ?edge_ident: string -> Loc.t -> t -> int -> Edge.t -> int -> t
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_neighbour : Loc.t -> t -> int -> Edge.t -> (int * t)
val add_neighbour : Loc.t -> t -> int -> G_edge.t -> (int * t)
val merge_node : Loc.t -> t -> int -> int -> t option
val shift_in : Loc.t -> t -> int -> int -> t
......@@ -72,11 +92,10 @@ module Graph : sig
val del_feat : t -> int -> string -> t
val equals : t -> t -> bool
(** [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 -> Edge.t -> bool
val edge_out: t -> int -> P_edge.t -> bool
val equals: t -> t -> bool
val roots: t -> int list
end
src/grew_node.ml
View file @ 1fcba640
open Printf
open Grew_utils
open Grew_ast
open Grew_edge
open Grew_fs
module Node = struct
(* ================================================================================ *)
module G_node = struct
type t = {
fs : Feature_structure.t;
pos : int option;
next : Edge.t Massoc.t; (* the massoc gives for each node [n], the (sorted) list of edge from the current node to [n] *)
fs: Feature_structure.t;
pos: int option;
next: G_edge.t Massoc.t;
}
let empty = {fs = Feature_structure.empty; pos=None; next = Massoc.empty}
let get_fs t = t.fs
let get_next t = t.next
let set_fs t fs = {t with fs = fs}
let empty = { fs = Feature_structure.empty; pos = None; next = Massoc.empty }
let to_string t =
Printf.sprintf "[fs=%s ; next=%s]"
(Feature_structure.to_string t.fs)
(Massoc.to_string G_edge.to_string t.next)
let to_gr t =
sprintf "%s [%s] "
(match t.pos with Some i -> sprintf "(%d)" i | None -> "")
(Feature_structure.to_gr t.fs)
let add_edge g_edge gid_tar t =
match Massoc.add gid_tar g_edge t.next with
| Some l -> Some {t with next = l}
| None -> None
let build ?domain (ast_node, loc) =
(ast_node.Ast.node_id,
......@@ -20,13 +41,57 @@ module Node = struct
pos = ast_node.Ast.position;
next = Massoc.empty;
} )
let remove id_tar label t = {t with next = Massoc.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
let merge_key src_id tar_id t =
try Some {t with next = Massoc.merge_key src_id tar_id t.next}
with Massoc.Duplicate -> None
let shift_out src_t tar_t =
try Some {tar_t with next = Massoc.disjoint_union src_t.next tar_t.next}
with Massoc.Not_disjoint -> None
let rm_out_edges t = {t with next = Massoc.empty}
let build_neighbour t = {empty with pos = match t.pos with Some x -> Some (x+1) | None -> None}
let pos_comp n1 n2 = Pervasives.compare n1.pos n2.pos
end
(* ================================================================================ *)
(* ================================================================================ *)
module P_node = struct
type t = {
fs: Feature_structure.t;
next: P_edge.t Massoc.t;
}
let get_fs t = t.fs
let get_next t = t.next
let empty = { fs = Feature_structure.empty; next = Massoc.empty }
let build ?domain (ast_node, loc) =
(ast_node.Ast.node_id,
{ fs = Feature_structure.build ?domain ast_node.Ast.fs;
next = Massoc.empty;
} )
let add_edge p_edge pid_tar t =
match Massoc.add pid_tar p_edge t.next with
| Some l -> Some {t with next = l}
| None -> None
(* Says that "pattern" t1 is a t2*)
let is_a pattern graph = Feature_structure.compatible pattern.fs graph.fs
let is_a p_node g_node = Feature_structure.compatible p_node.fs (G_node.get_fs g_node)
let to_string t =
Printf.sprintf "[fs=%s ; next=%s]"
(Feature_structure.to_string t.fs)
(Massoc.to_string Edge.to_string t.next)
end
(* ================================================================================ *)
src/grew_node.mli
View file @ 1fcba640
......@@ -3,17 +3,52 @@ open Grew_fs
open Grew_edge
open Grew_ast
module Node : sig
type t = {
fs : Feature_structure.t;
pos : int option;
next : Edge.t Massoc.t;
}
(* ================================================================================ *)
module G_node: sig
type t
val empty: t
val to_string: t -> string
val to_gr: t -> string
val get_fs: t -> Feature_structure.t
val get_next: t -> G_edge.t Massoc.t
val set_fs: t -> Feature_structure.t -> t
(* FIXME move Gid up and replace int by Gid.t *)
val remove: int -> G_edge.t -> t -> t