Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
grew
libcaml-grew
Commits
c0994a10
Commit
c0994a10
authored
Oct 05, 2012
by
Bruno Guillaume
Browse files
add support for n#a node names in commands
parent
5a523355
Changes
10
Hide whitespace changes
Inline
Side-by-side
src/grew_ast.ml
View file @
c0994a10
...
...
@@ -23,9 +23,6 @@ module Ast = struct
type
feature
=
u_feature
*
Loc
.
t
(* qualified feature name "A.lemma" *)
type
qfn
=
string
*
string
type
u_node
=
{
node_id
:
Id
.
name
;
position
:
int
option
;
...
...
@@ -50,14 +47,16 @@ module Ast = struct
|
Le
->
"≤"
|
Ge
->
"≥"
type
feature_name
=
string
type
u_const
=
|
Start
of
Id
.
name
*
string
list
(* (source, labels) *)
|
Cst_out
of
Id
.
name
|
End
of
Id
.
name
*
string
list
(* (target, labels) *)
|
Cst_in
of
Id
.
name
|
Feature_eq
of
qfn
*
qfn
|
Feature_diseq
of
qfn
*
qfn
|
Feature_ineq
of
ineq
*
qfn
*
qfn
|
Feature_eq
of
(
Id
.
name
*
feature_name
)
*
(
Id
.
name
*
feature_name
)
|
Feature_diseq
of
(
Id
.
name
*
feature_name
)
*
(
Id
.
name
*
feature_name
)
|
Feature_ineq
of
ineq
*
(
Id
.
name
*
feature_name
)
*
(
Id
.
name
*
feature_name
)
type
const
=
u_const
*
Loc
.
t
...
...
@@ -67,24 +66,37 @@ module Ast = struct
pat_const
:
const
list
;
}
type
graph
=
{
nodes
:
(
Id
.
name
*
node
)
list
;
edge
:
edge
list
;
}
(* the base node name and the eventual new_node extension *)
type
c_ident
=
Id
.
name
*
string
option
let
c_ident_to_string
(
string_node
,
new_opt
)
=
match
new_opt
with
|
None
->
string_node
|
Some
a
->
sprintf
"%s#%s"
string_node
a
type
concat_item
=
|
Qfn_item
of
(
string
*
string
)
|
Qfn_item
of
(
c_ident
*
feature_name
)
|
String_item
of
string
|
Param_item
of
string
type
u_command
=
|
Del_edge_expl
of
(
Id
.
name
*
Id
.
name
*
string
)
|
Del_edge_expl
of
(
c_ident
*
c_ident
*
string
)
|
Del_edge_name
of
string
|
Add_edge
of
(
Id
.
name
*
Id
.
name
*
string
)
|
Shift_in
of
(
Id
.
name
*
Id
.
name
)
|
Shift_out
of
(
Id
.
name
*
Id
.
name
)
|
Shift_edge
of
(
Id
.
name
*
Id
.
name
)
|
Merge_node
of
(
Id
.
name
*
Id
.
name
)
|
New_neighbour
of
(
Id
.
name
*
Id
.
name
*
string
)
|
Del_node
of
Id
.
name
|
Del_feat
of
qfn
|
Update_feat
of
qfn
*
concat_item
list
|
Add_edge
of
(
c_ident
*
c_ident
*
string
)
|
Shift_in
of
(
c_ident
*
c_ident
)
|
Shift_out
of
(
c_ident
*
c_ident
)
|
Shift_edge
of
(
c_ident
*
c_ident
)
|
Merge_node
of
(
c_ident
*
c_ident
)
|
New_neighbour
of
(
c_ident
*
c_ident
*
string
)
|
Del_node
of
c_ident
|
Del_feat
of
(
c_ident
*
feature_name
)
|
Update_feat
of
(
c_ident
*
feature_name
)
*
concat_item
list
type
command
=
u_command
*
Loc
.
t
...
...
src/grew_ast.mli
View file @
c0994a10
...
...
@@ -20,9 +20,6 @@ module Ast : sig
type
feature
=
u_feature
*
Loc
.
t
(* qualified feature name "A.lemma" *)
type
qfn
=
string
*
string
type
u_node
=
{
node_id
:
Id
.
name
;
position
:
int
option
;
...
...
@@ -45,14 +42,16 @@ module Ast : sig
val
string_of_ineq
:
ineq
->
string
type
feature_name
=
string
type
u_const
=
|
Start
of
Id
.
name
*
string
list
(* (source, labels) *)
|
Cst_out
of
Id
.
name
|
End
of
Id
.
name
*
string
list
(* (target, labels) *)
|
Cst_in
of
Id
.
name
|
Feature_eq
of
qfn
*
qfn
|
Feature_diseq
of
qfn
*
qfn
|
Feature_ineq
of
ineq
*
qfn
*
qfn
|
Feature_eq
of
(
Id
.
name
*
feature_name
)
*
(
Id
.
name
*
feature_name
)
|
Feature_diseq
of
(
Id
.
name
*
feature_name
)
*
(
Id
.
name
*
feature_name
)
|
Feature_ineq
of
ineq
*
(
Id
.
name
*
feature_name
)
*
(
Id
.
name
*
feature_name
)
type
const
=
u_const
*
Loc
.
t
...
...
@@ -62,24 +61,29 @@ module Ast : sig
pat_const
:
const
list
;
}
(* the base node name and the eventual new_node extension *)
type
c_ident
=
Id
.
name
*
string
option
val
c_ident_to_string
:
c_ident
->
string
type
concat_item
=
|
Qfn_item
of
(
string
*
string
)
|
Qfn_item
of
(
c_ident
*
feature_name
)
|
String_item
of
string
|
Param_item
of
string
type
u_command
=
|
Del_edge_expl
of
(
Id
.
name
*
Id
.
name
*
string
)
|
Del_edge_expl
of
(
c_ident
*
c_ident
*
string
)
|
Del_edge_name
of
string
|
Add_edge
of
(
Id
.
name
*
Id
.
name
*
string
)
|
Shift_in
of
(
Id
.
name
*
Id
.
name
)
|
Shift_out
of
(
Id
.
name
*
Id
.
name
)
|
Shift_edge
of
(
Id
.
name
*
Id
.
name
)
|
Merge_node
of
(
Id
.
name
*
Id
.
name
)
|
New_neighbour
of
(
Id
.
name
*
Id
.
name
*
string
)
|
Del_node
of
Id
.
name
|
Del_feat
of
qfn
|
Update_feat
of
qfn
*
concat_item
list
|
Add_edge
of
(
c_ident
*
c_ident
*
string
)
|
Shift_in
of
(
c_ident
*
c_ident
)
|
Shift_out
of
(
c_ident
*
c_ident
)
|
Shift_edge
of
(
c_ident
*
c_ident
)
|
Merge_node
of
(
c_ident
*
c_ident
)
|
New_neighbour
of
(
c_ident
*
c_ident
*
string
)
|
Del_node
of
c_ident
|
Del_feat
of
(
c_ident
*
feature_name
)
|
Update_feat
of
(
c_ident
*
feature_name
)
*
concat_item
list
type
command
=
u_command
*
Loc
.
t
...
...
src/grew_command.ml
View file @
c0994a10
...
...
@@ -6,13 +6,12 @@ open Grew_ast
open
Grew_edge
open
Grew_fs
(* ==================================================================================================== *)
module
Command
=
struct
type
pid
=
Pid
.
t
type
gid
=
Gid
.
t
type
cnode
=
(* a command node is either: *)
|
Pid
of
pid
(* a node identified in the pattern *)
|
New
of
string
(* a node introduced by a new_neighbour *)
type
cnode
=
(* 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 *)
type
item
=
|
Feat
of
(
cnode
*
string
)
...
...
@@ -28,7 +27,7 @@ module Command = struct
|
ADD_EDGE
of
(
cnode
*
cnode
*
G_edge
.
t
)
|
DEL_FEAT
of
(
cnode
*
string
)
|
UPDATE_FEAT
of
(
cnode
*
string
*
item
list
)
|
NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
p
id
)
|
NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
P
id
.
t
)
|
SHIFT_EDGE
of
(
cnode
*
cnode
)
|
SHIFT_IN
of
(
cnode
*
cnode
)
|
SHIFT_OUT
of
(
cnode
*
cnode
)
...
...
@@ -38,66 +37,72 @@ module Command = struct
(* a item in the command history: command applied to a graph *)
type
h
=
|
H_DEL_NODE
of
g
id
|
H_DEL_EDGE_EXPL
of
(
g
id
*
g
id
*
G_edge
.
t
)
|
H_DEL_NODE
of
G
id
.
t
|
H_DEL_EDGE_EXPL
of
(
G
id
.
t
*
G
id
.
t
*
G_edge
.
t
)
|
H_DEL_EDGE_NAME
of
string
|
H_ADD_EDGE
of
(
g
id
*
g
id
*
G_edge
.
t
)
|
H_DEL_FEAT
of
(
g
id
*
string
)
|
H_UPDATE_FEAT
of
(
g
id
*
string
*
string
)
|
H_NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
g
id
)
|
H_SHIFT_EDGE
of
(
g
id
*
g
id
)
|
H_SHIFT_IN
of
(
g
id
*
g
id
)
|
H_SHIFT_OUT
of
(
g
id
*
g
id
)
|
H_MERGE_NODE
of
(
g
id
*
g
id
)
let
build
?
param
(
k
n
i
,
kei
)
table
locals
ast_command
=
let
get_pid
node_name
=
match
Id
.
build_opt
node_name
table
with
|
Some
id
->
P
id
(
Pid
.
Pos
id
)
|
None
->
New
node_name
in
let
check_
node
loc
node_id
k
n
i
=
if
not
(
List
.
mem
node_id
k
n
i
)
then
Error
.
build
~
loc
"Unbound
node
identifier
\"
%s
\"
"
node_id
in
|
H_ADD_EDGE
of
(
G
id
.
t
*
G
id
.
t
*
G_edge
.
t
)
|
H_DEL_FEAT
of
(
G
id
.
t
*
string
)
|
H_UPDATE_FEAT
of
(
G
id
.
t
*
string
*
string
)
|
H_NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
G
id
.
t
)
|
H_SHIFT_EDGE
of
(
G
id
.
t
*
G
id
.
t
)
|
H_SHIFT_IN
of
(
G
id
.
t
*
G
id
.
t
)
|
H_SHIFT_OUT
of
(
G
id
.
t
*
G
id
.
t
)
|
H_MERGE_NODE
of
(
G
id
.
t
*
G
id
.
t
)
let
build
?
param
(
k
c
i
,
kei
)
table
locals
ast_command
=
let
pid_of_c_ident
=
function
|
(
node_name
,
None
)
->
P
at
(
Pid
.
Pos
(
Id
.
build
node_name
table
)
)
|
(
node_name
,
Some
n
)
->
Act
(
Pid
.
Pos
(
Id
.
build
node_name
table
)
,
n
)
in
let
check_
c_ident
loc
c_ident
k
c
i
=
if
not
(
List
.
mem
c_ident
k
c
i
)
then
Error
.
build
~
loc
"Unbound
c_ident
identifier
\"
%s
\"
"
(
Ast
.
c_ident_to_string
c_ident
)
in
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
(
i
,
j
,
lab
)
,
loc
)
->
check_node
loc
i
kni
;
check_node
loc
j
kni
;
|
(
Ast
.
Del_edge_expl
(
i
,
j
,
lab
)
,
loc
)
->
check_c_ident
loc
i
kci
;
check_c_ident
loc
j
kci
;
let
edge
=
G_edge
.
make
~
locals
lab
in
((
DEL_EDGE_EXPL
(
get_pid
i
,
get_pid
j
,
edge
)
,
loc
)
,
(
k
n
i
,
kei
))
((
DEL_EDGE_EXPL
(
pid_of_c_ident
i
,
pid_of_c_ident
j
,
edge
)
,
loc
)
,
(
k
c
i
,
kei
))
|
(
Ast
.
Del_edge_name
id
,
loc
)
->
|
(
Ast
.
Del_edge_name
id
,
loc
)
->
check_edge
loc
id
kei
;
(
DEL_EDGE_NAME
id
,
loc
)
,
(
k
n
i
,
List_
.
rm
id
kei
)
(
DEL_EDGE_NAME
id
,
loc
)
,
(
k
c
i
,
List_
.
rm
id
kei
)
|
(
Ast
.
Add_edge
(
i
,
j
,
lab
)
,
loc
)
->
check_node
loc
i
kni
;
check_node
loc
j
kni
;
|
(
Ast
.
Add_edge
(
i
,
j
,
lab
)
,
loc
)
->
check_c_ident
loc
i
kci
;
check_c_ident
loc
j
kci
;
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
)
->
check_node
loc
i
kni
;
check_node
loc
j
kni
;
((
SHIFT_EDGE
(
get_pid
i
,
get_pid
j
)
,
loc
)
,
(
kni
,
kei
))
((
ADD_EDGE
(
pid_of_c_ident
i
,
pid_of_c_ident
j
,
edge
)
,
loc
)
,
(
kci
,
kei
))
|
(
Ast
.
Shift_in
(
i
,
j
)
,
loc
)
->
check_node
loc
i
kni
;
check_node
loc
j
kni
;
((
SHIFT_IN
(
get_pid
i
,
get_pid
j
)
,
loc
)
,
(
kni
,
kei
))
|
(
Ast
.
Shift_edge
(
i
,
j
)
,
loc
)
->
check_c_ident
loc
i
kci
;
check_c_ident
loc
j
kci
;
((
SHIFT_EDGE
(
pid_of_c_ident
i
,
pid_of_c_ident
j
)
,
loc
)
,
(
kci
,
kei
))
|
(
Ast
.
Shift_out
(
i
,
j
)
,
loc
)
->
check_node
loc
i
kni
;
check_node
loc
j
kni
;
((
SHIFT_OUT
(
get_pid
i
,
get_pid
j
)
,
loc
)
,
(
kni
,
kei
))
|
(
Ast
.
Shift_in
(
i
,
j
)
,
loc
)
->
check_c_ident
loc
i
kci
;
check_c_ident
loc
j
kci
;
((
SHIFT_IN
(
pid_of_c_ident
i
,
pid_of_c_ident
j
)
,
loc
)
,
(
kci
,
kei
))
|
(
Ast
.
Merge_node
(
i
,
j
)
,
loc
)
->
check_node
loc
i
kni
;
check_node
loc
j
kni
;
((
MERGE_NODE
(
get_pid
i
,
get_pid
j
)
,
loc
)
,
(
List_
.
rm
i
kni
,
kei
))
|
(
Ast
.
New_neighbour
(
name_created
,
ancestor
,
label
)
,
loc
)
->
check_node
loc
ancestor
kni
;
if
List
.
mem
name_created
kni
|
(
Ast
.
Shift_out
(
i
,
j
)
,
loc
)
->
check_c_ident
loc
i
kci
;
check_c_ident
loc
j
kci
;
((
SHIFT_OUT
(
pid_of_c_ident
i
,
pid_of_c_ident
j
)
,
loc
)
,
(
kci
,
kei
))
|
(
Ast
.
Merge_node
(
i
,
j
)
,
loc
)
->
check_c_ident
loc
i
kci
;
check_c_ident
loc
j
kci
;
((
MERGE_NODE
(
pid_of_c_ident
i
,
pid_of_c_ident
j
)
,
loc
)
,
(
List_
.
rm
i
kci
,
kei
))
|
(
Ast
.
New_neighbour
((
name_created
,
None
)
,
ancestor
,
label
)
,
loc
)
->
check_c_ident
loc
ancestor
kci
;
if
List
.
mem
(
name_created
,
None
)
kci
then
Error
.
build
~
loc
"Node identifier
\"
%s
\"
is already used"
name_created
;
let
edge
=
G_edge
.
make
~
locals
label
in
begin
...
...
@@ -106,39 +111,40 @@ module Command = struct
(
NEW_NEIGHBOUR
(
name_created
,
edge
,
Pid
.
Pos
(
Id
.
build
~
loc
ancestor
table
)
Pid
.
Pos
(
Id
.
build
~
loc
(
fst
ancestor
)
table
)
)
,
loc
)
,
(
name_created
::
k
n
i
,
kei
)
(
(
name_created
,
None
)
::
k
c
i
,
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
)
ancestor
(
fst
ancestor
)
(
Loc
.
to_string
loc
)
end
|
(
Ast
.
Del_node
n
,
loc
)
->
check_
node
loc
n
k
n
i
;
((
DEL_NODE
(
get_pid
n
)
,
loc
)
,
(
List_
.
rm
n
k
n
i
,
kei
))
|
(
Ast
.
Del_node
n
,
loc
)
->
check_
c_ident
loc
n
k
c
i
;
((
DEL_NODE
(
pid_of_c_ident
n
)
,
loc
)
,
(
List_
.
rm
n
k
c
i
,
kei
))
|
(
Ast
.
Del_feat
(
node
,
feat_name
)
,
loc
)
->
check_
node
loc
node
k
n
i
;
((
DEL_FEAT
(
get_pid
node
,
feat_name
)
,
loc
)
,
(
k
n
i
,
kei
))
|
(
Ast
.
Del_feat
(
c_ident
,
feat_name
)
,
loc
)
->
check_
c_ident
loc
c_ident
k
c
i
;
((
DEL_FEAT
(
pid_of_c_ident
c_ident
,
feat_name
)
,
loc
)
,
(
k
c
i
,
kei
))
|
(
Ast
.
Update_feat
((
tar_node
,
tar_
feat_name
)
,
ast_items
)
,
loc
)
->
check_
node
loc
tar_node
k
n
i
;
|
(
Ast
.
Update_feat
((
c_ident
,
feat_name
)
,
ast_items
)
,
loc
)
->
check_
c_ident
loc
c_ident
k
c
i
;
let
items
=
List
.
map
(
function
|
Ast
.
Qfn_item
(
node
,
feat_name
)
->
check_node
loc
node
kni
;
Feat
(
get_pid
node
,
feat_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
(
get_pid
tar_node
,
tar_feat_name
,
items
)
,
loc
)
,
(
kni
,
kei
))
end
(
function
|
Ast
.
Qfn_item
(
ci
,
fn
)
->
check_c_ident
loc
ci
kci
;
Feat
(
pid_of_c_ident
ci
,
fn
)
|
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_c_ident
c_ident
,
feat_name
,
items
)
,
loc
)
,
(
kci
,
kei
))
|
_
->
failwith
"TODO remove with new neighbour"
end
(* module Command *)
src/grew_command.mli
View file @
c0994a10
...
...
@@ -2,13 +2,12 @@ open Grew_ast
open
Grew_utils
open
Grew_edge
(* ==================================================================================================== *)
module
Command
:
sig
type
pid
=
Pid
.
t
type
gid
=
Gid
.
t
type
cnode
=
(* a command node is either: *)
|
P
id
of
p
id
(* a node identified in the pattern *)
|
P
at
of
P
id
.
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
=
|
Feat
of
(
cnode
*
string
)
...
...
@@ -16,40 +15,39 @@ module Command : sig
|
Param_in
of
int
|
Param_out
of
int
type
p
=
type
p
=
|
DEL_NODE
of
cnode
|
DEL_EDGE_EXPL
of
(
cnode
*
cnode
*
G_edge
.
t
)
|
DEL_EDGE_EXPL
of
(
cnode
*
cnode
*
G_edge
.
t
)
|
DEL_EDGE_NAME
of
string
|
ADD_EDGE
of
(
cnode
*
cnode
*
G_edge
.
t
)
|
DEL_FEAT
of
(
cnode
*
string
)
|
UPDATE_FEAT
of
(
cnode
*
string
*
item
list
)
|
NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
p
id
)
|
NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
P
id
.
t
)
|
SHIFT_EDGE
of
(
cnode
*
cnode
)
|
SHIFT_IN
of
(
cnode
*
cnode
)
|
SHIFT_OUT
of
(
cnode
*
cnode
)
|
MERGE_NODE
of
(
cnode
*
cnode
)
type
t
=
(
p
*
Loc
.
t
)
type
h
=
|
H_DEL_NODE
of
g
id
|
H_DEL_EDGE_EXPL
of
(
g
id
*
g
id
*
G_edge
.
t
)
type
t
=
(
p
*
Loc
.
t
)
type
h
=
|
H_DEL_NODE
of
G
id
.
t
|
H_DEL_EDGE_EXPL
of
(
G
id
.
t
*
G
id
.
t
*
G_edge
.
t
)
|
H_DEL_EDGE_NAME
of
string
|
H_ADD_EDGE
of
(
g
id
*
g
id
*
G_edge
.
t
)
|
H_DEL_FEAT
of
(
g
id
*
string
)
|
H_UPDATE_FEAT
of
(
g
id
*
string
*
string
)
|
H_NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
g
id
)
|
H_SHIFT_EDGE
of
(
g
id
*
g
id
)
|
H_SHIFT_IN
of
(
g
id
*
g
id
)
|
H_SHIFT_OUT
of
(
g
id
*
g
id
)
|
H_MERGE_NODE
of
(
g
id
*
g
id
)
|
H_ADD_EDGE
of
(
G
id
.
t
*
G
id
.
t
*
G_edge
.
t
)
|
H_DEL_FEAT
of
(
G
id
.
t
*
string
)
|
H_UPDATE_FEAT
of
(
G
id
.
t
*
string
*
string
)
|
H_NEW_NEIGHBOUR
of
(
string
*
G_edge
.
t
*
G
id
.
t
)
|
H_SHIFT_EDGE
of
(
G
id
.
t
*
G
id
.
t
)
|
H_SHIFT_IN
of
(
G
id
.
t
*
G
id
.
t
)
|
H_SHIFT_OUT
of
(
G
id
.
t
*
G
id
.
t
)
|
H_MERGE_NODE
of
(
G
id
.
t
*
G
id
.
t
)
val
build
:
val
build
:
?
param
:
(
string
list
*
string
list
)
->
(
st
ring
list
*
string
list
)
->
Id
.
table
->
(
A
st
.
c_ident
list
*
string
list
)
->
Id
.
table
->
Label
.
decl
array
->
Ast
.
command
->
t
*
(
string
list
*
string
list
)
end
Ast
.
command
->
t
*
(
Ast
.
c_ident
list
*
string
list
)
end
(* module Command *)
src/grew_grs.ml
View file @
c0994a10
...
...
@@ -9,9 +9,8 @@ open Grew_command
open
Grew_graph
open
Grew_rule
(* ==================================================================================================== *)
module
Rewrite_history
=
struct
type
t
=
{
instance
:
Instance
.
t
;
module_name
:
string
;
...
...
@@ -27,7 +26,6 @@ module Rewrite_history = struct
|
{
good_nf
=
[]
}
->
0
(* dead branch *)
|
{
good_nf
=
l
}
->
List
.
fold_left
(
fun
acc
t
->
acc
+
(
num_sol
t
))
0
l
let
save_nfs
?
main_feat
~
dot
base_name
t
=
let
rec
loop
file_name
rules
t
=
match
(
t
.
good_nf
,
t
.
bad_nf
)
with
...
...
@@ -47,7 +45,6 @@ module Rewrite_history = struct
[]
l
in
loop
base_name
[]
t
let
save_gr
base
t
=
let
rec
loop
file_name
t
=
match
(
t
.
good_nf
,
t
.
bad_nf
)
with
...
...
@@ -63,11 +60,9 @@ module Rewrite_history = struct
|
[
one
]
,
[]
->
loop
one
|
_
->
Error
.
run
"Not a single rewriting"
in
loop
t
end
end
(* module Rewrite_history *)
(* ==================================================================================================== *)
module
Modul
=
struct
type
t
=
{
name
:
string
;
...
...
@@ -102,8 +97,9 @@ module Modul = struct
loc
=
ast_module
.
Ast
.
mod_loc
;
}
in
check
modul
;
modul
end
end
(* module Modul *)
(* ==================================================================================================== *)
module
Sequence
=
struct
type
t
=
{
name
:
string
;
...
...
@@ -127,8 +123,9 @@ module Sequence = struct
loc
=
ast_sequence
.
Ast
.
seq_loc
;
}
in
check
module_list
sequence
;
sequence
end
end
(* module Sequence *)
(* ==================================================================================================== *)
module
Grs
=
struct
type
t
=
{
...
...
@@ -253,4 +250,4 @@ module Grs = struct
(
fun
modul
->
List
.
iter
(
fun
filter
->
fct
modul
.
Modul
.
name
filter
)
modul
.
Modul
.
filters
)
grs
.
modules
end
end
(* module Grs *)
src/grew_html.ml
View file @
c0994a10
...
...
@@ -27,27 +27,30 @@ let html_header ?title buff =
module
Html_doc
=
struct
let
string_of_concat_item
=
function
|
Ast
.
Qfn_item
(
n
,
f
)
->
sprintf
"%s.%s"
n
f
|
Ast
.
Qfn_item
(
n
,
f
n
)
->
sprintf
"%s.%s"
(
Ast
.
c_ident_to_string
n
)
f
n
|
Ast
.
String_item
s
->
sprintf
"
\"
%s
\"
"
s
|
Ast
.
Param_item
var
->
sprintf
"%s"
var
let
string_of_qfn
(
node
,
feat_name
)
=
sprintf
"%s.%s"
node
feat_name
let
buff_html_command
?
(
li_html
=
false
)
buff
(
u_command
,_
)
=
bprintf
buff
" "
;
if
li_html
then
bprintf
buff
"<li>"
;
(
match
u_command
with
|
Ast
.
Del_edge_expl
(
n1
,
n2
,
label
)
->
bprintf
buff
"del_edge %s -[%s]-> %s"
n1
label
n2
|
Ast
.
Del_edge_expl
(
n1
,
n2
,
label
)
->
bprintf
buff
"del_edge %s -[%s]-> %s"
(
Ast
.
c_ident_to_string
n1
)
label
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
Del_edge_name
name
->
bprintf
buff
"del_edge %s"
name
|
Ast
.
Add_edge
(
n1
,
n2
,
label
)
->
bprintf
buff
"add_edge %s -[%s]-> %s"
n1
label
n2
|
Ast
.
Shift_in
(
n1
,
n2
)
->
bprintf
buff
"shift_in %s ==> %s"
n1
n2
|
Ast
.
Shift_out
(
n1
,
n2
)
->
bprintf
buff
"shift_out %s ==> %s"
n1
n2
|
Ast
.
Shift_edge
(
n1
,
n2
)
->
bprintf
buff
"shift %s ==> %s"
n1
n2
|
Ast
.
Merge_node
(
n1
,
n2
)
->
bprintf
buff
"merge %s ==> %s"
n1
n2
|
Ast
.
New_neighbour
(
n1
,
n2
,
label
)
->
bprintf
buff
"add_node %s: <-[%s]- %s"
n1
label
n2
|
Ast
.
Del_node
n
->
bprintf
buff
"del_node %s"
n
|
Ast
.
Update_feat
(
qfn
,
item_list
)
->
bprintf
buff
"%s = %s"
(
string_of_qfn
qfn
)
(
List_
.
to_string
string_of_concat_item
" + "
item_list
)
|
Ast
.
Del_feat
qfn
->
bprintf
buff
"del_feat %s"
(
string_of_qfn
qfn
)
|
Ast
.
Add_edge
(
n1
,
n2
,
label
)
->
bprintf
buff
"add_edge %s -[%s]-> %s"
(
Ast
.
c_ident_to_string
n1
)
label
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
Shift_in
(
n1
,
n2
)
->
bprintf
buff
"shift_in %s ==> %s"
(
Ast
.
c_ident_to_string
n1
)
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
Shift_out
(
n1
,
n2
)
->
bprintf
buff
"shift_out %s ==> %s"
(
Ast
.
c_ident_to_string
n1
)
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
Shift_edge
(
n1
,
n2
)
->
bprintf
buff
"shift %s ==> %s"
(
Ast
.
c_ident_to_string
n1
)
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
Merge_node
(
n1
,
n2
)
->
bprintf
buff
"merge %s ==> %s"
(
Ast
.
c_ident_to_string
n1
)
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
New_neighbour
(
n1
,
n2
,
label
)
->
bprintf
buff
"add_node %s: <-[%s]- %s"
(
Ast
.
c_ident_to_string
n1
)
label
(
Ast
.
c_ident_to_string
n2
)
|
Ast
.
Del_node
n
->
bprintf
buff
"del_node %s"
(
Ast
.
c_ident_to_string
n
)
|
Ast
.
Update_feat
((
n
,
fn
)
,
item_list
)
->
bprintf
buff
"%s.%s = %s"
(
Ast
.
c_ident_to_string
n
)
fn
(
List_
.
to_string
string_of_concat_item
" + "
item_list
)
|
Ast
.
Del_feat
(
n
,
fn
)
->
bprintf
buff
"del_feat %s.%s"
(
Ast
.
c_ident_to_string
n
)
fn
);
if
li_html
then
bprintf
buff
"</li>
\n
"
else
bprintf
buff
";
\n
"
...
...
@@ -83,9 +86,10 @@ module Html_doc = struct
|
Ast
.
Cst_out
id
->
bprintf
buff
"%s -> *"
id
|
Ast
.
End
(
id
,
labels
)
->
bprintf
buff
"* -[%s]-> %s"
(
List_
.
to_string
(
fun
x
->
x
)
"|"
labels
)
id
|
Ast
.
Cst_in
id
->
bprintf
buff
"* -> %s"
id
|
Ast
.
Feature_eq
(
qfn_l
,
qfn_r
)
->
bprintf
buff
"%s = %s"
(
string_of_qfn
qfn_l
)
(
string_of_qfn
qfn_r
)
|
Ast
.
Feature_diseq
(
qfn_l
,
qfn_r
)
->
bprintf
buff
"%s <> %s"
(
string_of_qfn
qfn_l
)
(
string_of_qfn
qfn_r
)
|
Ast
.
Feature_ineq
(
ineq
,
qfn_l
,
qfn_r
)
->
bprintf
buff
"%s %s %s"
(
string_of_qfn
qfn_l
)
(
Ast
.
string_of_ineq
ineq
)
(
string_of_qfn
qfn_r
));
|
Ast
.
Feature_eq
((
n_l
,
fn_l
)
,
(
n_r
,
fn_r
))
->
bprintf
buff
"%s.%s = %s.%s"
n_l
fn_l
n_r
fn_r
;
|
Ast
.
Feature_diseq
((
n_l
,
fn_l
)
,
(
n_r
,
fn_r
))
->
bprintf
buff
"%s.%s <> %s.%s"
n_l
fn_l
n_r
fn_r
;
|
Ast
.
Feature_ineq
(
ineq
,
(
n_l
,
fn_l
)
,
(
n_r
,
fn_r
))
->
bprintf
buff
"%s.%s %s %s.%s"
n_l
fn_l
(
Ast
.
string_of_ineq
ineq
)
n_r
fn_r
);
bprintf
buff
"
\n
"
let
buff_html_pos_pattern
buff
pos_pattern
=
...
...
src/grew_rule.ml
View file @
c0994a10
...
...
@@ -62,27 +62,22 @@ ELSE
ENDIF
end
(* module Instance *)
module
Instance_set
=
Set
.
Make
(
Instance
)
(* ================================================================================ *)
module
Instance_set
=
Set
.
Make
(
Instance
)
(* ================================================================================ *)
module
Rule
=
struct
(* the [pid] type is used for pattern identifier *)
type
pid
=
Pid
.
t
(* the [gid] type is used for graph identifier *)
type
gid
=
Gid
.
t
