Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
verimag
synchrone
sasa
Commits
40eece7c
Commit
40eece7c
authored
Apr 08, 2021
by
erwan
Browse files
Chore: code refactoring
parent
a872f728
Changes
1
Hide whitespace changes
Inline
Side-by-side
lib/sasacore/register.ml
View file @
40eece7c
(* Time-stamp: <modified the
13/10
/202
0
(at 1
5:37
) by Erwan Jahier> *)
(* Time-stamp: <modified the
07/04
/202
1
(at 1
0:16
) by Erwan Jahier> *)
type
'
s
neighbor
=
{
state
:
'
s
;
...
...
@@ -30,29 +30,22 @@ type 's internal_tables = {
mutable
legitimate
:
Obj
.
t
;
mutable
fault
:
Obj
.
t
;
mutable
actions
:
action
list
;
mutable
card
:
int
;
mutable
min_deg
:
int
;
mutable
mean_deg
:
float
;
mutable
max_deg
:
int
;
mutable
topology
:
Topology
.
t
option
;
mutable
card
:
int
option
;
mutable
min_deg
:
int
option
;
mutable
mean_deg
:
float
option
;
mutable
max_deg
:
int
option
;
mutable
is_cyclic
:
bool
option
;
mutable
is_connected
:
bool
option
;
mutable
is_tree
:
bool
option
;
mutable
is_directed
:
bool
option
;
mutable
height
:
(
string
->
int
);
mutable
links_number
:
int
;
mutable
diameter
:
int
;
mutable
height
:
(
string
->
int
)
option
;
mutable
sub_tree_size
:
(
string
->
int
)
option
;
mutable
parent
:
(
string
->
int
option
)
option
;
mutable
links_number
:
int
option
;
mutable
diameter
:
int
option
;
}
type
properties_functions
=
{
mutable
card
:
unit
->
int
;
mutable
min_max
:
unit
->
int
*
int
;
mutable
mean_deg
:
unit
->
float
;
mutable
is_connected_cyclic
:
unit
->
bool
*
bool
;
mutable
is_directed
:
unit
->
bool
;
mutable
links_number
:
unit
->
int
;
mutable
diameter
:
unit
->
int
}
type
node_id
=
string
(* cf topology.mli *)
let
(
tbls
:
'
s
internal_tables
)
=
{
...
...
@@ -67,27 +60,20 @@ let (tbls:'s internal_tables) = {
legitimate
=
(
Obj
.
repr
None
);
fault
=
(
Obj
.
repr
None
);
actions
=
[]
;
card
=
(
-
1
);
min_deg
=
(
-
1
);
mean_deg
=
(
-
1
.
);
max_deg
=
(
-
1
);
topology
=
None
;
card
=
None
;
min_deg
=
None
;
mean_deg
=
None
;
max_deg
=
None
;
is_cyclic
=
None
;
is_connected
=
None
;
is_tree
=
None
;
is_directed
=
None
;
height
=
(
fun
_
->
-
1
);
links_number
=
(
-
1
);
diameter
=
(
-
1
)
}
let
(
prop_funs
:
properties_functions
)
=
{
card
=
(
fun
()
->
-
1
);
min_max
=
(
fun
()
->
(
-
1
,-
1
));
mean_deg
=
(
fun
()
->
-
1
.
);
is_connected_cyclic
=
(
fun
()
->
(
false
,
false
));
is_directed
=
(
fun
()
->
false
);
links_number
=
(
fun
()
->
-
1
);
diameter
=
(
fun
()
->
-
1
)
height
=
None
;
parent
=
None
;
sub_tree_size
=
None
;
links_number
=
None
;
diameter
=
None
}
let
verbose_level
=
ref
0
...
...
@@ -96,14 +82,13 @@ exception Unregistred of string * string
let
print_table
lbl
tbl
=
let
keys
=
Hashtbl
.
fold
(
fun
k
_
acc
->
Printf
.
sprintf
"%s,%s"
k
acc
)
tbl
""
in
if
!
verbose_level
>
0
then
Printf
.
eprintf
"Defined keys for %s: %s
\n
%!"
lbl
keys
let
(
reg_init_state
:
algo_id
->
(
int
->
string
->
'
s
)
->
unit
)
=
fun
algo_id
x
->
if
!
verbose_level
>
0
then
Printf
.
eprintf
"Registering %s init_vars
\n
%!"
algo_id
;
Hashtbl
.
replace
tbls
.
init_state
algo_id
(
Obj
.
repr
x
)
if
!
verbose_level
>
0
then
Printf
.
eprintf
"Registering %s init_vars
\n
%!"
algo_id
;
Hashtbl
.
replace
tbls
.
init_state
algo_id
(
Obj
.
repr
x
)
let
(
get_init_state
:
algo_id
->
int
->
string
->
'
s
)
=
fun
algo_id
->
try
Obj
.
obj
(
Hashtbl
.
find
tbls
.
init_state
algo_id
)
...
...
@@ -111,7 +96,6 @@ let (get_init_state : algo_id -> int -> string -> 's) =
print_table
"init_state"
tbls
.
init_state
;
raise
(
Unregistred
(
"init_state"
,
algo_id
))
let
(
reg_enable
:
algo_id
->
'
s
enable_fun
->
unit
)
=
fun
algo_id
x
->
if
!
verbose_level
>
0
then
Printf
.
eprintf
"Registering %s enable
\n
%!"
algo_id
;
Hashtbl
.
replace
tbls
.
enable
algo_id
(
Obj
.
repr
x
)
...
...
@@ -177,7 +161,6 @@ let (get_value_of_string : unit -> (string -> 's) option) = fun () ->
try
Some
(
Obj
.
obj
(
Hashtbl
.
find
tbls
.
value_of_string
"_global"
))
with
Not_found
->
None
let
(
reg_copy_value
:
(
'
s
->
'
s
)
->
unit
)
=
fun
f
->
if
!
verbose_level
>
0
then
Printf
.
eprintf
"Registering copy_value
\n
%!"
;
...
...
@@ -190,70 +173,71 @@ let (get_copy_value : unit -> ('s -> 's)) = fun () ->
raise
(
Unregistred
(
"copy_value"
,
"_global"
))
let
set_min_max
:
(
unit
->
unit
)
=
fun
()
->
let
(
x
,
y
)
=
prop_funs
.
min_max
()
in
tbls
.
min_deg
<-
x
;
tbls
.
max_deg
<-
y
let
set_connec_cycl
:
(
unit
->
unit
)
=
fun
()
->
let
(
x
,
y
)
=
prop_funs
.
is_connected_cyclic
()
in
tbls
.
is_connected
<-
Some
x
;
tbls
.
is_cyclic
<-
Some
y
let
set_topology
g
=
tbls
.
topology
<-
Some
g
let
get_topology
()
=
match
tbls
.
topology
with
|
None
->
assert
false
(* SNO if set_topology is called in Main *)
|
Some
g
->
g
let
(
card
:
unit
->
int
)
=
fun
()
->
match
tbls
.
card
with
|
-
1
->
let
c
=
prop_funs
.
card
()
in
tbls
.
card
<-
c
;
c
|
c
->
c
|
None
->
let
x
=
List
.
length
(
get_topology
()
)
.
nodes
in
tbls
.
card
<-
Some
x
;
x
|
Some
b
->
b
let
(
is_directed
:
unit
->
bool
)
=
fun
()
->
match
tbls
.
is_directed
with
|
None
->
let
c
=
prop_funs
.
is_directed
()
in
tbls
.
is_directed
<-
Some
c
;
c
|
Some
c
->
c
let
(
min_degree
:
unit
->
int
)
=
fun
()
->
match
tbls
.
min_deg
with
|
-
1
->
(
set_min_max
()
;
tbls
.
min_deg
)
|
m
->
m
let
x
=
(
get_topology
()
)
.
directed
in
tbls
.
is_directed
<-
Some
x
;
x
|
Some
b
->
b
let
(
mean_degree
:
unit
->
float
)
=
fun
()
->
match
tbls
.
mean_deg
with
|
-
1
.
->
let
m
=
prop_funs
.
mean_deg
(
)
in
tbls
.
mean_deg
<-
m
;
m
|
m
->
m
|
None
->
let
x
=
Topology
.
get_mean_degree
(
get_topology
()
)
in
tbls
.
mean_deg
<-
Some
x
;
x
|
Some
b
->
b
let
(
max_degree
:
unit
->
int
)
=
fun
()
->
match
tbls
.
max_deg
with
|
-
1
->
(
set_min_max
()
;
tbls
.
max_deg
)
|
m
->
m
let
(
min_degree
:
unit
->
int
)
=
fun
()
->
match
tbls
.
min_deg
with
|
None
->
let
mind
,
maxd
=
Topology
.
get_degree
(
get_topology
()
)
in
tbls
.
max_deg
<-
Some
maxd
;
tbls
.
min_deg
<-
Some
mind
;
mind
|
Some
b
->
b
let
(
max_degree
:
unit
->
int
)
=
fun
()
->
match
tbls
.
max_deg
with
|
None
->
let
mind
,
maxd
=
Topology
.
get_degree
(
get_topology
()
)
in
tbls
.
max_deg
<-
Some
maxd
;
tbls
.
min_deg
<-
Some
mind
;
maxd
|
Some
b
->
b
let
(
is_cyclic
:
unit
->
bool
)
=
fun
()
->
match
tbls
.
is_cyclic
with
|
None
->
set_connec_cycl
()
;
(
match
tbls
.
is_c
yclic
with
|
Some
b
->
b
|
_
->
assert
false
)
let
connect
,
cyclic
=
Topology
.
is_connected_and_cyclic
(
get_topology
()
)
in
tbls
.
is_c
onnected
<-
Some
connect
;
tbls
.
is_cyclic
<-
Some
cyclic
;
cyclic
|
Some
b
->
b
let
(
is_connected
:
unit
->
bool
)
=
fun
()
->
match
tbls
.
is_connected
with
|
None
->
(
set_connec_cycl
()
;
match
tbls
.
is_connected
with
|
Some
b
->
b
|
_
->
assert
false
)
|
None
->
let
connect
,
cyclic
=
Topology
.
is_connected_and_cyclic
(
get_topology
()
)
in
tbls
.
is_connected
<-
Some
connect
;
tbls
.
is_cyclic
<-
Some
cyclic
;
connect
|
Some
b
->
b
let
(
is_tree
:
unit
->
bool
)
=
fun
()
->
match
tbls
.
is_tree
with
|
None
->
...
...
@@ -262,60 +246,60 @@ let (is_tree : unit -> bool) = fun () ->
b
|
Some
b
->
b
(* Caution : this option is not the same as the option in the type tbls.height.
* If height () = None, then the graph doesn't have a height (because it isn't a tree)*)
let
height
:
(
unit
->
(
string
->
int
)
option
)
=
exception
Not_a_tree
let
height
:
(
unit
->
string
->
int
)
=
fun
()
->
if
is_tree
()
then
Some
tbls
.
height
else
None
if
is_tree
()
then
(
match
tbls
.
height
with
|
Some
h
->
h
|
None
->
let
h
=
Topology
.
get_height
(
get_topology
()
)
in
tbls
.
height
<-
Some
h
;
h
)
else
raise
Not_a_tree
let
sub_tree_size
:
(
unit
->
string
->
int
)
=
fun
()
->
if
is_tree
()
then
(
match
tbls
.
sub_tree_size
with
|
Some
s
->
s
|
None
->
let
s
=
Topology
.
get_sub_tree_size
(
get_topology
()
)
in
tbls
.
sub_tree_size
<-
Some
s
;
s
)
else
raise
Not_a_tree
let
parent
:
(
unit
->
string
->
int
option
)
=
fun
()
->
if
is_tree
()
then
(
match
tbls
.
parent
with
|
Some
p
->
p
|
None
->
let
p
=
Topology
.
get_parent
(
get_topology
()
)
in
tbls
.
parent
<-
Some
p
;
p
)
else
raise
Not_a_tree
let
(
links_number
:
unit
->
int
)
=
fun
()
->
match
tbls
.
links_number
with
|
-
1
->
let
n
=
prop_funs
.
links_number
()
in
tbls
.
links_number
<-
n
;
n
|
n
->
n
match
tbls
.
links_number
with
|
Some
x
->
x
|
None
->
let
x
=
Topology
.
get_nb_link
(
get_topology
()
)
in
tbls
.
links_number
<-
Some
x
;
x
let
(
diameter
:
unit
->
int
)
=
fun
()
->
match
tbls
.
diameter
with
|
-
1
->
let
d
=
(
prop_funs
.
diameter
()
)
in
tbls
.
diameter
<-
d
;
d
|
d
->
d
let
set_card
:
((
unit
->
int
)
->
unit
)
=
fun
f
->
prop_funs
.
card
<-
f
let
set_is_directed
:
((
unit
->
bool
)
->
unit
)
=
fun
f
->
prop_funs
.
is_directed
<-
f
let
set_degrees
:
((
unit
->
int
*
int
)
->
unit
)
=
fun
f
->
prop_funs
.
min_max
<-
f
let
set_mean_deg
:
((
unit
->
float
)
->
unit
)
=
fun
f
->
prop_funs
.
mean_deg
<-
f
let
set_is_connected_cyclic
:
((
unit
->
bool
*
bool
)
->
unit
)
=
fun
f
->
prop_funs
.
is_connected_cyclic
<-
f
let
set_height
:
((
node_id
->
int
)
->
unit
)
=
fun
f
->
tbls
.
height
<-
f
let
set_links_number
:
((
unit
->
int
)
->
unit
)
=
fun
f
->
prop_funs
.
links_number
<-
f
let
set_diameter
:
((
unit
->
int
)
->
unit
)
=
fun
f
->
prop_funs
.
diameter
<-
f
|
Some
x
->
x
|
None
->
let
x
=
Topology
.
get_nb_link
(
get_topology
()
)
in
tbls
.
diameter
<-
Some
x
;
x
let
(
to_string
:
'
s
->
string
)
=
fun
v
->
(
get_value_to_string
()
)
v
...
...
erwan
@jahier
mentioned in commit
cbab6231
·
Apr 21, 2021
mentioned in commit
cbab6231
mentioned in commit cbab62313c52d4add68490f7efbc909c21afa165
Toggle commit list
Write
Preview
Supports
Markdown
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