Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
L
libcaml-grew
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
3
Issues
3
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
grew
libcaml-grew
Commits
151b8cb5
Commit
151b8cb5
authored
May 23, 2017
by
Bruno Guillaume
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
change shifts semantics: only edges outside the pattern are concerned by shifts
parent
6fe5403e
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
26 additions
and
39 deletions
+26
-39
src/grew_graph.ml
src/grew_graph.ml
+14
-31
src/grew_graph.mli
src/grew_graph.mli
+4
-4
src/grew_rule.ml
src/grew_rule.ml
+8
-4
No files found.
src/grew_graph.ml
View file @
151b8cb5
...
...
@@ -583,30 +583,21 @@ 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
?
domain
src_gid
tar_gid
label_cst
graph
=
let
shift_out
loc
?
domain
src_gid
tar_gid
is_gid_local
label_cst
graph
=
let
src_node
=
Gid_map
.
find
src_gid
graph
.
map
in
let
tar_node
=
Gid_map
.
find
tar_gid
graph
.
map
in
let
src_next
=
G_node
.
get_next
src_node
in
let
tar_next
=
G_node
.
get_next
tar_node
in
(* Error if a loop is created by the shift_out *)
let
src_tar_edges
=
Massoc_gid
.
assoc
tar_gid
src_next
in
let
_
=
try
let
loop_edge
=
List
.
find
(
fun
edge
->
Label_cst
.
match_
?
domain
label_cst
edge
)
src_tar_edges
in
Error
.
run
~
loc
"The shfit_out command tries to build a loop (with label %s)"
(
Label
.
to_string
?
domain
loop_edge
)
with
Not_found
->
()
in
let
(
new_src_next
,
new_tar_next
)
=
let
(
new_src_next
,
new_tar_next
)
=
Massoc_gid
.
fold
(
fun
(
acc_src_next
,
acc_tar_next
)
next_gid
edge
->
if
Label_cst
.
match_
?
domain
label_cst
edge
if
Label_cst
.
match_
?
domain
label_cst
edge
&&
not
(
is_gid_local
next_gid
)
then
match
Massoc_gid
.
add
next_gid
edge
acc_tar_next
with
|
Some
new_acc_tar_next
->
(
Massoc_gid
.
remove
next_gid
edge
acc_src_next
,
new_acc_tar_next
)
|
None
->
Error
.
run
~
loc
"The [shift_out] command tries to build a duplicate edge (with label
\"
%s
\"
)"
(
Label
.
to_string
?
domain
edge
)
else
(
acc_src_next
,
acc_tar_next
)
)
(
src_next
,
tar_next
)
src_next
in
...
...
@@ -618,21 +609,13 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let
shift_in
loc
?
domain
src_gid
tar_gid
label_cst
graph
=
let
tar_node
=
Gid_map
.
find
tar_gid
graph
.
map
in
let
tar_next
=
G_node
.
get_next
tar_node
in
(* Error if a loop is created by the shift_in *)
let
tar_src_edges
=
Massoc_gid
.
assoc
src_gid
tar_next
in
let
_
=
try
let
loop_edge
=
List
.
find
(
fun
edge
->
Label_cst
.
match_
?
domain
label_cst
edge
)
tar_src_edges
in
Error
.
run
~
loc
"The [shift_in] command tries to build a loop (with label
\"
%s
\"
)"
(
Label
.
to_string
?
domain
loop_edge
)
with
Not_found
->
()
in
let
shift_in
loc
?
domain
src_gid
tar_gid
is_gid_local
label_cst
graph
=
{
graph
with
map
=
Gid_map
.
mapi
(
fun
node_id
node
->
Gid_map
.
mapi
(
fun
node_id
node
->
if
is_gid_local
node_id
then
node
else
let
node_next
=
G_node
.
get_next
node
in
match
Massoc_gid
.
assoc
src_gid
node_next
with
|
[]
->
node
(* no edges from node to src *)
...
...
@@ -658,14 +641,14 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let
shift_edges
loc
?
domain
src_gid
tar_gid
label_cst
graph
=
let
shift_edges
loc
?
domain
src_gid
tar_gid
is_gid_local
label_cst
graph
=
graph
|>
(
shift_in
loc
?
domain
src_gid
tar_gid
label_cst
)
|>
(
shift_out
loc
?
domain
src_gid
tar_gid
label_cst
)
|>
(
shift_in
loc
?
domain
src_gid
tar_gid
is_gid_local
label_cst
)
|>
(
shift_out
loc
?
domain
src_gid
tar_gid
is_gid_local
label_cst
)
(* -------------------------------------------------------------------------------- *)
let
merge_node
loc
?
domain
graph
src_gid
tar_gid
=
let
se_graph
=
shift_edges
loc
?
domain
src_gid
tar_gid
Label_cst
.
all
graph
in
let
merge_node
loc
?
domain
graph
is_gid_local
src_gid
tar_gid
=
let
se_graph
=
shift_edges
loc
?
domain
src_gid
tar_gid
is_gid_local
Label_cst
.
all
graph
in
let
src_node
=
Gid_map
.
find
src_gid
se_graph
.
map
in
let
tar_node
=
Gid_map
.
find
tar_gid
se_graph
.
map
in
...
...
src/grew_graph.mli
View file @
151b8cb5
...
...
@@ -144,16 +144,16 @@ module G_graph: sig
val
add_before
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
t
->
(
Gid
.
t
*
t
)
val
add_after
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
t
->
(
Gid
.
t
*
t
)
val
merge_node
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
t
->
Gid
.
t
->
Gid
.
t
->
t
option
val
merge_node
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
t
->
(
Gid
.
t
->
bool
)
->
Gid
.
t
->
Gid
.
t
->
t
option
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
val
shift_in
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
Gid
.
t
->
Label_cst
.
t
->
t
->
t
val
shift_in
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
Gid
.
t
->
(
Gid
.
t
->
bool
)
->
Label_cst
.
t
->
t
->
t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val
shift_out
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
Gid
.
t
->
Label_cst
.
t
->
t
->
t
val
shift_out
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
Gid
.
t
->
(
Gid
.
t
->
bool
)
->
Label_cst
.
t
->
t
->
t
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val
shift_edges
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
Gid
.
t
->
Label_cst
.
t
->
t
->
t
val
shift_edges
:
Loc
.
t
->
?
domain
:
Domain
.
t
->
Gid
.
t
->
Gid
.
t
->
(
Gid
.
t
->
bool
)
->
Label_cst
.
t
->
t
->
t
(** [update_feat domain tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
...
...
src/grew_rule.ml
View file @
151b8cb5
...
...
@@ -885,6 +885,10 @@ module Rule = struct
(* the exception below is added to handle unification failure in merge!! *)
exception
Command_execution_fail
(* [in_img node_gid n_match] checks if [node_gid] belongs to the codomain of [n_match] *)
let
test_locality
matching
created_nodes
gid
=
(
Pid_map
.
exists
(
fun
_
id
->
id
=
gid
)
matching
.
n_match
)
||
(
List
.
exists
(
fun
(
_
,
id
)
->
id
=
gid
)
created_nodes
)
(* ---------------------------------------------------------------------- *)
(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
let
apply_command
?
domain
(
command
,
loc
)
instance
matching
created_nodes
=
...
...
@@ -965,7 +969,7 @@ module Rule = struct
|
Command
.
MERGE_NODE
(
src_cn
,
tar_cn
)
->
let
src_gid
=
node_find
src_cn
in
let
tar_gid
=
node_find
tar_cn
in
(
match
G_graph
.
merge_node
loc
?
domain
instance
.
Instance
.
graph
src_gid
tar_gid
with
(
match
G_graph
.
merge_node
loc
?
domain
instance
.
Instance
.
graph
(
test_locality
matching
created_nodes
)
src_gid
tar_gid
with
|
Some
new_graph
->
(
{
instance
with
...
...
@@ -1051,7 +1055,7 @@ module Rule = struct
let
tar_gid
=
node_find
tar_cn
in
(
{
instance
with
Instance
.
graph
=
G_graph
.
shift_in
loc
?
domain
src_gid
tar_gid
label_cst
instance
.
Instance
.
graph
;
Instance
.
graph
=
G_graph
.
shift_in
loc
?
domain
src_gid
tar_gid
(
test_locality
matching
created_nodes
)
label_cst
instance
.
Instance
.
graph
;
history
=
List_
.
sort_insert
(
Command
.
H_SHIFT_IN
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
...
...
@@ -1062,7 +1066,7 @@ module Rule = struct
let
tar_gid
=
node_find
tar_cn
in
(
{
instance
with
Instance
.
graph
=
G_graph
.
shift_out
loc
?
domain
src_gid
tar_gid
label_cst
instance
.
Instance
.
graph
;
Instance
.
graph
=
G_graph
.
shift_out
loc
?
domain
src_gid
tar_gid
(
test_locality
matching
created_nodes
)
label_cst
instance
.
Instance
.
graph
;
history
=
List_
.
sort_insert
(
Command
.
H_SHIFT_OUT
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
...
...
@@ -1073,7 +1077,7 @@ module Rule = struct
let
tar_gid
=
node_find
tar_cn
in
(
{
instance
with
Instance
.
graph
=
G_graph
.
shift_edges
loc
?
domain
src_gid
tar_gid
label_cst
instance
.
Instance
.
graph
;
Instance
.
graph
=
G_graph
.
shift_edges
loc
?
domain
src_gid
tar_gid
(
test_locality
matching
created_nodes
)
label_cst
instance
.
Instance
.
graph
;
history
=
List_
.
sort_insert
(
Command
.
H_SHIFT_EDGE
(
src_gid
,
tar_gid
))
instance
.
Instance
.
history
}
,
created_nodes
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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