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
why3
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
120
Issues
120
List
Boards
Labels
Service Desk
Milestones
Merge Requests
17
Merge Requests
17
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
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"
type
transID
=
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
=
{
prover
:
Whyconf
.
prover
;
timelimit
:
int
;
memlimit
:
int
;
stepslimit
:
int
;
proof_state
:
Call_provers
.
prover_result
option
;
(* None means that the call was not done
or never returned *)
proof_state
:
Call_provers
.
prover_result
option
;
(* None means that the call was not done
or never returned *)
proof_obsolete
:
bool
;
proof_script
:
string
option
;
(* non empty for external ITP *)
}
...
...
@@ -49,20 +55,14 @@ type transformation_node = {
transf_parent
:
proofNodeID
;
}
type
theory
=
{
theory_name
:
Ident
.
ident
;
theory_checksum
:
Termcode
.
checksum
option
;
theory_goals
:
proofNodeID
list
;
}
type
file
=
{
file_name
:
string
;
file_format
:
string
option
;
file_theories
:
theory
list
;
}
type
session
=
{
task
_table
:
proof_node
Hint
.
t
;
type
session
=
{
proofNode
_table
:
proof_node
Hint
.
t
;
mutable
next_proofNodeID
:
int
;
trans_table
:
transformation_node
Hint
.
t
;
mutable
next_transID
:
int
;
...
...
@@ -70,7 +70,7 @@ type session = {
mutable
session_shape_version
:
int
;
session_prover_ids
:
int
Hprover
.
t
;
session_file_name
:
string
;
}
}
let
gen_transID
(
s
:
session
)
=
let
id
=
s
.
next_transID
in
...
...
@@ -82,12 +82,23 @@ let gen_proofNodeID (s : session) =
s
.
next_proofNodeID
<-
id
+
1
;
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
shape_version
=
match
shape_version
with
|
Some
v
->
v
|
None
->
Termcode
.
current_shape_version
in
{
task
_table
=
Hint
.
create
97
;
{
proofNode
_table
=
Hint
.
create
97
;
next_proofNodeID
=
0
;
trans_table
=
Hint
.
create
97
;
next_transID
=
0
;
...
...
@@ -97,35 +108,52 @@ let empty_session ?shape_version (file : string) =
session_file_name
=
file
;
}
exception
BadID
let
graft_proof_attempt
(
s
:
session
)
(
id
:
proofNodeID
)
(
pa
:
proof_attempt
)
=
try
let
pn
=
Hint
.
find
s
.
task_table
id
in
let
pn
=
get_proofNode
s
id
in
let
node
=
{
proofa_parent
=
id
;
proofa_attempt
=
pa
}
in
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
id
=
gen_proofNodeID
s
in
let
pn
=
{
proofn_task
=
t
;
proofn_parent
=
Trans
tid
;
proofn_attempts
=
Hprover
.
create
3
;
let
remove_proof_attempt
(
s
:
session
)
(
id
:
proofNodeID
)
(
prover
:
Whyconf
.
prover
)
=
let
pn
=
get_proofNode
s
id
in
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
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
let
graft_transf
(
s
:
session
)
(
id
:
proofNodeID
)
(
name
:
string
)
(
l
:
trans_arg
list
)
(
tl
:
Task
.
task
list
)
=
try
let
pn
=
Hint
.
find
s
.
task_table
id
in
let
tid
=
gen_transID
s
in
let
sub_tasks
=
List
.
map
(
mk_proof_node
s
tid
)
tl
in
let
mk_transf_node
(
s
:
session
)
(
id
:
proofNodeID
)
(
node_id
:
transID
)
(
name
:
string
)
(
args
:
trans_arg
list
)
(
pnl
:
proofNodeID
list
)
=
let
pn
=
get_proofNode
s
id
in
let
tn
=
{
transf_name
=
name
;
transf_args
=
l
;
transf_subtasks
=
sub_tasks
;
transf_args
=
args
;
transf_subtasks
=
pnl
;
transf_parent
=
id
;
}
in
Hint
.
replace
s
.
trans_table
tid
tn
;
pn
.
proofn_transformations
<-
tid
::
pn
.
proofn_transformations
with
Not_found
->
raise
BadID
Hint
.
add
s
.
trans_table
node_id
tn
;
pn
.
proofn_transformations
<-
node_id
::
pn
.
proofn_transformations
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 *)
...
...
@@ -267,7 +295,7 @@ let read_file_session_and_shapes dir xml_filename =
Filename
.
concat
dir
compressed_shape_filename
in
if
Sys
.
file_exists
compressed_shape_filename
then
(* if Compress.compression_supported then
(* if Compress.compression_supported then
Session.ReadShapesCompress.read_xml_and_shapes
xml_filename compressed_shape_filename
else *)
...
...
@@ -278,31 +306,115 @@ let read_file_session_and_shapes dir xml_filename =
end
else
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
else*)
begin
Warning
.
emit
"[Warning] could not find goal shapes file@."
;
Xml
.
from_file
xml_filename
,
false
end
with
e
->
with
e
->
Warning
.
emit
"[Warning] failed to read goal shapes: %s@."
(
Printexc
.
to_string
e
);
Xml
.
from_file
xml_filename
,
false
let
load_file
session
old_provers
f
=
old_provers
(* match f.Xml.name with
(* [load_goal s op p g id] loads the goal of parent [p] from the xml
[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"
->
let ctxt = { old_provers = old_provers ; keygen = keygen } in
let
fn
=
string_attribute
"name"
f
in
let
fmt
=
load_option
"format"
f
in
let expanded = bool_attribute "expanded" f false in
let mf = raw_add_file ~keygen:ctxt.keygen ~expanded session fn fmt in
mf.file_theories <-
List.rev
let
ft
=
List
.
rev
(
List
.
fold_left
(load_theory ctxt mf) [] f.Xml.elements);
mf.file_verified <- file_verified mf;
(
load_theory
session
old_provers
)
[]
f
.
Xml
.
elements
)
in
let
mf
=
{
file_name
=
fn
;
file_format
=
fmt
;
file_theories
=
ft
;
}
in
Hstr
.
add
session
.
session_files
fn
mf
;
old_provers
|
"prover"
->
(* The id is just for the session file *)
...
...
@@ -316,7 +428,7 @@ let load_file session old_provers f = old_provers
let
timelimit
=
int_attribute_def
"timelimit"
f
5
in
let
steplimit
=
int_attribute_def
"steplimit"
f
1
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_altern
=
altern
}
in
Mint
.
add
id
(
p
,
timelimit
,
steplimit
,
memlimit
)
old_provers
...
...
@@ -327,7 +439,6 @@ let load_file session old_provers f = old_provers
|
s
->
Warning
.
emit
"[Warning] Session.load_file: unexpected element '%s'@."
s
;
old_provers
*)
let
build_session
(
s
:
session
)
xml
=
match
xml
.
Xml
.
name
with
...
...
src/session/session_itp.mli
View file @
dd787602
...
...
@@ -7,9 +7,11 @@ type trans_arg
(* (\** 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
(** [graft_proof_attempt s id pa] adds the proof attempt [pa] as a
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
child of the task [id] of the session [s]. [l] is the list of argument
of the transformation; [tl] is the resulting list of tasks *)
child of the task [id] of the session [s]. [l] is the list of
argument of the transformation; [tl] is the resulting list of
tasks *)
val
remove_proof_attempt
:
session
->
proofNodeID
->
Whyconf
.
prover
->
unit
(** [remove_proof_attempt s id pr] removes the proof attempt from the
prover [pr] from the proof node [id] of the session [s] *)
val
remove_transformation
:
session
->
proofNodeID
->
transID
->
unit
(** [remove_transformation s
pid tid] removes the transformation [tid] from
the proof node [pid] of
the session [s] *)
val
remove_transformation
:
session
->
transID
->
unit
(** [remove_transformation s
id] removes the transformation [id]
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] *)
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
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
- 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 =
...
...
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