Commit dd787602 authored by Clément Fumex's avatar Clément Fumex

load proof first attempt

parent 9e698189
...@@ -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
......
...@@ -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 tid] removes the transformation [tid] 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 =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment