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
272e76b3
Commit
272e76b3
authored
May 06, 2021
by
erwan
Browse files
Merge the 2 sasa/rdbg GUI
parent
8ac1bbad
Changes
4
Hide whitespace changes
Inline
Side-by-side
tools/rdbg4sasa/daemongui.ml
View file @
272e76b3
...
...
@@ -77,25 +77,7 @@ let init_rdbg_hook () =
in
rdbg_mv_hook
:=
Some
guidaemon
(* GTK3 *)
let
main
()
=
let
_locale
=
GtkMain
.
Main
.
init
()
in
let
_thread
=
GtkThread
.
start
()
in
let
window
=
GWindow
.
window
(* ~width:320 ~height:240 *)
~
title
:
"Daemon GUI"
~
show
:
true
()
in
let
vbox
=
GPack
.
vbox
~
packing
:
window
#
add
()
~
homogeneous
:
false
in
ignore
(
window
#
connect
#
destroy
~
callback
:
(
fun
()
->
quit
()
;
(* quit rdbg, this will stop the readloop below *)
Main
.
quit
()
(* terminate gtk *)
));
(* Affichage d'informations *)
let
gtext_content
=
ref
""
in
let
custom_daemon
gtext
vbox
=
(* création du rdbg_mv_hook et de tout ce qu'il faut autour *)
init_rdbg_hook
()
;
...
...
@@ -122,9 +104,6 @@ let main () =
let
scrolled
=
GBin
.
scrolled_window
~
border_width
:
10
~
shadow_type
:
`OUT
~
height
:
150
~
packing
:
vbox
#
add
()
in
let
gtext
=
GText
.
view
~
wrap_mode
:
`CHAR
~
height
:
50
~
editable
:
false
~
width
:
50
~
packing
:
scrolled
#
add
()
~
cursor_visible
:
true
in
dk_dd
#
misc
#
set_tooltip_text
(
Printf
.
sprintf
"Set the automatic distributed mode"
);
dk_sd
#
misc
#
set_tooltip_text
(
Printf
.
sprintf
"Set the automatic synchronous mode"
);
dk_cd
#
misc
#
set_tooltip_text
(
Printf
.
sprintf
"Set the automatic central mode"
);
...
...
@@ -325,75 +304,360 @@ let main () =
ignore
(
dk_manual
#
connect
#
clicked
~
callback
:
set_manual_mode
);
ignore
(
dk_manual_central
#
connect
#
clicked
~
callback
:
set_manual_central_mode
);
(* Affichage d'informations *)
gtext
#
buffer
#
set_text
!
gtext_content
;
let
_print_gui
str
=
let
txt
=
Printf
.
sprintf
"%s
\n
%s"
str
(
str_of_sasa_event
true
!
e
)
in
gtext
#
buffer
#
set_text
txt
;
gtext_content
:=
txt
;
in
(* Boutons de contrôle de la simulation *)
let
hbox
=
GPack
.
hbox
~
packing
:
vbox
#
add
()
in
let
rdbg_btn
label
tip
cmd
=
let
btn
=
GButton
.
button
~
label
:
label
~
packing
:
hbox
#
add
()
in
btn
#
misc
#
set_tooltip_text
tip
;
ignore
(
btn
#
connect
#
clicked
~
callback
:
(
fun
()
->
cmd
()
;
refresh
()
;
));
btn
in
let
rec
get_higher_prioriry
nl
=
let
prio
n
=
let
counter
=
Hashtbl
.
find
counter_map
n
in
counter
#
get
(* gtext#buffer#set_text !gtext_content; *)
let
rec
get_higher_prioriry
nl
=
let
prio
n
=
let
counter
=
Hashtbl
.
find
counter_map
n
in
counter
#
get
in
let
rec
aux
p
acc
=
function
|
[]
->
acc
|
(
n
,
false
)
::
t
->
aux
p
acc
t
|
(
n
,
true
)
::
t
->
let
pn
=
prio
n
in
if
p
>
pn
then
aux
p
acc
t
else
if
p
=
pn
then
aux
p
(
n
::
acc
)
t
else
aux
pn
[
n
]
t
in
aux
0
[]
nl
in
let
rec
aux
p
acc
=
function
|
[]
->
acc
|
(
n
,
false
)
::
t
->
aux
p
acc
t
|
(
n
,
true
)
::
t
->
let
pn
=
prio
n
in
if
p
>
pn
then
aux
p
acc
t
else
if
p
=
pn
then
aux
p
(
n
::
acc
)
t
else
aux
pn
[
n
]
t
let
step
()
=
match
!
daemon_kind
with
|
Distributed
->
gtext
#
buffer
#
set_text
"finish me"
|
Synchronous
->
(
let
nodes_enabled
=
rdbg_nodes_enabled
!
e
in
let
nodes
=
get_higher_prioriry
nodes_enabled
in
List
.
iter
(
fun
(
n
,_
)
->
if
List
.
mem
n
nodes
then
Hashtbl
.
add
daemongui_activate
n
true
else
Hashtbl
.
add
daemongui_activate
n
false
)
nodes_enabled
;
sd
()
;
gtext
#
buffer
#
set_text
(
"Synchronous step : "
^
(
String
.
concat
","
nodes
))
)
|
Central
->
gtext
#
buffer
#
set_text
"finish me"
|
LocCentral
->
gtext
#
buffer
#
set_text
"finish me"
|
ManualCentral
->
()
(* SNO *)
|
Manual
->
sd
()
in
aux
0
[]
nl
step
let
prefix
=
try
let
opam_dir
=
Unix
.
getenv
"OPAM_SWITCH_PREFIX"
in
opam_dir
with
Not_found
->
"$HOME/sasa/"
let
lib_prefix
=
prefix
^
"/lib/sasa"
let
libui_prefix
=
prefix
^
"/lib/rdbgui4sasa"
let
oc_stdin
=
stdout
let
ic_stdout
=
stdin
(* GTK3 *)
let
main
()
=
let
_locale
=
GtkMain
.
Main
.
init
()
in
let
_thread
=
GtkThread
.
start
()
in
let
window
=
GWindow
.
window
(* ~width:320 ~height:240 *)
~
title
:
"A rdbg GUI for sasa"
~
show
:
true
()
in
let
step
()
=
match
!
daemon_kind
with
|
Distributed
->
gtext
#
buffer
#
set_text
"finish me"
|
Synchronous
->
(
let
nodes_enabled
=
rdbg_nodes_enabled
!
e
in
let
nodes
=
get_higher_prioriry
nodes_enabled
in
List
.
iter
(
fun
(
n
,_
)
->
if
List
.
mem
n
nodes
then
Hashtbl
.
add
daemongui_activate
n
true
else
Hashtbl
.
add
daemongui_activate
n
false
)
nodes_enabled
;
sd
()
;
gtext
#
buffer
#
set_text
(
"Synchronous step : "
^
(
String
.
concat
","
nodes
))
)
|
Central
->
gtext
#
buffer
#
set_text
"finish me"
|
LocCentral
->
gtext
#
buffer
#
set_text
"finish me"
|
ManualCentral
->
()
(* SNO *)
|
Manual
->
sd
()
in
let
_
=
rdbg_btn
"<<"
"previous round"
pr
in
let
_
=
rdbg_btn
"<"
"previous step"
bd
in
let
_
=
rdbg_btn
"G"
"display the network"
graph_view
in
let
_
=
rdbg_btn
">"
"next step"
step
in
let
_
=
rdbg_btn
">>"
"next round"
nr
in
let
_
=
rdbg_btn
"q"
"end the session"
q
in
let
w
=
GPack
.
vbox
~
packing
:
window
#
add
()
~
homogeneous
:
false
in
let
box
=
GPack
.
vbox
~
packing
:
w
#
add
()
in
let
gbox
=
GPack
.
hbox
~
packing
:
box
#
add
()
in
let
gbox2
=
GPack
.
hbox
~
packing
:
box
#
add
()
in
let
sw1
=
GBin
.
scrolled_window
~
border_width
:
10
~
shadow_type
:
`IN
~
height
:
30
~
width
:
50
~
packing
:
box
#
add
()
in
let
sw2
=
GBin
.
scrolled_window
~
border_width
:
10
~
shadow_type
:
`OUT
~
height
:
250
~
packing
:
box
#
add
()
in
sw1
#
misc
#
set_tooltip_text
"This window displays the commands sent to the rdbg cli"
;
sw2
#
misc
#
set_tooltip_text
"This window displays commands outputs"
;
let
text_in
=
GText
.
view
~
wrap_mode
:
`CHAR
~
height
:
250
~
editable
:
true
~
width
:
50
~
packing
:
sw1
#
add
()
~
cursor_visible
:
true
in
let
text_out
=
GText
.
view
~
wrap_mode
:
`CHAR
~
height
:
250
~
editable
:
false
~
packing
:
sw2
#
add
()
~
cursor_visible
:
true
in
let
p
str
=
text_out
#
set_buffer
(
GText
.
buffer
~
text
:
str
()
);
Printf
.
fprintf
oc_stdin
"%s
\n
%!"
str
;
Printf
.
printf
"%s
\n
%!"
str
;
in
Printf
.
fprintf
oc_stdin
"#require
\"
sasa
\"
;;
\n
%!"
;
(* Printf.fprintf oc_stdin "#use \"sasa-rdbg-cmds.ml\";;\n%!"; *)
Printf
.
fprintf
oc_stdin
"print_sasa_event false !e;;
\n
%!"
;
(* print the first event *)
let
bbox
=
GPack
.
hbox
~
packing
:
box
#
add
()
in
let
change_label
button
str
=
let
icon
=
button
#
image
in
button
#
set_label
str
;
button
#
set_image
icon
in
let
button_cb
cmd
()
=
cmd
()
;
let
txt
=
Printf
.
sprintf
"%s"
(
str_of_sasa_event
false
!
e
)
in
text_out
#
buffer
#
set_text
txt
in
let
button_cb_string
cmd
()
=
let
txt
=
Printf
.
sprintf
"%s"
(
cmd
()
)
in
text_out
#
buffer
#
set_text
txt
in
let
back_step_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`GO_BACK
~
packing
:
bbox
#
add
()
in
back_step_button
#
misc
#
set_tooltip_text
"Move BACKWARD to the previous STEP"
;
change_label
back_step_button
"Ste_p"
;
ignore
(
back_step_button
#
connect
#
clicked
~
callback
:
(
button_cb
bd
));
let
step_button
=
GButton
.
button
~
use_mnemonic
:
true
~
packing
:
bbox
#
add
~
stock
:
`GO_FORWARD
()
in
step_button
#
misc
#
set_tooltip_text
"Move FORWARD to the next STEP"
;
change_label
step_button
"_Step"
;
ignore
(
step_button
#
connect
#
clicked
~
callback
:
(
button_cb
sd
));
let
back_round_button
=
GButton
.
button
~
packing
:
bbox
#
add
~
stock
:
`MEDIA_PREVIOUS
~
use_mnemonic
:
true
~
label
:
"back round"
()
in
back_round_button
#
misc
#
set_tooltip_text
"Move BACKWARD to the previous ROUND"
;
change_label
back_round_button
"Roun_d"
;
ignore
(
back_round_button
#
connect
#
clicked
~
callback
:
(
button_cb
pr
));
let
round_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`MEDIA_FORWARD
~
packing
:
bbox
#
add
~
label
:
"round"
()
in
round_button
#
misc
#
set_tooltip_text
"Move FORWARD to the next ROUND"
;
change_label
round_button
"_Round"
;
ignore
(
round_button
#
connect
#
clicked
~
callback
:
(
button_cb
nr
));
let
legitimate
()
=
let
legitimate_button
=
GButton
.
button
~
use_mnemonic
:
true
~
packing
:
bbox
#
add
()
in
legitimate_button
#
misc
#
set_tooltip_text
"Move FORWARD until a legitimate configuration is reached (silence by default)"
;
let
image
=
GMisc
.
image
~
file
:
(
libui_prefix
^
"/chut_small.svg"
)
()
in
legitimate_button
#
set_image
image
#
coerce
;
(* change_label legitimate_button "Silen_t"; *)
ignore
(
legitimate_button
#
connect
#
clicked
~
callback
:
(
button_cb
legitimate
))
in
legitimate
()
;
let
graph
()
=
let
graph_button
=
GButton
.
button
~
use_mnemonic
:
true
~
packing
:
bbox
#
add
()
in
graph_button
#
misc
#
set_tooltip_text
"Visualize the Topology states: Green=Enabled ; Gold=Active"
;
let
image
=
GMisc
.
image
~
file
:
(
libui_prefix
^
"/graph_small.png"
)
()
in
graph_button
#
set_image
image
#
coerce
;
ignore
(
graph_button
#
connect
#
clicked
~
callback
:
(
button_cb
graph_view
));
in
graph
()
;
let
viol_oracle
()
=
let
viol_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`OK
~
packing
:
bbox
#
add
()
in
viol_button
#
misc
#
set_tooltip_text
"Move FORWARD until an oracle is violated"
;
(* let image = GMisc.image ~file:"../rdbg-utils/oracle_small.jpg" () in *)
(* viol_button#set_image image#coerce; *)
change_label
viol_button
"_Oracle"
;
ignore
(
viol_button
#
connect
#
clicked
~
callback
:
(
button_cb_string
viol_string
))
in
(* if args.oracles <> [] then *)
viol_oracle
()
;
let
undo_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`UNDO
~
packing
:
bbox
#
add
~
label
:
"undo"
()
in
undo_button
#
misc
#
set_tooltip_text
"Undo the last move"
;
ignore
(
undo_button
#
connect
#
clicked
~
callback
:
(
button_cb
(
fun
()
->
u
()
;
d
()
)));
let
restart_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`REFRESH
~
packing
:
bbox
#
add
~
label
:
"restart"
()
in
restart_button
#
misc
#
set_tooltip_text
"Restart from the beginning"
;
change_label
restart_button
"Restar_t"
;
ignore
(
restart_button
#
connect
#
clicked
~
callback
:
(
button_cb
(
fun
()
->
r
()
;
d
()
)));
let
info_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`INFO
~
packing
:
bbox
#
add
~
label
:
"_Info"
()
in
change_label
info_button
"_Info"
;
info_button
#
misc
#
set_tooltip_text
"Get information about the current session"
;
ignore
(
info_button
#
connect
#
clicked
~
callback
:
(
button_cb_string
info_string
));
let
quit_button
=
GButton
.
button
~
use_mnemonic
:
true
~
stock
:
`QUIT
~
packing
:
bbox
#
add
~
label
:
"_Quit"
()
in
quit_button
#
misc
#
set_tooltip_text
"Quit RDBGUI"
;
ignore
(
quit_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
Stdlib
.
exit
0
));
let
dot_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
label
:
"dot"
()
in
let
fd_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
group
:
dot_button
#
group
~
label
:
"fdp"
()
in
let
sf_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
group
:
dot_button
#
group
~
label
:
"sfdp"
()
in
let
ne_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
active
:
true
~
group
:
dot_button
#
group
~
label
:
"neato"
()
in
let
tw_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
group
:
dot_button
#
group
~
label
:
"twopi"
()
in
let
ci_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
group
:
dot_button
#
group
~
label
:
"circo"
()
in
let
pa_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
group
:
dot_button
#
group
~
label
:
"patchwork"
()
in
let
os_button
=
GButton
.
radio_button
~
packing
:
gbox
#
add
~
group
:
dot_button
#
group
~
label
:
"osage"
()
in
let
par_dot
()
=
let
par_dot_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"dot*"
()
in
let
par_fd_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"fdp*"
()
in
let
par_sf_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"sfdp*"
()
in
let
par_ne_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"neato*"
()
in
let
par_tw_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"twopi*"
()
in
let
par_ci_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"circo*"
()
in
let
par_pa_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"patchwork*"
()
in
let
par_os_button
=
GButton
.
radio_button
~
packing
:
gbox2
#
add
~
group
:
dot_button
#
group
~
label
:
"osage*"
()
in
par_dot_button
#
misc
#
set_tooltip_text
"Use dot, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_fd_button
#
misc
#
set_tooltip_text
"Use fdp, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_sf_button
#
misc
#
set_tooltip_text
"Use sfdp, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_ne_button
#
misc
#
set_tooltip_text
"Use neato, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_tw_button
#
misc
#
set_tooltip_text
"Use twopi, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_ci_button
#
misc
#
set_tooltip_text
"Use circo, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_pa_button
#
misc
#
set_tooltip_text
"Use patchwork, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
par_os_button
#
misc
#
set_tooltip_text
"Use osage, but show only links to the parent (works if State.t contains a 'par:int' field)"
;
ignore
(
par_dot_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_dot_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"d_par"
));
dot_view
:=
d_par
;
!
dot_view
()
));
ignore
(
par_fd_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_fd_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"fd_par"
));
dot_view
:=
fd_par
;
!
dot_view
()
));
ignore
(
par_sf_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_sf_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"sf_par"
));
dot_view
:=
sf_par
;
!
dot_view
()
));
ignore
(
par_ne_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_ne_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"ne_par"
));
dot_view
:=
ne_par
;
!
dot_view
()
));
ignore
(
par_tw_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_tw_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"tw_par"
));
dot_view
:=
tw_par
;
!
dot_view
()
));
ignore
(
par_ci_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_ci_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"ci_par"
));
dot_view
:=
ci_par
;
!
dot_view
()
));
ignore
(
par_pa_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_pa_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"pa_par"
));
dot_view
:=
pa_par
;
!
dot_view
()
));
ignore
(
par_os_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
par_os_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"os_par"
));
dot_view
:=
os_par
;
!
dot_view
()
))
in
let
have_parent
()
=
(* is there a parent field in the state ? *)
(* List.exists (fun (v,_) -> Str.string_match (Str.regexp ".*_par.*") v 0) !e.data *)
true
in
if
have_parent
()
then
par_dot
()
;
dot_button
#
misc
#
set_tooltip_text
"Use the dot engine to display the graph"
;
fd_button
#
misc
#
set_tooltip_text
"Use the fdp engine to display the graph"
;
sf_button
#
misc
#
set_tooltip_text
"Use the sfdp engine to display the graph"
;
ne_button
#
misc
#
set_tooltip_text
"Use the neato engine to display the graph"
;
tw_button
#
misc
#
set_tooltip_text
"Use the twopi engine to display the graph"
;
ci_button
#
misc
#
set_tooltip_text
"Use the circo engine to display the graph"
;
pa_button
#
misc
#
set_tooltip_text
"Use the patchwork engine to display the graph"
;
os_button
#
misc
#
set_tooltip_text
"Use the osage engine to display the graph"
;
ignore
(
dot_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
dot_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"d"
));
dot_view
:=
dot
;
!
dot_view
()
));
ignore
(
fd_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
fd_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"fd"
));
dot_view
:=
fd
;
!
dot_view
()
));
ignore
(
sf_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
sf_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"sf"
));
dot_view
:=
sf
;
!
dot_view
()
));
ignore
(
ne_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
ne_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"ne"
));
dot_view
:=
ne
;
!
dot_view
()
));
ignore
(
tw_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
tw_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"tw"
));
dot_view
:=
tw
;
!
dot_view
()
));
ignore
(
ci_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
ci_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"ci"
));
dot_view
:=
ci
;
!
dot_view
()
));
ignore
(
pa_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
pa_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"pa"
));
dot_view
:=
pa
;
!
dot_view
()
));
ignore
(
os_button
#
connect
#
clicked
~
callback
:
(
fun
()
->
p
((
os_button
#
misc
#
tooltip_text
)
^
"
\n
"
^
(
help_string
"os"
));
dot_view
:=
os
;
!
dot_view
()
));
ignore
(
window
#
connect
#
destroy
~
callback
:
(
fun
()
->
quit
()
;
(* quit rdbg, this will stop the readloop below *)
Main
.
quit
()
(* terminate gtk *)
));
(* Affichage d'informations *)
(* let gtext_content = ref "" in *)
let
step
=
custom_daemon
text_out
w
in
refresh
()
let
m
=
main
let
gui
=
main
(* todo
- cacher les boutons de rounds en mode manuel
- cacher le bouton step en mode manuel central
...
...
tools/rdbg4sasa/sasa-rdbg-cmds.ml
View file @
272e76b3
...
...
@@ -223,13 +223,18 @@ let goto_next_false_oracle e =
List
.
mem
(
"ok"
,
Bool
)
e
.
outputs
&&
not
(
vb
"ok"
e
))
let
viol
()
=
let
viol
_string
()
=
if
args
.
oracles
<>
[]
then
(
e
:=
goto_next_false_oracle
!
e
;
!
dot_view
()
e
:=
goto_next_false_oracle
!
e
;
!
dot_view
()
;
"An oracle has been violated. Cf the .rif file"
)
else
(
Printf
.
printf
"No oracle is set.
\n
%!
"
"No oracle is set."
)
;;
let
viol
()
=
Printf
.
printf
"%s
\n
%!"
(
viol_string
()
)
let
_
=
add_doc_entry
"viol"
"unit -> unit"
"Move forward until the oracle is violated"
"sasa"
"sasa-rdbg-cmds.ml"
(**********************************************************************)
(* Move forward until silence *)
...
...
@@ -283,8 +288,16 @@ let _ =
add_doc_entry
"nd"
"unit -> unit"
"go to the next event and update the network"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"bd"
"unit -> unit"
"go to the previous event and update the network"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"nr"
"unit -> unit"
"go to the next round and update the network"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"pr"
"unit -> unit"
"go to the previous round and update the network"
"sasa"
"sasa-rdbg-cmds.ml"
;;
add_doc_entry
"pr"
"unit -> unit"
"go to the previous round and update the network"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"d_par"
"unit -> unit"
"cf d (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"ne_par"
"unit -> unit"
"cf ne (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"tw_par"
"unit -> unit"
"cf tw (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"ci_par"
"unit -> unit"
"cf ci (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"fd_par"
"unit -> unit"
"cf fd (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"sf_par"
"unit -> unit"
"cf sf (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"pa_par"
"unit -> unit"
"cf pa (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
add_doc_entry
"os_par"
"unit -> unit"
"cf os (for topology with a parent field)"
"sasa"
"sasa-rdbg-cmds.ml"
;
()
let
l
()
=
l
()
;
...
...
tools/rdbgui4sasa/dune
View file @
272e76b3
...
...
@@ -13,7 +13,7 @@
)
)
(install
(files chut_small.svg graph_small.png)
(files chut_small.svg graph_small.png
gui2use.ml
)
(section lib)
(package rdbgui4sasa)
)
...
...
tools/rdbgui4sasa/rdbgui.ml
View file @
272e76b3
let
quote
str
=
if
String
.
contains
str
'
'
then
(
"
\"
"
^
str
^
"
\"
"
)
else
str
let
rdbg_cmd
=
String
.
concat
" "
(
"rdbg"
::
(
List
.
tl
(
List
.
map
quote
(
Array
.
to_list
Sys
.
argv
))))
(* let oc_stdin = Unix.open_process_out rdbg_cmd *)
let
ic_stdout
,
oc_stdin
=
Unix
.
open_process
rdbg_cmd
(* let ic_stdout, oc_stdin, ic_stderr =
Unix.open_process_full rdbg_cmd (Unix.environment()) *)
let
_
=
Unix
.
set_nonblock
(
Unix
.
descr_of_in_channel
ic_stdout
);
(* Unix.set_nonblock (Unix.descr_of_in_channel ic_stderr) *)
()
(* let p str = Printf.printf "%s\n%!" str *)
let
read_stdout
ic
=
let
buff
=
Bytes
.
create
256
in
let
res
=
ref
""
in
let
cond
=
ref
true
in
Unix
.
sleepf
0
.
5
;
while
!
cond
do
try
let
n
=
Stdlib
.
input
ic
buff
0
256
in
res
:=
!
res
^
(
Bytes
.
sub_string
buff
0
n
);
if
n
<
256
then
cond
:=
false
;
with
Sys_blocked_io
->
cond
:=
false
done
;
if
!
res
<>
""
then
Printf
.
printf
"%s%!"
!
res
;
!
res
let
prefix
=
try
let
opam_dir
=
Unix
.
getenv
"OPAM_SWITCH_PREFIX"
in
opam_dir
with
Not_found
->
"$HOME/sasa/"
let
lib_prefix
=
prefix
^
"/lib/sasa"
let
libui_prefix
=
prefix
^
"/lib/rdbgui4sasa"
let
gui
str
=
Printf
.
fprintf
oc_stdin
"%s
\n
"
str
;
(* sent the session choice *)
(* Printf.fprintf oc_stdin "#require \"sasa\";;\n%!" ; *)
(* Printf.fprintf oc_stdin "#use \"sasa-rdbg-cmds.ml\";;\n%!"; *)
Printf
.
fprintf
oc_stdin
"del_hook
\"
print_event
\"
; add_hook
\"
print_event
\"
(print_sasa_event false);;
\n
%!"
;
(* Printf.fprintf oc_stdin "print_sasa_event false !e;;\n"; (* print the first event *) *)
let
_locale
=
GMain
.
init
()
in
let
_thread
=
GtkThread
.
start
()
in
let
w
=
GWindow
.
window
~
show
:
true
~
title
:
"A rdbg GUI for sasa"
()
in
let
box
=
GPack
.
vbox
~
packing
:
w
#
add
()
in
let
gbox
=
GPack
.
hbox
~
packing
:
box
#
add
()
in
let
gbox2
=
GPack
.
hbox
~
packing
:
box
#
add
()
in
let
sw1
=
GBin
.
scrolled_window
~
border_width
:
10
~
shadow_type
:
`IN
~
height
:
30
~
width
:
50
~
packing
:
box
#
add
()
in
let
sw2
=
GBin
.
scrolled_window
~
border_width
:
10
~
shadow_type
:
`OUT
~
height
:
250
~
packing
:
box
#
add
()
in
sw1
#
misc
#
set_tooltip_text
"This window displays the commands sent to the rdbg cli"
;
sw2
#
misc
#
set_tooltip_text
"This window displays commands outputs"
;
let
text1
=
GText
.
view
~
wrap_mode
:
`CHAR
~
height
:
50
~
editable
:
false
~
width
:
50
~
packing
:
sw1
#
add
()
~
cursor_visible
:
true
in
let
text2
=
GText
.
view
~
wrap_mode
:
`CHAR
~
height
:
250
~
editable
:
false
~
packing
:
sw2
#
add
()
~
cursor_visible
:
true
in
(* text2#place_cursor_onscreen (); *)
(* let text3 = GText.view ~editable:false ~packing: box#add () in *)
(* let input_buff = Buffer.create 100 in *)
let
p
str
=
(* Buffer.add_string input_buff (str^"\n"); *)