Skip to content

GitLab

L
libcaml-grew
Commit 1d57deed authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files
Options

safe_commands

parent 1bd378e0
Hide whitespace changes
Inline Side-by-side
Showing with 38 additions and 65 deletions
src/grew_base.ml
View file @ 1d57deed
......@@ -442,8 +442,6 @@ module type S = sig
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
......@@ -523,17 +521,6 @@ module Massoc_make (Ord: OrderedType) = struct
| 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
exception True
let exists fct t =
try
......@@ -631,5 +618,5 @@ module Global = struct
| (fo, Some l) -> current_loc := (fo, Some (l+1))
let debug = ref false
let strict = ref false
let safe_commands = ref false
end
src/grew_base.mli
View file @ 1d57deed
......@@ -225,9 +225,6 @@ module type S =
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
val rename: (key * key) list -> 'a t -> 'a t
......@@ -294,5 +291,5 @@ module Global: sig
val label_flag: bool ref
val debug: bool ref
val strict: bool ref
val safe_commands: bool ref
end
src/grew_graph.ml
View file @ 1d57deed
......@@ -560,7 +560,7 @@ 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 strict src_gid tar_gid is_gid_local label_cst graph =
let shift_out loc src_gid tar_gid is_gid_local label_cst graph =
let domain = get_domain graph in
let del_edges = ref [] and add_edges = ref [] in
......@@ -576,7 +576,7 @@ 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
| 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 when !Global.safe_commands -> 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)
......@@ -597,7 +597,7 @@ module G_graph = struct
)
(* -------------------------------------------------------------------------------- *)
let shift_in loc strict src_gid tar_gid is_gid_local label_cst graph =
let shift_in loc src_gid tar_gid is_gid_local label_cst graph =
let domain = get_domain graph in
let del_edges = ref [] and add_edges = ref [] in
let new_map =
......@@ -617,7 +617,7 @@ module G_graph = struct
if Label_cst.match_ ?domain label_cst edge
then
match List_.usort_insert edge acc_node_tar_edges with
| None when strict ->
| None when !Global.safe_commands ->
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;
......@@ -641,9 +641,9 @@ module G_graph = struct
)
(* -------------------------------------------------------------------------------- *)
let shift_edges loc strict src_gid tar_gid is_gid_local label_cst graph =
let (g1,de1,ae1) = shift_out loc strict src_gid tar_gid is_gid_local label_cst graph in
let (g2,de2,ae2) = shift_in loc strict src_gid tar_gid is_gid_local label_cst g1 in
let shift_edges loc src_gid tar_gid is_gid_local label_cst graph =
let (g1,de1,ae1) = shift_out loc src_gid tar_gid is_gid_local label_cst graph in
let (g2,de2,ae2) = shift_in loc src_gid tar_gid is_gid_local label_cst g1 in
(g2, de1 @ de2, ae1 @ ae2)
(* -------------------------------------------------------------------------------- *)
......
src/grew_graph.mli
View file @ 1d57deed
......@@ -136,7 +136,6 @@ module G_graph: sig
(** shift all crown-edges ending in [src_gid] to edges ending in [tar_gid] *)
val shift_in:
Loc.t -> (* localization of the command *)
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 *)
......@@ -150,7 +149,6 @@ module G_graph: sig
(** shift all crown-edges starting from [src_gid] to edges starting from [tar_gid] *)
val shift_out:
Loc.t -> (* localization of the command *)
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 *)
......@@ -164,7 +162,6 @@ module G_graph: sig
(** 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 *)
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 *)
......
src/grew_node.ml
View file @ 1d57deed
......@@ -115,14 +115,6 @@ module G_node = struct
let remove_key node_id 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_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_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_gid.empty}
(* let build_neighbour t = { empty with position = (get_position t) +. 0.01 }
......
src/grew_node.mli
View file @ 1d57deed
......@@ -61,8 +61,6 @@ module G_node: sig
val remove_key: Gid.t -> t -> t
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
......
src/grew_rule.ml
View file @ 1d57deed
......@@ -907,7 +907,7 @@ module Rule = struct
},
created_nodes
)
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (instance, created_nodes)
end
......@@ -929,7 +929,7 @@ module Rule = struct
},
created_nodes
)
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "ADD_EDGE_EXPL: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (instance, created_nodes)
......@@ -939,7 +939,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(match G_graph.del_edge loc instance.Instance.graph src_gid edge tar_gid with
| None when !Global.strict -> Error.run "DEL_EDGE_EXPL: the edge '%s' does not exist %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_EDGE_EXPL: the edge '%s' does not exist %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (instance, created_nodes)
| Some new_graph ->
(
......@@ -969,7 +969,7 @@ module Rule = struct
| Command.DEL_NODE node_cn ->
let node_gid = node_find node_cn in
(match G_graph.del_node instance.Instance.graph node_gid with
| None when !Global.strict -> Error.run "DEL_NODE: the node does not exist %s" (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_NODE: the node does not exist %s" (Loc.to_string loc)
| None -> (instance, created_nodes)
| Some new_graph ->
(
......@@ -1009,7 +1009,7 @@ module Rule = struct
| Command.DEL_FEAT (tar_cn,feat_name) ->
let tar_gid = node_find tar_cn in
(match G_graph.del_feat instance.Instance.graph tar_gid feat_name with
| None when !Global.strict -> Error.run "DEL_FEAT: the feat does not exist %s" (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_FEAT: the feat does not exist %s" (Loc.to_string loc)
| None ->
Log.fwarning "DEL_FEAT: the feat does not exist %s" (Loc.to_string loc);
(instance, created_nodes)
......@@ -1057,7 +1057,7 @@ module Rule = struct
| Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, _, _) = G_graph.shift_in loc true src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
let (new_graph, _, _) = G_graph.shift_in loc src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
......@@ -1069,7 +1069,7 @@ module Rule = struct
| Command.SHIFT_OUT (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, _, _) = G_graph.shift_out loc true src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
let (new_graph, _, _) = G_graph.shift_out loc src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
......@@ -1081,7 +1081,7 @@ module Rule = struct
| Command.SHIFT_EDGE (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, _, _) = G_graph.shift_edges loc true src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
let (new_graph, _, _) = G_graph.shift_edges loc src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
......@@ -1391,7 +1391,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
begin
match G_graph.add_edge graph src_gid edge tar_gid with
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
......@@ -1405,7 +1405,7 @@ module Rule = struct
with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
begin
match G_graph.add_edge graph src_gid edge tar_gid with
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "ADD_EDGE_EXPL: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
......@@ -1415,8 +1415,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(match G_graph.del_edge loc graph src_gid edge tar_gid with
| None when !Global.strict -> Error.run "DEL_EDGE_EXPL: the edge '%s' does not exist %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_EDGE_EXPL: the edge '%s' does not exist %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
)
......@@ -1426,13 +1425,16 @@ module Rule = struct
try List.assoc edge_ident matching.e_match
with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
(match G_graph.del_edge ~edge_ident loc graph src_gid edge tar_gid with
| None -> Error.bug "DEL_EDGE_NAME"
| None when !Global.safe_commands -> Error.run "DEL_EDGE_NAME: the edge '%s' does not exist %s" edge_ident (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
)
| Command.DEL_NODE node_cn ->
let node_gid = node_find node_cn in
(match G_graph.del_node graph node_gid with
| None -> Error.run "DEL_NODE: the node does not exist %s" (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_NODE: the node does not exist %s" (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
)
......@@ -1459,7 +1461,7 @@ module Rule = struct
| Command.DEL_FEAT (tar_cn,feat_name) ->
let tar_gid = node_find tar_cn in
(match G_graph.del_feat graph tar_gid feat_name with
| None when !Global.strict -> Error.run "XXX"
| None when !Global.safe_commands -> Error.run "XXX"
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
)
......@@ -1467,19 +1469,19 @@ module Rule = struct
| Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, de, ae) = G_graph.shift_in loc true src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
let (new_graph, de, ae) = G_graph.shift_in loc src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
(new_graph, created_nodes, eff || de <> [] || ae <> [])
| Command.SHIFT_OUT (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, de, ae) = G_graph.shift_out loc true src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
let (new_graph, de, ae) = G_graph.shift_out loc src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
(new_graph, created_nodes, eff || de <> [] || ae <> [])
| Command.SHIFT_EDGE (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, de, ae) = G_graph.shift_edges loc true src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
let (new_graph, de, ae) = G_graph.shift_edges loc src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
(new_graph, created_nodes, eff || de <> [] || ae <> [])
| Command.NEW_AFTER (created_name,base_cn) ->
......@@ -1612,7 +1614,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
begin
match G_graph.add_edge gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "ADD_EDGE: the edge '%s' already exists %s"
(G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> gwh
......@@ -1632,7 +1634,7 @@ module Rule = struct
begin
match G_graph.add_edge gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "ADD_EDGE_EXPL: the edge '%s' already exists %s"
(G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> gwh
......@@ -1647,7 +1649,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(match G_graph.del_edge loc gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when !Global.strict ->
| None when !Global.safe_commands ->
Error.run "DEL_EDGE_EXPL: the edge '%s' does not exist %s"
(G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> gwh
......@@ -1662,7 +1664,7 @@ module Rule = struct
try List.assoc edge_ident matching.e_match
with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
(match G_graph.del_edge ~edge_ident loc gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when !Global.strict -> Error.run "DEL_EDGE_NAME: the edge '%s' does not exist %s" edge_ident (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_EDGE_NAME: the edge '%s' does not exist %s" edge_ident (Loc.to_string loc)
| None -> gwh
| Some new_graph ->
{gwh with
......@@ -1673,7 +1675,7 @@ module Rule = struct
| Command.DEL_NODE node_cn ->
let node_gid = node_find node_cn in
(match G_graph.del_node gwh.Graph_with_history.graph node_gid with
| None when !Global.strict -> Error.run "DEL_NODE the node does not exist %s" (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_NODE the node does not exist %s" (Loc.to_string loc)
| None -> gwh
| Some new_graph ->
{ gwh with
......@@ -1712,7 +1714,7 @@ module Rule = struct
| Command.DEL_FEAT (tar_cn,feat_name) ->
let tar_gid = node_find tar_cn in
(match G_graph.del_feat gwh.Graph_with_history.graph tar_gid feat_name with
| None when !Global.strict -> Error.run "DEL_FEAT the feat does not exist %s" (Loc.to_string loc)
| None when !Global.safe_commands -> Error.run "DEL_FEAT the feat does not exist %s" (Loc.to_string loc)
| None -> gwh
| Some new_graph -> { gwh with
Graph_with_history.graph = new_graph;
......@@ -1724,7 +1726,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, del_edges, add_edges) =
G_graph.shift_in loc !Global.strict src_gid tar_gid (test_locality matching []) label_cst gwh.Graph_with_history.graph in
G_graph.shift_in loc src_gid tar_gid (test_locality matching []) label_cst gwh.Graph_with_history.graph in
{ gwh with
Graph_with_history.graph = new_graph;
delta = gwh.Graph_with_history.delta
......@@ -1736,7 +1738,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, del_edges, add_edges) =
G_graph.shift_out loc !Global.strict src_gid tar_gid (test_locality matching []) label_cst gwh.Graph_with_history.graph in
G_graph.shift_out loc src_gid tar_gid (test_locality matching []) label_cst gwh.Graph_with_history.graph in
{ gwh with
Graph_with_history.graph = new_graph;
delta = gwh.Graph_with_history.delta
......@@ -1748,7 +1750,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, del_edges, add_edges) =
G_graph.shift_edges loc !Global.strict src_gid tar_gid (test_locality matching []) label_cst gwh.Graph_with_history.graph in
G_graph.shift_edges loc src_gid tar_gid (test_locality matching []) label_cst gwh.Graph_with_history.graph in
{ gwh with
Graph_with_history.graph = new_graph;
delta = gwh.Graph_with_history.delta
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment