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
e90891d7
Commit
e90891d7
authored
Aug 14, 2014
by
Bruno Guillaume
Browse files
activate mechanism to create new nodes
parent
7a67b63c
Changes
14
Hide whitespace changes
Inline
Side-by-side
emacs/grew.el
View file @
e90891d7
...
...
@@ -3,10 +3,10 @@
;; Mode used to write Grew with emacs (highlight)
;; see: https://wikilligramme.loria.fr/doku.php?id=grew:grew
(
require
'generic-x
)
;;pour Emacs OK, mais semble ne pas marcher avec XEmacs
(
require
'generic-x
)
;;pour Emacs OK, mais semble ne pas marcher avec XEmacs
(
define-generic-mode
'grew-mode
'
(
"%"
)
;;comments
'
(
"features"
"module"
"rule"
"lex_rule"
"match"
"without"
"labels"
"sequences"
"commands"
"graph"
"confluent"
"include"
"filter"
)
;;keywords
'
(
"features"
"module"
"rule"
"lex_rule"
"match"
"without"
"labels"
"sequences"
"commands"
"graph"
"confluent"
"include"
"filter"
"suffixes"
)
;;keywords
'
(
;; ("class\\s (\*\*)* +\\(\\sw[a-zA-Z0-9_.-]*\\)" 1 'font-lock-type-face);noms de classes
;; ("\?[a-zA-Z0-9]+" . font-lock-variable-name-face)
...
...
src/grew_ast.ml
View file @
e90891d7
...
...
@@ -10,7 +10,6 @@
open
Printf
open
Log
open
Libgrew_utils
module
Ast
=
struct
...
...
@@ -22,6 +21,7 @@ module Ast = struct
type
feature_name
=
string
(* cat, num, ... *)
type
feature_atom
=
string
(* V, N, inf, ... *)
type
feature_value
=
string
(* V, 4, "free text", ... *)
type
suffix
=
string
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
...
...
@@ -217,7 +217,7 @@ module Ast = struct
type
modul
=
{
module_id
:
Id
.
name
;
local_labels
:
(
string
*
string
list
)
list
;
new_node_nam
es
:
string
list
;
suffix
es
:
string
list
;
rules
:
rule
list
;
confluent
:
bool
;
module_doc
:
string
list
;
...
...
src/grew_ast.mli
View file @
e90891d7
...
...
@@ -9,11 +9,12 @@
(**********************************************************************************)
open
Libgrew_utils
module
Ast
:
sig
type
feature_name
=
string
(* cat, num, ... *)
type
feature_atom
=
string
(* V, N, inf, ... *)
type
feature_value
=
string
(* V, 4, "free text", ... *)
type
suffix
=
string
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
...
...
@@ -46,7 +47,7 @@ module Ast : sig
val
act_qfn_of_ci
:
complex_id
->
act_qfn
type
feature_spec
=
type
feature_spec
=
|
Closed
of
feature_name
*
feature_atom
list
(* cat:V,N *)
|
Open
of
feature_name
(* phon, lemma, ... *)
|
Int
of
feature_name
(* position *)
...
...
@@ -54,7 +55,7 @@ module Ast : sig
type
domain
=
feature_spec
list
val
normalize_domain
:
domain
->
domain
type
feature_kind
=
type
feature_kind
=
|
Equality
of
feature_value
list
|
Disequality
of
feature_value
list
|
Param
of
string
(* $ident *)
...
...
@@ -88,7 +89,7 @@ module Ast : sig
type
ineq
=
Lt
|
Gt
|
Le
|
Ge
val
string_of_ineq
:
ineq
->
string
type
u_const
=
type
u_const
=
|
Start
of
Id
.
name
*
edge_label
list
(* (source, labels) *)
|
Cst_out
of
Id
.
name
|
End
of
Id
.
name
*
edge_label
list
(* (target, labels) *)
...
...
@@ -109,7 +110,7 @@ module Ast : sig
|
String_item
of
string
|
Param_item
of
string
type
u_command
=
type
u_command
=
|
Del_edge_expl
of
(
act_id
*
act_id
*
edge_label
)
|
Del_edge_name
of
string
|
Add_edge
of
(
act_id
*
act_id
*
edge_label
)
...
...
@@ -135,36 +136,36 @@ module Ast : sig
rule_doc
:
string
list
;
rule_loc
:
Loc
.
t
;
}
type
modul
=
{
module_id
:
Id
.
name
;
local_labels
:
(
string
*
string
list
)
list
;
new_node_nam
es
:
string
list
;
suffix
es
:
string
list
;
rules
:
rule
list
;
confluent
:
bool
;
module_doc
:
string
list
;
mod_loc
:
Loc
.
t
;
mod_dir
:
string
;
(* the directory where the module is defined (for lp file localisation) *)
}
type
sequence
=
{
seq_name
:
string
;
seq_mod
:
string
list
;
seq_doc
:
string
list
;
seq_loc
:
Loc
.
t
;
}
(**
a GRS: graph rewriting system
(**
a GRS: graph rewriting system
*)
type
module_or_include
=
type
module_or_include
=
|
Modul
of
modul
|
Includ
of
(
string
*
Loc
.
t
)
type
grs_with_include
=
{
domain_wi
:
domain
;
labels_wi
:
(
string
*
string
list
)
list
;
(* the list of global edge labels *)
modules_wi
:
module_or_include
list
;
modules_wi
:
module_or_include
list
;
sequences_wi
:
sequence
list
;
}
...
...
src/grew_command.ml
View file @
e90891d7
...
...
@@ -63,7 +63,7 @@ module Command = struct
|
H_MERGE_NODE
of
(
Gid
.
t
*
Gid
.
t
)
|
H_ACT_NODE
of
(
Gid
.
t
*
string
)
let
build
?
param
(
kai
,
kei
)
table
locals
ast_command
=
let
build
?
param
(
kai
,
kei
)
table
locals
suffixes
ast_command
=
(* kai stands for "known act ident", kei for "known edge ident" *)
let
pid_of_act_id
loc
=
function
...
...
@@ -143,12 +143,15 @@ module Command = struct
(
Loc
.
to_string
loc
)
end
|
(
Ast
.
Activate
(
_
,
None
)
,
loc
)
->
Error
.
build
~
loc
"Cannot activate a pattern node"
|
(
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
))
begin
match
act_n
with
|
(
_
,
None
)
->
Error
.
build
~
loc
"Cannot activate a pattern node"
|
(
src
,
Some
suffix
)
->
check_act_id
loc
(
src
,
None
)
kai
;
if
not
(
List
.
mem
suffix
suffixes
)
then
Error
.
build
~
loc
"Undefined suffix
\"
%s
\"
"
suffix
;
((
ACT_NODE
(
pid_of_act_id
loc
act_n
)
,
loc
)
,
(
act_n
::
kai
,
kei
))
end
|
(
Ast
.
Del_node
act_n
,
loc
)
->
check_act_id
loc
act_n
kai
;
...
...
src/grew_command.mli
View file @
e90891d7
...
...
@@ -60,6 +60,7 @@ module Command : sig
(
Ast
.
act_id
list
*
string
list
)
->
Id
.
table
->
Label
.
decl
array
->
Ast
.
suffix
list
->
Ast
.
command
->
t
*
(
Ast
.
act_id
list
*
string
list
)
end
(* module Command *)
src/grew_graph.ml
View file @
e90891d7
...
...
@@ -229,6 +229,30 @@ module G_graph = struct
map
:
G_node
.
t
Gid_map
.
t
;
(* node description *)
}
(* -------------------------------------------------------------------------------- *)
let
rename
mapping
graph
=
{
graph
with
map
=
Gid_map
.
fold
(
fun
id
node
acc
->
let
new_id
=
try
List
.
assoc
id
mapping
with
Not_found
->
id
in
let
new_node
=
G_node
.
rename
mapping
node
in
Gid_map
.
add
new_id
new_node
acc
)
graph
.
map
Gid_map
.
empty
}
(* -------------------------------------------------------------------------------- *)
(* [normalize g] changes all graphs keys to Old _ (used when entering a new module) *)
let
normalize
t
=
let
(
_
,
mapping
)
=
Gid_map
.
fold
(
fun
key
value
(
max_binding
,
mapping
)
->
match
key
with
|
Gid
.
Old
n
->
(
n
,
mapping
)
|
Gid
.
New
_
->
(
max_binding
,
mapping
)
|
Gid
.
Act
(
n
,
suffix
)
->
(
max_binding
+
1
,
(
key
,
(
Gid
.
Old
(
max_binding
+
1
)))
::
mapping
)
)
t
.
map
(
0
,
[]
)
in
rename
mapping
t
let
empty
=
{
meta
=
[]
;
map
=
Gid_map
.
empty
}
let
find
node_id
graph
=
Gid_map
.
find
node_id
graph
.
map
...
...
@@ -416,17 +440,6 @@ module G_graph = struct
(* Update functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* -------------------------------------------------------------------------------- *)
let
rename
mapping
graph
=
{
graph
with
map
=
Gid_map
.
fold
(
fun
id
node
acc
->
let
new_id
=
try
List
.
assoc
id
mapping
with
Not_found
->
id
in
let
new_node
=
G_node
.
rename
mapping
node
in
Gid_map
.
add
new_id
new_node
acc
)
graph
.
map
Gid_map
.
empty
}
(* -------------------------------------------------------------------------------- *)
let
del_edge
?
edge_ident
loc
graph
id_src
label
id_tar
=
let
node_src
=
...
...
@@ -450,13 +463,13 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let
activate
loc
node_id
new_name
graph
=
let
activate
loc
node_id
suffix
graph
=
let
index
=
match
node_id
with
|
Gid
.
Old
id
->
Gid
.
Act
(
id
,
new_name
)
|
Gid
.
Old
id
->
Gid
.
Act
(
id
,
suffix
)
|
_
->
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
;
then
Error
.
run
~
loc
"[Graph.activate] try to activate twice the
\"
same
\"
node (with
suffix '%s')"
suffix
;
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
...
...
@@ -470,7 +483,7 @@ module G_graph = struct
|
Some
label_int
->
Gid
.
New
(
id
,
label_int
)
|
None
->
Error
.
run
~
loc
"[Graph.add_neighbour] try to add neighbour with a local label"
)
|
Gid
.
New
_
->
Error
.
run
~
loc
"[Graph.add_neighbour] try to add neighbour node to a neighbour node"
in
|
Gid
.
New
_
|
Gid
.
Act
_
->
Error
.
run
~
loc
"[Graph.add_neighbour] try to add neighbour node to a neighbour node"
in
if
Gid_map
.
mem
index
graph
.
map
then
Error
.
run
~
loc
"[Graph.add_neighbour] try to build twice the
\"
same
\"
neighbour node (with label '%s')"
(
Label
.
to_string
label
);
...
...
src/grew_graph.mli
View file @
e90891d7
...
...
@@ -95,6 +95,8 @@ module G_graph: sig
val
fold_gid
:
(
Gid
.
t
->
'
a
->
'
a
)
->
t
->
'
a
->
'
a
val
normalize
:
t
->
t
(** raise ??? *)
val
max_binding
:
t
->
int
...
...
src/grew_grs.ml
View file @
e90891d7
...
...
@@ -136,6 +136,7 @@ module Modul = struct
type
t
=
{
name
:
string
;
local_labels
:
(
string
*
string
list
)
array
;
suffixes
:
string
list
;
rules
:
Rule
.
t
list
;
filters
:
Rule
.
t
list
;
confluent
:
bool
;
...
...
@@ -154,14 +155,16 @@ module Modul = struct
let
build
ast_module
=
let
locals
=
Array
.
of_list
ast_module
.
Ast
.
local_labels
in
Array
.
sort
compare
locals
;
let
rules_or_filters
=
List
.
map
(
Rule
.
build
~
locals
ast_module
.
Ast
.
mod_dir
)
ast_module
.
Ast
.
rules
in
let
suffixes
=
ast_module
.
Ast
.
suffixes
in
let
rules_or_filters
=
List
.
map
(
Rule
.
build
~
locals
suffixes
ast_module
.
Ast
.
mod_dir
)
ast_module
.
Ast
.
rules
in
let
(
filters
,
rules
)
=
List
.
partition
Rule
.
is_filter
rules_or_filters
in
let
modul
=
{
name
=
ast_module
.
Ast
.
module_id
;
local_labels
=
locals
;
rules
=
rules
;
filters
=
filters
;
suffixes
;
rules
;
filters
;
confluent
=
ast_module
.
Ast
.
confluent
;
loc
=
ast_module
.
Ast
.
mod_loc
;
}
in
...
...
@@ -260,7 +263,9 @@ module Grs = struct
Timeout
.
start
()
;
let
modules_to_apply
=
modules_of_sequence
grs
sequence
in
let
rec
loop
instance
=
function
let
rec
loop
instance
module_list
=
let
instance
=
{
instance
with
Instance
.
graph
=
G_graph
.
normalize
instance
.
Instance
.
graph
}
in
match
module_list
with
|
[]
->
(* no more modules to apply *)
{
Rewrite_history
.
instance
=
instance
;
module_name
=
""
;
good_nf
=
[]
;
bad_nf
=
[]
;
}
|
next
::
tail
->
...
...
@@ -284,7 +289,9 @@ module Grs = struct
let
build_rew_display
grs
sequence
instance
=
let
modules_to_apply
=
modules_of_sequence
grs
sequence
in
let
rec
loop
instance
=
function
let
rec
loop
instance
module_list
=
let
instance
=
{
instance
with
Instance
.
graph
=
G_graph
.
normalize
instance
.
Instance
.
graph
}
in
match
module_list
with
|
[]
->
Grew_types
.
Leaf
instance
.
Instance
.
graph
|
next
::
tail
->
let
(
good_set
,
bad_set
)
=
...
...
src/grew_grs.mli
View file @
e90891d7
...
...
@@ -13,10 +13,11 @@ open Grew_graph
open
Grew_rule
open
Grew_ast
(* ==================================================================================================== *)
module
Rewrite_history
:
sig
type
t
=
{
instance
:
Instance
.
t
;
module_name
:
string
;
module_name
:
string
;
good_nf
:
t
list
;
bad_nf
:
Instance
.
t
list
;
}
...
...
@@ -24,17 +25,17 @@ module Rewrite_history: sig
val
is_empty
:
t
->
bool
val
num_sol
:
t
->
int
(** [save_nfs ?main_feat base_name t] does two things:
- write PNG files of normal forms
- returns a list of couples (rules, file)
*)
val
save_nfs
:
?
filter
:
string
list
->
?
main_feat
:
string
->
?
filter
:
string
list
->
?
main_feat
:
string
->
dot
:
bool
->
string
->
t
->
string
->
t
->
((
string
*
string
list
)
list
*
string
)
list
(** [save_annot out_dir base_name t] writes a set of svg_file for an annotation folder. *)
...
...
@@ -55,10 +56,12 @@ module Rewrite_history: sig
val
conll_dep_string
:
?
keep_empty_rh
:
bool
->
t
->
string
option
end
(* ==================================================================================================== *)
module
Modul
:
sig
type
t
=
{
name
:
string
;
local_labels
:
(
string
*
string
list
)
array
;
suffixes
:
string
list
;
rules
:
Rule
.
t
list
;
filters
:
Rule
.
t
list
;
confluent
:
bool
;
...
...
@@ -66,13 +69,12 @@ module Modul: sig
}
end
(* ==================================================================================================== *)
module
Grs
:
sig
type
t
val
empty
:
t
val
get_modules
:
t
->
Modul
.
t
list
val
get_ast
:
t
->
Ast
.
grs
...
...
src/grew_rule.ml
View file @
e90891d7
...
...
@@ -259,7 +259,7 @@ module Rule = struct
Buffer
.
contents
buff
(* ====================================================================== *)
let
build_commands
?
param
?
(
locals
=
[
||
])
pos
pos_table
ast_commands
=
let
build_commands
?
param
?
(
locals
=
[
||
])
suffixes
pos
pos_table
ast_commands
=
let
known_act_ids
=
List
.
map
(
fun
x
->
(
x
,
None
))
(
Array
.
to_list
pos_table
)
in
let
known_edge_ids
=
get_edge_ids
pos
in
...
...
@@ -272,6 +272,7 @@ module Rule = struct
(
kai
,
kei
)
pos_table
locals
suffixes
ast_command
in
command
::
(
loop
(
new_kai
,
new_kei
)
tail
)
in
loop
(
known_act_ids
,
known_edge_ids
)
ast_commands
...
...
@@ -290,7 +291,7 @@ module Rule = struct
parse_pat_vars
vars
(* ====================================================================== *)
let
build
?
(
locals
=
[
||
])
dir
rule_ast
=
let
build
?
(
locals
=
[
||
])
suffixes
dir
rule_ast
=
let
(
param
,
pat_vars
,
cmd_vars
)
=
match
rule_ast
.
Ast
.
param
with
...
...
@@ -317,7 +318,7 @@ module Rule = struct
name
=
rule_ast
.
Ast
.
rule_id
;
pos
=
pos
;
neg
=
List
.
map
(
fun
pattern_ast
->
build_neg_pattern
~
locals
pos_table
pattern_ast
)
rule_ast
.
Ast
.
neg_patterns
;
commands
=
build_commands
~
param
:
(
pat_vars
,
cmd_vars
)
~
locals
pos
pos_table
rule_ast
.
Ast
.
commands
;
commands
=
build_commands
~
param
:
(
pat_vars
,
cmd_vars
)
~
locals
suffixes
pos
pos_table
rule_ast
.
Ast
.
commands
;
loc
=
rule_ast
.
Ast
.
rule_loc
;
param
=
param
;
param_names
=
(
pat_vars
,
cmd_vars
)
...
...
@@ -696,6 +697,7 @@ module Rule = struct
}
,
(
created_nodes
,
((
pid
,
new_name
)
,
new_gid
)
::
activated_nodes
)
)
|
Command
.
ACT_NODE
_
->
Error
.
bug
"Try to activate a node without suffix"
(
Loc
.
to_string
loc
)
|
Command
.
SHIFT_IN
(
src_cn
,
tar_cn
)
->
let
src_gid
=
node_find
src_cn
in
...
...
src/grew_rule.mli
View file @
e90891d7
...
...
@@ -74,7 +74,7 @@ module Rule : sig
(** [build ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
[dir] is used for localisation of lp files *)
val
build
:
?
locals
:
Label
.
decl
array
->
string
->
Ast
.
rule
->
t
val
build
:
?
locals
:
Label
.
decl
array
->
string
list
->
string
->
Ast
.
rule
->
t
(** [normalize module_name ?confluent rule_list filter_list instance] returns two sets of good normal forms and bad normal forms *)
(* raise Stop if some command fails to apply *)
...
...
src/libgrew_utils.ml
View file @
e90891d7
...
...
@@ -522,7 +522,7 @@ module Massoc_make (Ord: OrderedType) = struct
|
[
one
]
when
one
=
value
->
M
.
remove
key
t
|
old
->
M
.
add
key
(
List_
.
usort_remove
value
old
)
t
let
rec
remove_key
key
t
=
M
.
remove
key
t
let
remove_key
key
t
=
M
.
remove
key
t
let
rec
mem
key
value
t
=
try
List_
.
sort_mem
value
(
M
.
find
key
t
)
...
...
src/parser/gr_grs_parser.mly
View file @
e90891d7
...
...
@@ -62,7 +62,7 @@ let localize t = (t,get_loc ())
%
token
FEATURE
/*
feature
*/
%
token
FILE
/*
file
*/
%
token
LABELS
/*
labels
*/
%
token
NEW_NOD
ES
/*
new_nod
es
*/
%
token
SUFFIX
ES
/*
suffix
es
*/
%
token
ACTIVATE
/*
activate
*/
%
token
MATCH
/*
match
*/
%
token
WITHOUT
/*
without
*/
...
...
@@ -249,11 +249,11 @@ modules:
|
x
=
list
(
grew_module
)
{
x
}
grew_module
:
|
doc
=
option
(
COMMENT
)
MODULE
conf
=
boption
(
CONFLUENT
)
id_loc
=
simple_id_with_loc
LACC
l
=
option
(
labels
)
nn
=
option
(
new_nod
es
)
r
=
rules
RACC
|
doc
=
option
(
COMMENT
)
MODULE
conf
=
boption
(
CONFLUENT
)
id_loc
=
simple_id_with_loc
LACC
l
=
option
(
labels
)
suff
=
option
(
suffix
es
)
r
=
rules
RACC
{
{
Ast
.
module_id
=
fst
id_loc
;
local_labels
=
(
match
l
with
None
->
[]
|
Some
x
->
x
);
new_node_nam
es
=
(
match
nn
with
None
->
[]
|
Some
x
->
x
);
suffix
es
=
(
match
suff
with
None
->
[]
|
Some
x
->
x
);
rules
=
r
;
confluent
=
conf
;
module_doc
=
(
match
doc
with
Some
d
->
d
|
None
->
[]
);
...
...
@@ -262,9 +262,9 @@ grew_module:
}
}
new_nod
es
:
(* "
new_nod
es {a, b, c}" *)
|
NEW_NOD
ES
x
=
delimited
(
LACC
,
separated_nonempty_list_final_opt
(
COMA
,
COMPLEX_ID
)
,
RACC
)
suffix
es
:
(* "
suffix
es {a, b, c}" *)
|
SUFFIX
ES
x
=
delimited
(
LACC
,
separated_nonempty_list_final_opt
(
COMA
,
COMPLEX_ID
)
,
RACC
)
{
List
.
map
Ast
.
simple_id_of_ci
x
}
...
...
src/parser/lexer.mll
View file @
e90891d7
...
...
@@ -105,7 +105,7 @@ and global = parse
|
"feature"
{
FEATURE
}
|
"file"
{
FILE
}
|
"labels"
{
LABELS
}
|
"
new_nod
es"
{
NEW_NOD
ES
}
|
"
suffix
es"
{
SUFFIX
ES
}
|
"match"
{
MATCH
}
|
"without"
{
WITHOUT
}
|
"commands"
{
COMMANDS
}
...
...
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