Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
Why3
why3
Commits
dd787602
Commit
dd787602
authored
Mar 02, 2016
by
Clément Fumex
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
load proof first attempt
parent
9e698189
Changes
2
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
297 additions
and
180 deletions
+297
-180
src/session/session_itp.ml
src/session/session_itp.ml
+279
-168
src/session/session_itp.mli
src/session/session_itp.mli
+18
-12
No files found.
src/session/session_itp.ml
View file @
dd787602
...
@@ -9,15 +9,21 @@ let debug = Debug.register_info_flag "session_itp"
...
@@ -9,15 +9,21 @@ let debug = Debug.register_info_flag "session_itp"
type
transID
=
int
type
transID
=
int
type
proofNodeID
=
int
type
proofNodeID
=
int
type
proof_parent
=
Trans
of
transID
|
Theory
of
Theory
.
theory
type
theory
=
{
theory_name
:
Ident
.
ident
;
theory_checksum
:
Termcode
.
checksum
option
;
theory_goals
:
proofNodeID
list
;
}
type
proof_parent
=
Trans
of
transID
|
Theory
of
theory
type
proof_attempt
=
{
type
proof_attempt
=
{
prover
:
Whyconf
.
prover
;
prover
:
Whyconf
.
prover
;
timelimit
:
int
;
timelimit
:
int
;
memlimit
:
int
;
memlimit
:
int
;
stepslimit
:
int
;
stepslimit
:
int
;
proof_state
:
Call_provers
.
prover_result
option
;
(* None means that the call was not done
proof_state
:
Call_provers
.
prover_result
option
;
or never returned *)
(* None means that the call was not done
or never returned *)
proof_obsolete
:
bool
;
proof_obsolete
:
bool
;
proof_script
:
string
option
;
(* non empty for external ITP *)
proof_script
:
string
option
;
(* non empty for external ITP *)
}
}
...
@@ -49,20 +55,14 @@ type transformation_node = {
...
@@ -49,20 +55,14 @@ type transformation_node = {
transf_parent
:
proofNodeID
;
transf_parent
:
proofNodeID
;
}
}
type
theory
=
{
theory_name
:
Ident
.
ident
;
theory_checksum
:
Termcode
.
checksum
option
;
theory_goals
:
proofNodeID
list
;
}
type
file
=
{
type
file
=
{
file_name
:
string
;
file_name
:
string
;
file_format
:
string
option
;
file_format
:
string
option
;
file_theories
:
theory
list
;
file_theories
:
theory
list
;
}
}
type
session
=
{
type
session
=
{
task
_table
:
proof_node
Hint
.
t
;
proofNode
_table
:
proof_node
Hint
.
t
;
mutable
next_proofNodeID
:
int
;
mutable
next_proofNodeID
:
int
;
trans_table
:
transformation_node
Hint
.
t
;
trans_table
:
transformation_node
Hint
.
t
;
mutable
next_transID
:
int
;
mutable
next_transID
:
int
;
...
@@ -70,7 +70,7 @@ type session = {
...
@@ -70,7 +70,7 @@ type session = {
mutable
session_shape_version
:
int
;
mutable
session_shape_version
:
int
;
session_prover_ids
:
int
Hprover
.
t
;
session_prover_ids
:
int
Hprover
.
t
;
session_file_name
:
string
;
session_file_name
:
string
;
}
}
let
gen_transID
(
s
:
session
)
=
let
gen_transID
(
s
:
session
)
=
let
id
=
s
.
next_transID
in
let
id
=
s
.
next_transID
in
...
@@ -82,12 +82,23 @@ let gen_proofNodeID (s : session) =
...
@@ -82,12 +82,23 @@ let gen_proofNodeID (s : session) =
s
.
next_proofNodeID
<-
id
+
1
;
s
.
next_proofNodeID
<-
id
+
1
;
id
id
exception
BadID
let
get_proofNode
(
s
:
session
)
(
id
:
proofNodeID
)
=
try
Hint
.
find
s
.
proofNode_table
id
with
Not_found
->
raise
BadID
let
get_transfNode
(
s
:
session
)
(
id
:
transID
)
=
try
Hint
.
find
s
.
trans_table
id
with
Not_found
->
raise
BadID
let
empty_session
?
shape_version
(
file
:
string
)
=
let
empty_session
?
shape_version
(
file
:
string
)
=
let
shape_version
=
match
shape_version
with
let
shape_version
=
match
shape_version
with
|
Some
v
->
v
|
Some
v
->
v
|
None
->
Termcode
.
current_shape_version
|
None
->
Termcode
.
current_shape_version
in
in
{
task
_table
=
Hint
.
create
97
;
{
proofNode
_table
=
Hint
.
create
97
;
next_proofNodeID
=
0
;
next_proofNodeID
=
0
;
trans_table
=
Hint
.
create
97
;
trans_table
=
Hint
.
create
97
;
next_transID
=
0
;
next_transID
=
0
;
...
@@ -97,35 +108,52 @@ let empty_session ?shape_version (file : string) =
...
@@ -97,35 +108,52 @@ let empty_session ?shape_version (file : string) =
session_file_name
=
file
;
session_file_name
=
file
;
}
}
exception
BadID
let
graft_proof_attempt
(
s
:
session
)
(
id
:
proofNodeID
)
(
pa
:
proof_attempt
)
=
let
graft_proof_attempt
(
s
:
session
)
(
id
:
proofNodeID
)
(
pa
:
proof_attempt
)
=
try
let
pn
=
get_proofNode
s
id
in
let
pn
=
Hint
.
find
s
.
task_table
id
in
let
node
=
{
proofa_parent
=
id
;
proofa_attempt
=
pa
}
in
let
node
=
{
proofa_parent
=
id
;
proofa_attempt
=
pa
}
in
Hprover
.
replace
pn
.
proofn_attempts
pa
.
prover
node
Hprover
.
replace
pn
.
proofn_attempts
pa
.
prover
node
with
Not_found
->
raise
BadID
let
mk_proof_node
(
s
:
session
)
(
tid
:
int
)
(
t
:
Task
.
task
)
=
let
remove_proof_attempt
(
s
:
session
)
(
id
:
proofNodeID
)
let
id
=
gen_proofNodeID
s
in
(
prover
:
Whyconf
.
prover
)
=
let
pn
=
{
proofn_task
=
t
;
proofn_parent
=
Trans
tid
;
let
pn
=
get_proofNode
s
id
in
proofn_attempts
=
Hprover
.
create
3
;
Hprover
.
remove
pn
.
proofn_attempts
prover
(* [mk_proof_node s t p id] register in the session [s] a proof node
of proofNodeID [id] of parent [p] of task [t] *)
let
mk_proof_node
(
s
:
session
)
(
t
:
Task
.
task
)
(
parent
:
proof_parent
)
(
node_id
:
proofNodeID
)
=
let
pn
=
{
proofn_task
=
t
;
proofn_parent
=
parent
;
proofn_attempts
=
Hprover
.
create
7
;
proofn_transformations
=
[]
}
in
proofn_transformations
=
[]
}
in
Hint
.
add
s
.
task_table
id
pn
;
Hint
.
add
s
.
proofNode_table
node_id
pn
let
mk_transf_proof_node
(
s
:
session
)
(
tid
:
int
)
(
t
:
Task
.
task
)
=
let
id
=
gen_proofNodeID
s
in
mk_proof_node
s
t
(
Trans
tid
)
id
;
id
id
let
graft_transf
(
s
:
session
)
(
id
:
proofNodeID
)
(
name
:
string
)
(
l
:
trans_arg
list
)
(
tl
:
Task
.
task
list
)
=
let
mk_transf_node
(
s
:
session
)
(
id
:
proofNodeID
)
(
node_id
:
transID
)
try
(
name
:
string
)
(
args
:
trans_arg
list
)
(
pnl
:
proofNodeID
list
)
=
let
pn
=
Hint
.
find
s
.
task_table
id
in
let
pn
=
get_proofNode
s
id
in
let
tid
=
gen_transID
s
in
let
sub_tasks
=
List
.
map
(
mk_proof_node
s
tid
)
tl
in
let
tn
=
{
transf_name
=
name
;
let
tn
=
{
transf_name
=
name
;
transf_args
=
l
;
transf_args
=
args
;
transf_subtasks
=
sub_tasks
;
transf_subtasks
=
pnl
;
transf_parent
=
id
;
}
in
transf_parent
=
id
;
}
in
Hint
.
replace
s
.
trans_table
tid
tn
;
Hint
.
add
s
.
trans_table
node_id
tn
;
pn
.
proofn_transformations
<-
tid
::
pn
.
proofn_transformations
pn
.
proofn_transformations
<-
node_id
::
pn
.
proofn_transformations
with
Not_found
->
raise
BadID
let
graft_transf
(
s
:
session
)
(
id
:
proofNodeID
)
(
name
:
string
)
(
args
:
trans_arg
list
)
(
tl
:
Task
.
task
list
)
=
let
tid
=
gen_transID
s
in
let
sub_tasks
=
List
.
map
(
mk_transf_proof_node
s
tid
)
tl
in
mk_transf_node
s
id
tid
name
args
sub_tasks
let
remove_transformation
(
s
:
session
)
(
id
:
transID
)
=
let
nt
=
get_transfNode
s
id
in
Hint
.
remove
s
.
trans_table
id
;
let
pn
=
get_proofNode
s
nt
.
transf_parent
in
let
trans_up
=
List
.
filter
(
fun
tid
->
tid
!=
id
)
pn
.
proofn_transformations
in
pn
.
proofn_transformations
<-
trans_up
;
(************************)
(************************)
(* saving state on disk *)
(* saving state on disk *)
...
@@ -267,7 +295,7 @@ let read_file_session_and_shapes dir xml_filename =
...
@@ -267,7 +295,7 @@ let read_file_session_and_shapes dir xml_filename =
Filename
.
concat
dir
compressed_shape_filename
Filename
.
concat
dir
compressed_shape_filename
in
in
if
Sys
.
file_exists
compressed_shape_filename
then
if
Sys
.
file_exists
compressed_shape_filename
then
(* if Compress.compression_supported then
(* if Compress.compression_supported then
Session.ReadShapesCompress.read_xml_and_shapes
Session.ReadShapesCompress.read_xml_and_shapes
xml_filename compressed_shape_filename
xml_filename compressed_shape_filename
else *)
else *)
...
@@ -278,31 +306,115 @@ let read_file_session_and_shapes dir xml_filename =
...
@@ -278,31 +306,115 @@ let read_file_session_and_shapes dir xml_filename =
end
end
else
else
let
shape_filename
=
Filename
.
concat
dir
shape_filename
in
let
shape_filename
=
Filename
.
concat
dir
shape_filename
in
(* if Sys.file_exists shape_filename then
(* if Sys.file_exists shape_filename then
ReadShapesNoCompress.read_xml_and_shapes xml_filename shape_filename
ReadShapesNoCompress.read_xml_and_shapes xml_filename shape_filename
else*)
else*)
begin
begin
Warning
.
emit
"[Warning] could not find goal shapes file@."
;
Warning
.
emit
"[Warning] could not find goal shapes file@."
;
Xml
.
from_file
xml_filename
,
false
Xml
.
from_file
xml_filename
,
false
end
end
with
e
->
with
e
->
Warning
.
emit
"[Warning] failed to read goal shapes: %s@."
Warning
.
emit
"[Warning] failed to read goal shapes: %s@."
(
Printexc
.
to_string
e
);
(
Printexc
.
to_string
e
);
Xml
.
from_file
xml_filename
,
false
Xml
.
from_file
xml_filename
,
false
let
load_file
session
old_provers
f
=
old_provers
(* [load_goal s op p g id] loads the goal of parent [p] from the xml
(* match f.Xml.name with
[g] of nodeID [id] into the session [s] *)
let
rec
load_goal
session
old_provers
parent
g
id
=
match
g
.
Xml
.
name
with
|
"goal"
->
mk_proof_node
session
None
parent
id
;
List
.
iter
(
load_proof_or_transf
session
old_provers
id
)
g
.
Xml
.
elements
;
|
"label"
->
()
|
s
->
Warning
.
emit
"[Warning] Session.load_goal: unexpected element '%s'@."
s
(* [load_proof_or_transf s op id a] load either a proof attempt or a
transformation of parent id [pid] from the xml [a] into the session
[s] *)
and
load_proof_or_transf
session
old_provers
pid
a
=
match
a
.
Xml
.
name
with
|
"proof"
->
begin
let
prover
=
string_attribute
"prover"
a
in
try
let
prover
=
int_of_string
prover
in
let
(
p
,
timelimit
,
steplimit
,
memlimit
)
=
Mint
.
find
prover
old_provers
in
let
res
=
match
a
.
Xml
.
elements
with
|
[
r
]
->
load_result
r
|
[]
->
None
|
_
->
Warning
.
emit
"[Error] Too many result elements@."
;
raise
(
LoadError
(
a
,
"too many result elements"
))
in
let
edit
=
load_option
"edited"
a
in
let
edit
=
match
edit
with
None
|
Some
""
->
None
|
_
->
edit
in
let
obsolete
=
bool_attribute
"obsolete"
a
false
in
let
timelimit
=
int_attribute_def
"timelimit"
a
timelimit
in
let
steplimit
=
int_attribute_def
"steplimit"
a
steplimit
in
let
memlimit
=
int_attribute_def
"memlimit"
a
memlimit
in
let
pa
=
{
prover
=
p
;
timelimit
=
timelimit
;
memlimit
=
memlimit
;
stepslimit
=
steplimit
;
proof_state
=
res
;
proof_obsolete
=
obsolete
;
proof_script
=
edit
;
}
in
graft_proof_attempt
session
pid
pa
with
Failure
_
|
Not_found
->
Warning
.
emit
"[Error] prover id not listed in header '%s'@."
prover
;
raise
(
LoadError
(
a
,
"prover not listing in header"
))
end
|
"transf"
->
let
trname
=
string_attribute
"name"
a
in
let
tid
=
gen_transID
session
in
let
subtasks
=
List
.
fold_left
(
fun
goals
th
->
match
th
.
Xml
.
name
with
|
"goal"
->
(
gen_proofNodeID
session
)
::
goals
|
_
->
goals
)
[]
a
.
Xml
.
elements
in
mk_transf_node
session
pid
tid
trname
[]
subtasks
;
List
.
iter2
(
load_goal
session
old_provers
(
Trans
tid
))
a
.
Xml
.
elements
subtasks
;
|
"metas"
->
()
|
"label"
->
()
|
s
->
Warning
.
emit
"[Warning] Session.load_proof_or_transf: unexpected element '%s'@."
s
let
load_theory
session
old_provers
acc
th
=
match
th
.
Xml
.
name
with
|
"theory"
->
let
thname
=
load_ident
th
in
let
csum
=
string_attribute_opt
"sum"
th
in
let
checksum
=
Opt
.
map
Termcode
.
checksum_of_string
csum
in
let
goals
=
List
.
fold_left
(
fun
goals
th
->
match
th
.
Xml
.
name
with
|
"goal"
->
(
gen_proofNodeID
session
)
::
goals
|
_
->
goals
)
[]
th
.
Xml
.
elements
in
let
mth
=
{
theory_name
=
thname
;
theory_checksum
=
checksum
;
theory_goals
=
goals
;
}
in
List
.
iter2
(
load_goal
session
old_provers
(
Theory
mth
))
th
.
Xml
.
elements
goals
;
mth
::
acc
|
s
->
Warning
.
emit
"[Warning] Session.load_theory: unexpected element '%s'@."
s
;
acc
let
load_file
session
old_provers
f
=
(* old_provers *)
match
f
.
Xml
.
name
with
|
"file"
->
|
"file"
->
let ctxt = { old_provers = old_provers ; keygen = keygen } in
let
fn
=
string_attribute
"name"
f
in
let
fn
=
string_attribute
"name"
f
in
let
fmt
=
load_option
"format"
f
in
let
fmt
=
load_option
"format"
f
in
let expanded = bool_attribute "expanded" f false in
let
ft
=
List
.
rev
let mf = raw_add_file ~keygen:ctxt.keygen ~expanded session fn fmt in
mf.file_theories <-
List.rev
(
List
.
fold_left
(
List
.
fold_left
(load_theory ctxt mf) [] f.Xml.elements);
(
load_theory
session
old_provers
)
[]
f
.
Xml
.
elements
)
in
mf.file_verified <- file_verified mf;
let
mf
=
{
file_name
=
fn
;
file_format
=
fmt
;
file_theories
=
ft
;
}
in
Hstr
.
add
session
.
session_files
fn
mf
;
old_provers
old_provers
|
"prover"
->
|
"prover"
->
(* The id is just for the session file *)
(* The id is just for the session file *)
...
@@ -316,7 +428,7 @@ let load_file session old_provers f = old_provers
...
@@ -316,7 +428,7 @@ let load_file session old_provers f = old_provers
let
timelimit
=
int_attribute_def
"timelimit"
f
5
in
let
timelimit
=
int_attribute_def
"timelimit"
f
5
in
let
steplimit
=
int_attribute_def
"steplimit"
f
1
in
let
steplimit
=
int_attribute_def
"steplimit"
f
1
in
let
memlimit
=
int_attribute_def
"memlimit"
f
1000
in
let
memlimit
=
int_attribute_def
"memlimit"
f
1000
in
let p = {
C
.prover_name = name;
let
p
=
{
Whyconf
.
prover_name
=
name
;
prover_version
=
version
;
prover_version
=
version
;
prover_altern
=
altern
}
in
prover_altern
=
altern
}
in
Mint
.
add
id
(
p
,
timelimit
,
steplimit
,
memlimit
)
old_provers
Mint
.
add
id
(
p
,
timelimit
,
steplimit
,
memlimit
)
old_provers
...
@@ -327,7 +439,6 @@ let load_file session old_provers f = old_provers
...
@@ -327,7 +439,6 @@ let load_file session old_provers f = old_provers
|
s
->
|
s
->
Warning
.
emit
"[Warning] Session.load_file: unexpected element '%s'@."
s
;
Warning
.
emit
"[Warning] Session.load_file: unexpected element '%s'@."
s
;
old_provers
old_provers
*)
let
build_session
(
s
:
session
)
xml
=
let
build_session
(
s
:
session
)
xml
=
match
xml
.
Xml
.
name
with
match
xml
.
Xml
.
name
with
...
...
src/session/session_itp.mli
View file @
dd787602
...
@@ -7,9 +7,11 @@ type trans_arg
...
@@ -7,9 +7,11 @@ type trans_arg
(* (\** New Proof sessions ("Refectoire") *\) *)
(* (\** New Proof sessions ("Refectoire") *\) *)
(* note: la fonction register des transformations doit permettre de declarer les types des arguments
(* note: la fonction register des transformations doit permettre de
declarer les types des arguments
type trans_arg_type = TTint | TTstring | TTterm | TTty | TTtysymbol | TTlsymbol | TTprsymbol
type trans_arg_type = TTint | TTstring | TTterm | TTty | TTtysymbol
| TTlsymbol | TTprsymbol
*)
*)
...
@@ -19,32 +21,36 @@ val graft_proof_attempt : session -> proofNodeID -> proof_attempt -> unit
...
@@ -19,32 +21,36 @@ val graft_proof_attempt : session -> proofNodeID -> proof_attempt -> unit
(** [graft_proof_attempt s id pa] adds the proof attempt [pa] as a
(** [graft_proof_attempt s id pa] adds the proof attempt [pa] as a
child of the task [id] of the session [s]. *)
child of the task [id] of the session [s]. *)
val
graft_transf
:
session
->
proofNodeID
->
string
->
trans_arg
list
->
Task
.
task
list
->
unit
val
graft_transf
:
session
->
proofNodeID
->
string
->
trans_arg
list
->
Task
.
task
list
->
unit
(** [graft_transf s id name l tl] adds the transformation [name] as a
(** [graft_transf s id name l tl] adds the transformation [name] as a
child of the task [id] of the session [s]. [l] is the list of argument
child of the task [id] of the session [s]. [l] is the list of
of the transformation; [tl] is the resulting list of tasks *)
argument of the transformation; [tl] is the resulting list of
tasks *)
val
remove_proof_attempt
:
session
->
proofNodeID
->
Whyconf
.
prover
->
unit
val
remove_proof_attempt
:
session
->
proofNodeID
->
Whyconf
.
prover
->
unit
(** [remove_proof_attempt s id pr] removes the proof attempt from the
(** [remove_proof_attempt s id pr] removes the proof attempt from the
prover [pr] from the proof node [id] of the session [s] *)
prover [pr] from the proof node [id] of the session [s] *)
val
remove_transformation
:
session
->
proofNodeID
->
transID
->
unit
val
remove_transformation
:
session
->
transID
->
unit
(** [remove_transformation s
pid t
id] removes the transformation [
t
id]
from
(** [remove_transformation s id] removes the transformation [id]
the proof node [pid] of
the session [s] *)
from
the session [s] *)
val
save_session
:
string
->
session
->
unit
(*
val save_session : string -> session -> unit
*)
(** [save_session f s] Save the session [s] in file [f] *)
(** [save_session f s] Save the session [s] in file [f] *)
val
load_session
:
string
->
session
val
load_session
:
string
->
session
*
bool
(** [load_session f] load a session from a file [f]; all the tasks are
(** [load_session f] load a session from a file [f]; all the tasks are
initialised to None *)
initialised to None *)
(*
(*
couche au-dessus: "scheduler" cad modifications asynchrones de la session
couche au-dessus: "scheduler" cad modifications asynchrones de la
session
- gere une file de travaux de modifications a faire
- gere une file de travaux de modifications a faire
- recupere les resultats de travaux , et les applique s'ils sont encore valides
- recupere les resultats de travaux , et les applique s'ils sont
encore valides
*)
*)
(*
(*
type theory =
type theory =
...
...
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