Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
grew
libcaml-grew
Commits
8b3202b7
Commit
8b3202b7
authored
Aug 12, 2014
by
Bruno Guillaume
Browse files
TMP_activate command
parent
00d588ef
Changes
10
Hide whitespace changes
Inline
Side-by-side
src/grew_command.ml
View file @
8b3202b7
...
...
@@ -20,9 +20,10 @@ open Grew_fs
module
Command
=
struct
type
command_node
=
(* a command node is either: *)
|
Pat
of
Pid
.
t
(* a node identified in the pattern *)
|
New
of
string
(* a node introduced by a new_neighbour *)
|
Act
of
Pid
.
t
*
string
(* a node introduced by a activate *)
|
New
of
string
(* a node introduced by a new_neighbour *)
(* TODO: remove *)
|
Act
of
Pid
.
t
*
string
(* a node introduced by a
n
activate *)
(* [item] is a element of the RHS of an update_feat command *)
type
item
=
|
Feat
of
(
command_node
*
string
)
|
String
of
string
...
...
@@ -37,29 +38,33 @@ module Command = struct
|
ADD_EDGE
of
(
command_node
*
command_node
*
G_edge
.
t
)
|
DEL_FEAT
of
(
command_node
*
string
)
|
UPDATE_FEAT
of
(
command_node
*
string
*
item
list
)
|
NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
Pid
.
t
)
|
NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
Pid
.
t
)
(* TODO: remove *)
|
SHIFT_EDGE
of
(
command_node
*
command_node
)
|
SHIFT_IN
of
(
command_node
*
command_node
)
|
SHIFT_OUT
of
(
command_node
*
command_node
)
|
MERGE_NODE
of
(
command_node
*
command_node
)
|
ACT_NODE
of
command_node
type
t
=
p
*
Loc
.
t
(* remember command location to be able to localize a command failure *)
(* a item in the command history: command applied to a graph *)
type
h
=
|
H_DEL_NODE
of
Gid
.
t
|
H_DEL_EDGE_EXPL
of
(
Gid
.
t
*
Gid
.
t
*
G_edge
.
t
)
|
H_DEL_EDGE_EXPL
of
(
Gid
.
t
*
Gid
.
t
*
G_edge
.
t
)
|
H_DEL_EDGE_NAME
of
string
|
H_ADD_EDGE
of
(
Gid
.
t
*
Gid
.
t
*
G_edge
.
t
)
|
H_DEL_FEAT
of
(
Gid
.
t
*
string
)
|
H_UPDATE_FEAT
of
(
Gid
.
t
*
string
*
string
)
|
H_NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
Gid
.
t
)
|
H_NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
Gid
.
t
)
(* TODO: remove *)
|
H_SHIFT_EDGE
of
(
Gid
.
t
*
Gid
.
t
)
|
H_SHIFT_IN
of
(
Gid
.
t
*
Gid
.
t
)
|
H_SHIFT_OUT
of
(
Gid
.
t
*
Gid
.
t
)
|
H_MERGE_NODE
of
(
Gid
.
t
*
Gid
.
t
)
|
H_ACT_NODE
of
(
Gid
.
t
*
string
)
let
build
?
param
(
kai
,
kei
)
table
locals
ast_command
=
(* kai stands for "known act ident", kei for "known edge ident" *)
let
pid_of_act_id
loc
=
function
|
(
node_name
,
Some
n
)
->
Act
(
Pid
.
Pos
(
Id
.
build
~
loc
node_name
table
)
,
n
)
...
...
@@ -68,58 +73,61 @@ module Command = struct
Pat
(
Pid
.
Pos
(
Id
.
build
~
loc
node_name
table
))
with
_
->
New
node_name
in
(* check that an act_id is well-defined earlier *)
let
check_act_id
loc
act_id
kai
=
if
not
(
List
.
mem
act_id
kai
)
then
Error
.
build
~
loc
"Unbound node identifier
\"
%s
\"
"
(
Ast
.
act_id_to_string
act_id
)
in
(* check that the edge_id is defined in the pattern *)
let
check_edge
loc
edge_id
kei
=
if
not
(
List
.
mem
edge_id
kei
)
then
Error
.
build
~
loc
"Unbound edge identifier
\"
%s
\"
"
edge_id
in
match
ast_command
with
|
(
Ast
.
Del_edge_expl
(
act_i
,
act_j
,
lab
)
,
loc
)
->
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
let
edge
=
G_edge
.
make
~
loc
~
locals
lab
in
((
DEL_EDGE_EXPL
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
edge
)
,
loc
)
,
(
kai
,
kei
))
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
let
edge
=
G_edge
.
make
~
loc
~
locals
lab
in
((
DEL_EDGE_EXPL
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
edge
)
,
loc
)
,
(
kai
,
kei
))
|
(
Ast
.
Del_edge_name
id
,
loc
)
->
check_edge
loc
id
kei
;
(
DEL_EDGE_NAME
id
,
loc
)
,
(
kai
,
List_
.
rm
id
kei
)
check_edge
loc
id
kei
;
(
DEL_EDGE_NAME
id
,
loc
)
,
(
kai
,
List_
.
rm
id
kei
)
|
(
Ast
.
Add_edge
(
act_i
,
act_j
,
lab
)
,
loc
)
->
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
let
edge
=
G_edge
.
make
~
loc
~
locals
lab
in
((
ADD_EDGE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
edge
)
,
loc
)
,
(
kai
,
kei
))
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
let
edge
=
G_edge
.
make
~
loc
~
locals
lab
in
((
ADD_EDGE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
edge
)
,
loc
)
,
(
kai
,
kei
))
|
(
Ast
.
Shift_edge
(
act_i
,
act_j
)
,
loc
)
->
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
SHIFT_EDGE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
kai
,
kei
))
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
SHIFT_EDGE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
kai
,
kei
))
|
(
Ast
.
Shift_in
(
act_i
,
act_j
)
,
loc
)
->
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
SHIFT_IN
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
kai
,
kei
))
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
SHIFT_IN
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
kai
,
kei
))
|
(
Ast
.
Shift_out
(
act_i
,
act_j
)
,
loc
)
->
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
SHIFT_OUT
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
kai
,
kei
))
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
SHIFT_OUT
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
kai
,
kei
))
|
(
Ast
.
Merge_node
(
act_i
,
act_j
)
,
loc
)
->
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
MERGE_NODE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
List_
.
rm
act_i
kai
,
kei
))
check_act_id
loc
act_i
kai
;
check_act_id
loc
act_j
kai
;
((
MERGE_NODE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
)
,
loc
)
,
(
List_
.
rm
act_i
kai
,
kei
))
|
(
Ast
.
New_neighbour
(
new_id
,
ancestor
,
label
)
,
loc
)
->
check_act_id
loc
ancestor
kai
;
if
List
.
mem
(
new_id
,
None
)
kai
then
Error
.
build
~
loc
"Node identifier
\"
%s
\"
is already used"
new_id
;
let
edge
=
G_edge
.
make
~
loc
~
locals
label
in
begin
try
check_act_id
loc
ancestor
kai
;
if
List
.
mem
(
new_id
,
None
)
kai
then
Error
.
build
~
loc
"Node identifier
\"
%s
\"
is already used"
new_id
;
let
edge
=
G_edge
.
make
~
loc
~
locals
label
in
begin
try
(
(
NEW_NEIGHBOUR
(
new_id
,
...
...
@@ -128,43 +136,48 @@ module Command = struct
)
,
loc
)
,
((
new_id
,
None
)
::
kai
,
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"
(
G_edge
.
to_string
edge
)
(
fst
ancestor
)
(
Loc
.
to_string
loc
)
end
with
not_found
->
Log
.
fcritical
"[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(
G_edge
.
to_string
edge
)
(
fst
ancestor
)
(
Loc
.
to_string
loc
)
end
|
(
Ast
.
Activate
(
_
,
None
)
,
loc
)
->
Error
.
build
~
loc
"Cannot activate a pattern node"
|
(
Ast
.
Activate
n
,
loc
)
->
failwith
"Not implemented"
|
(
Ast
.
Activate
act_n
,
loc
)
->
(* TODO: add a check on source node *)
((
ACT_NODE
(
pid_of_act_id
loc
act_n
)
,
loc
)
,
(
act_n
::
kai
,
kei
))
|
(
Ast
.
Del_node
act_n
,
loc
)
->
check_act_id
loc
act_n
kai
;
((
DEL_NODE
(
pid_of_act_id
loc
act_n
)
,
loc
)
,
(
List_
.
rm
act_n
kai
,
kei
))
check_act_id
loc
act_n
kai
;
((
DEL_NODE
(
pid_of_act_id
loc
act_n
)
,
loc
)
,
(
List_
.
rm
act_n
kai
,
kei
))
|
(
Ast
.
Del_feat
(
act_id
,
feat_name
)
,
loc
)
->
if
feat_name
=
"position"
then
Error
.
build
~
loc
"Illegal del_feat command: the 'position' feature cannot be deleted"
;
check_act_id
loc
act_id
kai
;
((
DEL_FEAT
(
pid_of_act_id
loc
act_id
,
feat_name
)
,
loc
)
,
(
kai
,
kei
))
if
feat_name
=
"position"
then
Error
.
build
~
loc
"Illegal del_feat command: the 'position' feature cannot be deleted"
;
check_act_id
loc
act_id
kai
;
((
DEL_FEAT
(
pid_of_act_id
loc
act_id
,
feat_name
)
,
loc
)
,
(
kai
,
kei
))
|
(
Ast
.
Update_feat
((
act_id
,
feat_name
)
,
ast_items
)
,
loc
)
->
check_act_id
loc
act_id
kai
;
let
items
=
List
.
map
(
function
(* special case of a basic identifier understood as a string *)
|
Ast
.
Qfn_item
ci
when
Ast
.
is_simple
ci
->
String
(
Ast
.
complex_id_to_string
ci
)
|
Ast
.
Qfn_item
ci
->
let
(
act_id
,
feature_name
)
=
Ast
.
act_qfn_of_ci
ci
in
check_act_id
loc
act_id
kai
;
Feat
(
pid_of_act_id
loc
act_id
,
feature_name
)
|
Ast
.
String_item
s
->
String
s
|
Ast
.
Param_item
var
->
match
param
with
|
None
->
Error
.
build
"Unknown command variable '%s'"
var
|
Some
(
par
,
cmd
)
->
match
(
List_
.
pos
var
par
,
List_
.
pos
var
cmd
)
with
|
(
_
,
Some
index
)
->
Param_out
index
|
(
Some
index
,_
)
->
Param_in
index
|
_
->
Error
.
build
"Unknown command variable '%s'"
var
)
ast_items
in
((
UPDATE_FEAT
(
pid_of_act_id
loc
act_id
,
feat_name
,
items
)
,
loc
)
,
(
kai
,
kei
))
check_act_id
loc
act_id
kai
;
let
items
=
List
.
map
(
function
(* special case of a basic identifier understood as a string *)
|
Ast
.
Qfn_item
ci
when
Ast
.
is_simple
ci
->
String
(
Ast
.
complex_id_to_string
ci
)
|
Ast
.
Qfn_item
ci
->
let
(
act_id
,
feature_name
)
=
Ast
.
act_qfn_of_ci
ci
in
check_act_id
loc
act_id
kai
;
Feat
(
pid_of_act_id
loc
act_id
,
feature_name
)
|
Ast
.
String_item
s
->
String
s
|
Ast
.
Param_item
var
->
match
param
with
|
None
->
Error
.
build
"Unknown command variable '%s'"
var
|
Some
(
par
,
cmd
)
->
match
(
List_
.
pos
var
par
,
List_
.
pos
var
cmd
)
with
|
(
_
,
Some
index
)
->
Param_out
index
|
(
Some
index
,_
)
->
Param_in
index
|
_
->
Error
.
build
"Unknown command variable '%s'"
var
)
ast_items
in
((
UPDATE_FEAT
(
pid_of_act_id
loc
act_id
,
feat_name
,
items
)
,
loc
)
,
(
kai
,
kei
))
end
(* module Command *)
src/grew_command.mli
View file @
8b3202b7
...
...
@@ -15,8 +15,8 @@ open Grew_edge
(* ==================================================================================================== *)
module
Command
:
sig
type
command_node
=
(* a command node is either: *)
|
Pat
of
Pid
.
t
(* a node identified in the pattern *)
|
New
of
string
(* a node introduced by a new_neighbour *)
|
Pat
of
Pid
.
t
(* a node identified in the pattern *)
|
New
of
string
(* a node introduced by a new_neighbour *)
|
Act
of
Pid
.
t
*
string
(* a node introduced by a activate *)
type
item
=
...
...
@@ -37,8 +37,9 @@ module Command : sig
|
SHIFT_IN
of
(
command_node
*
command_node
)
|
SHIFT_OUT
of
(
command_node
*
command_node
)
|
MERGE_NODE
of
(
command_node
*
command_node
)
|
ACT_NODE
of
command_node
type
t
=
(
p
*
Loc
.
t
)
type
h
=
|
H_DEL_NODE
of
Gid
.
t
...
...
@@ -52,6 +53,7 @@ module Command : sig
|
H_SHIFT_IN
of
(
Gid
.
t
*
Gid
.
t
)
|
H_SHIFT_OUT
of
(
Gid
.
t
*
Gid
.
t
)
|
H_MERGE_NODE
of
(
Gid
.
t
*
Gid
.
t
)
|
H_ACT_NODE
of
(
Gid
.
t
*
string
)
val
build
:
?
param
:
(
string
list
*
string
list
)
->
...
...
src/grew_graph.ml
View file @
8b3202b7
...
...
@@ -449,6 +449,19 @@ module G_graph = struct
)
graph
.
map
Gid_map
.
empty
}
(* -------------------------------------------------------------------------------- *)
let
activate
loc
node_id
new_name
graph
=
let
index
=
match
node_id
with
|
Gid
.
Old
id
->
Gid
.
Act
(
id
,
new_name
)
|
_
->
Error
.
run
~
loc
"[Graph.activate] is possible only from a
\"
ground
\"
node"
in
if
Gid_map
.
mem
index
graph
.
map
then
Error
.
run
~
loc
"[Graph.activate] try to activate twice the
\"
same
\"
node (with new_name '%s')"
new_name
;
let
node
=
Gid_map
.
find
node_id
graph
.
map
in
let
new_map
=
Gid_map
.
add
index
(
G_node
.
build_new
node
)
graph
.
map
in
(
index
,
{
graph
with
map
=
new_map
})
(* -------------------------------------------------------------------------------- *)
let
add_neighbour
loc
graph
node_id
label
=
let
index
=
match
node_id
with
...
...
src/grew_graph.mli
View file @
8b3202b7
...
...
@@ -50,7 +50,7 @@ module P_graph: sig
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 [...]" *)
old_map
:
P_node
.
t
Pid_map
.
t
;
(* a partial map for new constraints on old nodes "Old [...]" *)
}
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
...
...
@@ -137,6 +137,7 @@ module G_graph: sig
val
del_node
:
t
->
Gid
.
t
->
t
val
add_neighbour
:
Loc
.
t
->
t
->
Gid
.
t
->
G_edge
.
t
->
(
Gid
.
t
*
t
)
val
activate
:
Loc
.
t
->
Gid
.
t
->
string
->
t
->
(
Gid
.
t
*
t
)
val
merge_node
:
Loc
.
t
->
t
->
Gid
.
t
->
Gid
.
t
->
t
option
...
...
src/grew_node.ml
View file @
8b3202b7
...
...
@@ -82,6 +82,8 @@ module G_node = struct
let
build_neighbour
t
=
{
empty
with
position
=
(
get_position
t
)
+.
0
.
01
}
let
build_new
t
=
{
empty
with
position
=
(
get_position
t
)
+.
0
.
01
}
let
position_comp
n1
n2
=
Pervasives
.
compare
n1
.
position
n2
.
position
let
rename
mapping
n
=
{
n
with
next
=
Massoc_gid
.
rename
mapping
n
.
next
}
...
...
src/grew_node.mli
View file @
8b3202b7
...
...
@@ -53,6 +53,7 @@ module G_node: sig
val
get_annot_info
:
t
->
string
option
val
build_neighbour
:
t
->
t
val
build_new
:
t
->
t
val
rename
:
(
Gid
.
t
*
Gid
.
t
)
list
->
t
->
t
end
...
...
src/grew_rule.ml
View file @
8b3202b7
...
...
@@ -352,7 +352,7 @@ module Rule = struct
G_deco
.
edges
=
List
.
fold_left
(
fun
acc
(
_
,
edge
)
->
edge
::
acc
)
matching
.
a_match
matching
.
e_match
;
}
let
find
cnode
?
loc
(
matching
,
created_nodes
)
=
let
find
cnode
?
loc
(
matching
,
(
created_nodes
,
activated_nodes
)
)
=
match
cnode
with
|
Command
.
Pat
pid
->
(
try
Pid_map
.
find
pid
matching
.
n_match
...
...
@@ -360,7 +360,10 @@ module Rule = struct
|
Command
.
New
name
->
(
try
List
.
assoc
name
created_nodes
with
Not_found
->
Error
.
run
?
loc
"Identifier '%s' not found"
name
)
|
Command
.
Act
_
->
Log
.
critical
"TODO: not yet implemented"
|
Command
.
Act
(
pid
,
new_name
)
->
(
try
List
.
assoc
(
pid
,
new_name
)
activated_nodes
with
Not_found
->
Error
.
run
?
loc
"Activated identifier with suffix '%s' not found"
new_name
)
let
down_deco
(
matching
,
created_nodes
)
commands
=
...
...
@@ -566,8 +569,8 @@ module Rule = struct
exception
Command_execution_fail
(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
let
apply_command
(
command
,
loc
)
instance
matching
created_nodes
=
let
node_find
cnode
=
find
~
loc
cnode
(
matching
,
created_nodes
)
in
let
apply_command
(
command
,
loc
)
instance
matching
(
created_nodes
,
(
activated_nodes
:
((
Pid
.
t
*
string
)
*
Gid
.
t
)
list
))
=
let
node_find
cnode
=
find
~
loc
cnode
(
matching
,
(
created_nodes
,
activated_nodes
)
)
in
match
command
with
|
Command
.
ADD_EDGE
(
src_cn
,
tar_cn
,
edge
)
->
...
...
@@ -581,7 +584,7 @@ module Rule = struct
Instance
.
graph
=
new_graph
;
history
=
List_
.
sort_insert
(
Command
.
H_ADD_EDGE
(
src_gid
,
tar_gid
,
edge
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
None
->
Error
.
run
"ADD_EDGE: the edge '%s' already exists %s"
(
G_edge
.
to_string
edge
)
(
Loc
.
to_string
loc
)
...
...
@@ -595,7 +598,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
del_edge
loc
instance
.
Instance
.
graph
src_gid
edge
tar_gid
;
history
=
List_
.
sort_insert
(
Command
.
H_DEL_EDGE_EXPL
(
src_gid
,
tar_gid
,
edge
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
DEL_EDGE_NAME
edge_ident
->
...
...
@@ -607,7 +610,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
del_edge
~
edge_ident
loc
instance
.
Instance
.
graph
src_gid
edge
tar_gid
;
history
=
List_
.
sort_insert
(
Command
.
H_DEL_EDGE_EXPL
(
src_gid
,
tar_gid
,
edge
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
DEL_NODE
node_cn
->
...
...
@@ -617,7 +620,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
del_node
instance
.
Instance
.
graph
node_gid
;
history
=
List_
.
sort_insert
(
Command
.
H_DEL_NODE
node_gid
)
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
MERGE_NODE
(
src_cn
,
tar_cn
)
->
...
...
@@ -630,7 +633,7 @@ module Rule = struct
Instance
.
graph
=
new_graph
;
history
=
List_
.
sort_insert
(
Command
.
H_MERGE_NODE
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
None
->
raise
Command_execution_fail
)
...
...
@@ -658,7 +661,7 @@ module Rule = struct
Instance
.
graph
=
new_graph
;
history
=
List_
.
sort_insert
(
Command
.
H_UPDATE_FEAT
(
tar_gid
,
tar_feat_name
,
new_feature_value
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
DEL_FEAT
(
tar_cn
,
feat_name
)
->
...
...
@@ -668,7 +671,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
del_feat
instance
.
Instance
.
graph
tar_gid
feat_name
;
history
=
List_
.
sort_insert
(
Command
.
H_DEL_FEAT
(
tar_gid
,
feat_name
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
NEW_NEIGHBOUR
(
created_name
,
edge
,
base_pid
)
->
...
...
@@ -680,7 +683,18 @@ module Rule = struct
history
=
List_
.
sort_insert
(
Command
.
H_NEW_NEIGHBOUR
(
created_name
,
edge
,
new_gid
))
instance
.
Instance
.
history
;
activated_node
=
new_gid
::
instance
.
Instance
.
activated_node
;
}
,
(
created_name
,
new_gid
)
::
created_nodes
((
created_name
,
new_gid
)
::
created_nodes
,
activated_nodes
)
)
|
Command
.
ACT_NODE
(
Command
.
Act
(
pid
,
new_name
))
->
let
node_gid
=
node_find
(
Command
.
Pat
(
pid
))
in
let
(
new_gid
,
new_graph
)
=
G_graph
.
activate
loc
node_gid
new_name
instance
.
Instance
.
graph
in
(
{
instance
with
Instance
.
graph
=
new_graph
;
history
=
List_
.
sort_insert
(
Command
.
H_ACT_NODE
(
node_gid
,
new_name
))
instance
.
Instance
.
history
}
,
(
created_nodes
,
((
pid
,
new_name
)
,
new_gid
)
::
activated_nodes
)
)
|
Command
.
SHIFT_IN
(
src_cn
,
tar_cn
)
->
...
...
@@ -691,7 +705,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
shift_in
loc
instance
.
Instance
.
graph
src_gid
tar_gid
;
history
=
List_
.
sort_insert
(
Command
.
H_SHIFT_IN
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
SHIFT_OUT
(
src_cn
,
tar_cn
)
->
...
...
@@ -702,7 +716,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
shift_out
loc
instance
.
Instance
.
graph
src_gid
tar_gid
;
history
=
List_
.
sort_insert
(
Command
.
H_SHIFT_OUT
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
|
Command
.
SHIFT_EDGE
(
src_cn
,
tar_cn
)
->
...
...
@@ -713,7 +727,7 @@ module Rule = struct
Instance
.
graph
=
G_graph
.
shift_edges
loc
instance
.
Instance
.
graph
src_gid
tar_gid
;
history
=
List_
.
sort_insert
(
Command
.
H_SHIFT_EDGE
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
(
created_nodes
,
activated_nodes
)
)
(** [apply_rule instance matching rule] returns a new instance after the application of the rule
...
...
@@ -735,7 +749,7 @@ module Rule = struct
(
fun
(
instance
,
created_nodes
)
command
->
apply_command
command
instance
matching
created_nodes
)
(
instance
,
[]
)
(
instance
,
(
[]
,
[]
)
)
rule
.
commands
in
let
rule_app
=
{
...
...
src/libgrew_utils.ml
View file @
8b3202b7
...
...
@@ -169,17 +169,27 @@ module Gid = struct
type
t
=
|
Old
of
int
|
New
of
(
int
*
int
)
(* identifier for "created nodes" *)
|
Act
of
(
int
*
string
)
(* identifier for "activated nodes" *)
(* a compare function which ensures that new nodes are at the "end" of the graph *)
let
compare
t1
t2
=
match
(
t1
,
t2
)
with
|
Old
o1
,
Old
o2
->
Pervasives
.
compare
o1
o2
|
Old
_
,
New
_
->
-
1
|
New
_
,
Old
_
->
1
|
Old
o1
,
Old
o2
->
Pervasives
.
compare
o1
o2
|
New
n1
,
New
n2
->
Pervasives
.
compare
n1
n2
|
Old
_
,
Act
_
->
-
1
|
Act
_
,
Old
_
->
1
|
Act
n1
,
Act
n2
->
Pervasives
.
compare
n1
n2
|
Act
_
,
New
_
->
-
1
|
New
_
,
Act
_
->
1
let
to_string
=
function
|
Old
i
->
sprintf
"%d"
i
|
New
(
i
,
j
)
->
sprintf
"%d__%d"
i
j
|
Act
(
i
,
n
)
->
sprintf
"%d#%s"
i
n
end
(* module Gid *)
(* ================================================================================ *)
...
...
src/libgrew_utils.mli
View file @
8b3202b7
...
...
@@ -83,6 +83,7 @@ module Gid : sig
type
t
=
|
Old
of
int
|
New
of
(
int
*
int
)
(* identifier for "created nodes" *)
|
Act
of
(
int
*
string
)
(* identifier for "activated nodes" *)
val
compare
:
t
->
t
->
int
...
...
src/parser/lexer.mll
View file @
8b3202b7
...
...
@@ -22,6 +22,7 @@
(* a general notion of "ident" is needed to cover all usages:
with or without '#', with several '.' (separator for feature names and usual symbol for labels...) *)
let
parse_complex_ident
string
=
printf
"--parse_complex_ident-->%s<--
\n
%!"
string
;
match
Str
.
split
(
Str
.
regexp
"#"
)
string
with
|
[
x
]
->
Ast
.
No_sharp
x
|
[
x
;
y
]
->
Ast
.
Sharp
(
x
,
y
)
...
...
@@ -118,6 +119,7 @@ and global = parse
|
"del_node"
{
DEL_NODE
}
|
"add_node"
{
ADD_NODE
}
|
"del_feat"
{
DEL_FEAT
}
|
"activate"
{
ACTIVATE
}
|
"module"
{
MODULE
}
|
"confluent"
{
CONFLUENT
}
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment