+++ /dev/null
-requires="helm-acic_content helm-grafite helm-tactics"
-version="0.0.1"
-archive(byte)="acic_procedural.cma"
-archive(native)="acic_procedural.cmxa"
+++ /dev/null
-requires="helm-whelp helm-acic_content helm-cic_unification helm-disambiguation"
-version="0.0.1"
-archive(byte)="cic_disambiguation.cma"
-archive(native)="cic_disambiguation.cmxa"
-requires="helm-library helm-grafite helm-tactics helm-ng_tactics helm-ng_library"
+requires="helm-library helm-grafite helm-cic_unification helm-ng_tactics helm-ng_library"
version="0.0.1"
archive(byte)="grafite_engine.cma"
archive(native)="grafite_engine.cmxa"
-requires="helm-ng_disambiguation helm-lexicon helm-grafite_parser helm-tactics helm-ng_paramodulation"
+requires="helm-ng_disambiguation helm-lexicon helm-grafite_parser helm-ng_paramodulation"
version="0.0.1"
archive(byte)="ng_tactics.cma"
archive(native)="ng_tactics.cmxa"
+++ /dev/null
-requires="helm-extlib helm-cic_proof_checking helm-cic_unification"
-version="0.0.1"
-archive(byte)="tactics.cma"
-archive(native)="tactics.cmxa"
+++ /dev/null
-requires="helm-acic_content helm-grafite helm-lexicon"
-version="0.0.1"
-archive(byte)="tptp_grafite.cma"
-archive(native)="tptp_grafite.cmxa"
-linkopts=""
xml \
hgdome \
registry \
- hmysql \
+ hmysql \
syntax_extensions \
thread \
xmldiff \
acic_content \
grafite \
cic_unification \
- tactics \
- acic_procedural \
disambiguation \
ng_kernel \
ng_refiner \
+++ /dev/null
-proceduralHelpers.cmi:
-proceduralClassify.cmi:
-proceduralOptimizer.cmi:
-proceduralTypes.cmi:
-proceduralMode.cmi:
-proceduralConversion.cmi:
-procedural1.cmi: proceduralTypes.cmi
-procedural2.cmi: proceduralTypes.cmi
-proceduralTeX.cmi: proceduralTypes.cmi
-acic2Procedural.cmi:
-proceduralHelpers.cmo: proceduralHelpers.cmi
-proceduralHelpers.cmx: proceduralHelpers.cmi
-proceduralClassify.cmo: proceduralHelpers.cmi proceduralClassify.cmi
-proceduralClassify.cmx: proceduralHelpers.cmx proceduralClassify.cmi
-proceduralOptimizer.cmo: proceduralHelpers.cmi proceduralClassify.cmi \
- proceduralOptimizer.cmi
-proceduralOptimizer.cmx: proceduralHelpers.cmx proceduralClassify.cmx \
- proceduralOptimizer.cmi
-proceduralTypes.cmo: proceduralHelpers.cmi proceduralTypes.cmi
-proceduralTypes.cmx: proceduralHelpers.cmx proceduralTypes.cmi
-proceduralMode.cmo: proceduralClassify.cmi proceduralMode.cmi
-proceduralMode.cmx: proceduralClassify.cmx proceduralMode.cmi
-proceduralConversion.cmo: proceduralHelpers.cmi proceduralConversion.cmi
-proceduralConversion.cmx: proceduralHelpers.cmx proceduralConversion.cmi
-procedural1.cmo: proceduralTypes.cmi procedural1.cmi
-procedural1.cmx: proceduralTypes.cmx procedural1.cmi
-procedural2.cmo: proceduralTypes.cmi proceduralHelpers.cmi \
- proceduralConversion.cmi proceduralClassify.cmi procedural2.cmi
-procedural2.cmx: proceduralTypes.cmx proceduralHelpers.cmx \
- proceduralConversion.cmx proceduralClassify.cmx procedural2.cmi
-proceduralTeX.cmo: proceduralTypes.cmi proceduralHelpers.cmi \
- proceduralTeX.cmi
-proceduralTeX.cmx: proceduralTypes.cmx proceduralHelpers.cmx \
- proceduralTeX.cmi
-acic2Procedural.cmo: proceduralTypes.cmi proceduralTeX.cmi \
- proceduralHelpers.cmi procedural2.cmi procedural1.cmi acic2Procedural.cmi
-acic2Procedural.cmx: proceduralTypes.cmx proceduralTeX.cmx \
- proceduralHelpers.cmx procedural2.cmx procedural1.cmx acic2Procedural.cmi
+++ /dev/null
-proceduralHelpers.cmi:
-proceduralClassify.cmi:
-proceduralOptimizer.cmi:
-proceduralTypes.cmi:
-proceduralMode.cmi:
-proceduralConversion.cmi:
-procedural1.cmi: proceduralTypes.cmi
-procedural2.cmi: proceduralTypes.cmi
-proceduralTeX.cmi: proceduralTypes.cmi
-acic2Procedural.cmi:
-proceduralHelpers.cmo: proceduralHelpers.cmi
-proceduralHelpers.cmx: proceduralHelpers.cmi
-proceduralClassify.cmo: proceduralHelpers.cmi proceduralClassify.cmi
-proceduralClassify.cmx: proceduralHelpers.cmx proceduralClassify.cmi
-proceduralOptimizer.cmo: proceduralHelpers.cmi proceduralClassify.cmi \
- proceduralOptimizer.cmi
-proceduralOptimizer.cmx: proceduralHelpers.cmx proceduralClassify.cmx \
- proceduralOptimizer.cmi
-proceduralTypes.cmo: proceduralHelpers.cmi proceduralTypes.cmi
-proceduralTypes.cmx: proceduralHelpers.cmx proceduralTypes.cmi
-proceduralMode.cmo: proceduralClassify.cmi proceduralMode.cmi
-proceduralMode.cmx: proceduralClassify.cmx proceduralMode.cmi
-proceduralConversion.cmo: proceduralHelpers.cmi proceduralConversion.cmi
-proceduralConversion.cmx: proceduralHelpers.cmx proceduralConversion.cmi
-procedural1.cmo: proceduralTypes.cmi procedural1.cmi
-procedural1.cmx: proceduralTypes.cmx procedural1.cmi
-procedural2.cmo: proceduralTypes.cmi proceduralHelpers.cmi \
- proceduralConversion.cmi proceduralClassify.cmi procedural2.cmi
-procedural2.cmx: proceduralTypes.cmx proceduralHelpers.cmx \
- proceduralConversion.cmx proceduralClassify.cmx procedural2.cmi
-proceduralTeX.cmo: proceduralTypes.cmi proceduralHelpers.cmi \
- proceduralTeX.cmi
-proceduralTeX.cmx: proceduralTypes.cmx proceduralHelpers.cmx \
- proceduralTeX.cmi
-acic2Procedural.cmo: proceduralTypes.cmi proceduralTeX.cmi \
- proceduralHelpers.cmi procedural2.cmi procedural1.cmi acic2Procedural.cmi
-acic2Procedural.cmx: proceduralTypes.cmx proceduralTeX.cmx \
- proceduralHelpers.cmx procedural2.cmx procedural1.cmx acic2Procedural.cmi
+++ /dev/null
-PACKAGE = acic_procedural
-PREDICATES =
-
-INTERFACE_FILES = \
- proceduralHelpers.mli \
- proceduralClassify.mli \
- proceduralOptimizer.mli \
- proceduralTypes.mli \
- proceduralMode.mli \
- proceduralConversion.mli \
- procedural1.mli \
- procedural2.mli \
- proceduralTeX.mli \
- acic2Procedural.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module C = Cic
-module L = Librarian
-module G = GrafiteAst
-
-module H = ProceduralHelpers
-module T = ProceduralTypes
-module P1 = Procedural1
-module P2 = Procedural2
-module X = ProceduralTeX
-
-let tex_formatter = ref None
-
-(* object costruction *******************************************************)
-
-let th_flavours = [`Theorem; `Lemma; `Remark; `Fact]
-
-let def_flavours = [`Definition; `Variant]
-
-let get_flavour sorts params context v attrs =
- let rec aux = function
- | [] ->
- if H.is_acic_proof sorts context v then List.hd th_flavours
- else List.hd def_flavours
- | `Flavour fl :: _ -> fl
- | _ :: tl -> aux tl
- in
- let flavour_map x y = match x, y with
- | None, G.IPAs flavour -> Some flavour
- | _ -> x
- in
- match List.fold_left flavour_map None params with
- | Some fl -> fl
- | None -> aux attrs
-
-let rec is_record = function
- | [] -> None
- | `Class (`Record fields) :: _ -> Some fields
- | _ :: tl -> is_record tl
-
-let proc_obj ?(info="") proc_proof sorts params context = function
- | C.AConstant (_, _, s, Some v, t, [], attrs) ->
- begin match get_flavour sorts params context v attrs with
- | flavour when List.mem flavour th_flavours ->
- let ast = proc_proof v in
- let steps, nodes = T.count_steps 0 ast, T.count_nodes 0 ast in
- let text =
- if List.mem G.IPComments params then
- Printf.sprintf "%s\n%s%s: %u\n%s: %u\n%s"
- "COMMENTS" info "Tactics" steps "Final nodes" nodes "END"
- else
- ""
- in
- T.Statement (flavour, Some s, t, None, "") :: ast @ [T.Qed text]
- | flavour when List.mem flavour def_flavours ->
- [T.Statement (flavour, Some s, t, Some v, "")]
- | _ ->
- failwith "not a theorem, definition, axiom or inductive type"
- end
- | C.AConstant (_, _, s, None, t, [], attrs) ->
- [T.Statement (`Axiom, Some s, t, None, "")]
- | C.AInductiveDefinition (_, types, [], lpsno, attrs) ->
- begin match is_record attrs with
- | None -> [T.Inductive (types, lpsno, "")]
- | Some fs -> [T.Record (types, lpsno, fs, "")]
- end
- | _ ->
- failwith "not a theorem, definition, axiom or inductive type"
-
-(* interface functions ******************************************************)
-
-let get_proc_proof ~ids_to_inner_sorts ~ids_to_inner_types params context =
- let level_map x y = match x, y with
- | None, G.IPLevel level -> Some level
- | _ -> x
- in
- match List.fold_left level_map None params with
- | None
- | Some 2 ->
- P2.proc_proof
- (P2.init ~ids_to_inner_sorts ~ids_to_inner_types params context)
- | Some 1 ->
- P1.proc_proof
- (P1.init ~ids_to_inner_sorts ~ids_to_inner_types params context)
- | Some n ->
- failwith (
- "Procedural reconstruction level not supported: " ^
- string_of_int n
- )
-
-let procedural_of_acic_object ~ids_to_inner_sorts ~ids_to_inner_types
- ?info params anobj =
- let proc_proof =
- get_proc_proof ~ids_to_inner_sorts ~ids_to_inner_types params []
- in
- L.time_stamp "P : LEVEL 2 ";
- HLog.debug "Procedural: level 2 transformation";
- let steps = proc_obj ?info proc_proof ids_to_inner_sorts params [] anobj in
- let _ = match !tex_formatter with
- | None -> ()
- | Some frm -> X.tex_of_steps frm ids_to_inner_sorts steps
- in
- L.time_stamp "P : RENDERING";
- HLog.debug "Procedural: grafite rendering";
- let r = List.rev (T.render_steps [] steps) in
- L.time_stamp "P : DONE "; r
-
-let procedural_of_acic_term ~ids_to_inner_sorts ~ids_to_inner_types params
- context annterm =
- let proc_proof =
- get_proc_proof ~ids_to_inner_sorts ~ids_to_inner_types params context
- in
- HLog.debug "Procedural: level 2 transformation";
- let steps = proc_proof annterm in
- let _ = match !tex_formatter with
- | None -> ()
- | Some frm -> X.tex_of_steps frm ids_to_inner_sorts steps
- in
- HLog.debug "Procedural: grafite rendering";
- List.rev (T.render_steps [] steps)
-
-let rec is_debug n = function
- | [] -> false
- | G.IPDebug debug :: _ -> n <= debug
- | _ :: tl -> is_debug n tl
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val procedural_of_acic_object:
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> ?info:string ->
- GrafiteAst.inline_param list -> Cic.annobj ->
- (Cic.annterm, Cic.annterm,
- Cic.annterm GrafiteAst.reduction, Cic.annterm CicNotationPt.obj, string)
- GrafiteAst.statement list
-
-val procedural_of_acic_term:
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t ->
- GrafiteAst.inline_param list -> Cic.context -> Cic.annterm ->
- (Cic.annterm, Cic.annterm,
- Cic.annterm GrafiteAst.reduction, Cic.annterm CicNotationPt.obj, string)
- GrafiteAst.statement list
-
-val tex_formatter: Format.formatter option ref
-
-val is_debug: int -> GrafiteAst.inline_param list -> bool
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module C = Cic
-module A = Cic2acic
-module G = GrafiteAst
-
-module T = ProceduralTypes
-
-type status = {
- sorts : (C.id, A.sort_kind) Hashtbl.t;
- types : (C.id, A.anntypes) Hashtbl.t;
- params : G.inline_param list;
- context : C.context
-}
-
-(* interface functions ******************************************************)
-
-let proc_proof st what =
- let dtext = "" in
- [T.Exact (what, dtext)]
-
-let init ~ids_to_inner_sorts ~ids_to_inner_types params context =
- {
- sorts = ids_to_inner_sorts;
- types = ids_to_inner_types;
- params = params;
- context = context
- }
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type status
-
-val init:
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t ->
- GrafiteAst.inline_param list-> Cic.context -> status
-
-val proc_proof:
- status -> Cic.annterm -> ProceduralTypes.step list
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module C = Cic
-module I = CicInspect
-module S = CicSubstitution
-module R = CicReduction
-module TC = CicTypeChecker
-module Un = CicUniv
-module UM = UriManager
-module Obj = LibraryObjects
-module A = Cic2acic
-module Ut = CicUtil
-module E = CicEnvironment
-module Pp = CicPp
-module PEH = ProofEngineHelpers
-module HEL = HExtlib
-module DTI = DoubleTypeInference
-module NU = CicNotationUtil
-module L = Librarian
-module G = GrafiteAst
-
-module Cl = ProceduralClassify
-module T = ProceduralTypes
-module Cn = ProceduralConversion
-module H = ProceduralHelpers
-
-type status = {
- sorts : (C.id, A.sort_kind) Hashtbl.t;
- types : (C.id, A.anntypes) Hashtbl.t;
- params : G.inline_param list;
- max_depth: int option;
- depth : int;
- defaults : bool;
- cr : bool;
- context : C.context;
- case : int list
-}
-
-let debug = ref false
-
-(* helpers ******************************************************************)
-
-let split2_last l1 l2 =
-try
- let n = pred (List.length l1) in
- let before1, after1 = HEL.split_nth n l1 in
- let before2, after2 = HEL.split_nth n l2 in
- before1, before2, List.hd after1, List.hd after2
-with Invalid_argument _ -> failwith "A2P.split2_last"
-
-let string_of_head = function
- | C.ASort _ -> "sort"
- | C.AConst _ -> "const"
- | C.AMutInd _ -> "mutind"
- | C.AMutConstruct _ -> "mutconstruct"
- | C.AVar _ -> "var"
- | C.ARel _ -> "rel"
- | C.AProd _ -> "prod"
- | C.ALambda _ -> "lambda"
- | C.ALetIn _ -> "letin"
- | C.AFix _ -> "fix"
- | C.ACoFix _ -> "cofix"
- | C.AAppl _ -> "appl"
- | C.ACast _ -> "cast"
- | C.AMutCase _ -> "mutcase"
- | C.AMeta _ -> "meta"
- | C.AImplicit _ -> "implict"
-
-let next st = {st with depth = succ st.depth}
-
-let add st entry = {st with context = entry :: st.context}
-
-let push st = {st with case = 1 :: st.case}
-
-let inc st =
- {st with case = match st.case with
- | [] -> []
- | hd :: tl -> succ hd :: tl
- }
-
-let case st str =
- let case = String.concat "." (List.rev_map string_of_int st.case) in
- Printf.sprintf "case %s: %s" case str
-
-let test_depth st =
-try
- let msg = Printf.sprintf "Depth %u: " st.depth in
- match st.max_depth with
- | None -> true, ""
- | Some d -> if st.depth < d then true, msg else false, "DEPTH EXCEDED: "
-with Invalid_argument _ -> failwith "A2P.test_depth"
-
-let is_rewrite_right st = function
- | C.AConst (_, uri, []) -> st.defaults && Obj.is_eq_ind_r_URI uri
- | _ -> false
-
-let is_rewrite_left st = function
- | C.AConst (_, uri, []) -> st.defaults && Obj.is_eq_ind_URI uri
- | _ -> false
-
-let is_fwd_rewrite_right st hd tl =
- if is_rewrite_right st hd then match List.nth tl 3 with
- | C.ARel _ -> true
- | _ -> false
- else false
-
-let is_fwd_rewrite_left st hd tl =
- if is_rewrite_left st hd then match List.nth tl 3 with
- | C.ARel _ -> true
- | _ -> false
- else false
-
-let get_inner_types st v =
-try
- let id = Ut.id_of_annterm v in
- try match Hashtbl.find st.types id with
- | {A.annsynthesized = ity; A.annexpected = Some ety} -> Some (ity, ety)
- | {A.annsynthesized = ity; A.annexpected = None} -> Some (ity, ity)
- with Not_found -> None
-with Invalid_argument _ -> failwith "P2.get_inner_types"
-
-let get_entry st id =
- let rec aux = function
- | [] -> assert false
- | Some (C.Name name, e) :: _ when name = id -> e
- | _ :: tl -> aux tl
- in
- aux st.context
-
-let string_of_atomic = function
- | C.ARel (_, _, _, s) -> s
- | C.AVar (_, uri, _) -> H.name_of_uri uri None None
- | C.AConst (_, uri, _) -> H.name_of_uri uri None None
- | C.AMutInd (_, uri, i, _) -> H.name_of_uri uri (Some i) None
- | C.AMutConstruct (_, uri, i, j, _) -> H.name_of_uri uri (Some i) (Some j)
- | _ -> ""
-
-let get_sub_names head l =
- let s = string_of_atomic head in
- if s = "" then [] else
- let map (names, i) _ =
- let name = Printf.sprintf "%s_%u" s i in name :: names, succ i
- in
- let names, _ = List.fold_left map ([], 1) l in
- List.rev names
-
-let get_type msg st t = H.get_type msg st.context (H.cic t)
-
-let get_uri_of_head = function
- | C.AConst (_, u, _) ->
- Some (u, 0, 0, 0)
- | C.AAppl (_, C.AConst (_, u, _) :: vs) ->
- Some (u, 0, 0, List.length vs)
- | C.AMutInd (_, u, i, _) ->
- Some (u, succ i, 0, 0)
- | C.AAppl (_, C.AMutInd (_, u, i, _) :: vs) ->
- Some (u, succ i, 0, List.length vs)
- | C.AMutConstruct (_, u, i, j, _) ->
- Some (u, succ i, j, 0)
- | C.AAppl (_, C.AMutConstruct (_, u, i, j, _) :: vs) ->
- Some (u, succ i, j, List.length vs)
- | _ ->
- None
-
-let get_uri_of_apply = function
- | T.Exact (t, _)
- | T.Apply (t, _) -> get_uri_of_head t
- | _ -> None
-
-let is_reflexivity st step =
- match get_uri_of_apply step with
- | None -> false
- | Some (uri, i, j, n) ->
- st.defaults && Obj.is_eq_URI uri && i = 1 && j = 1 && n = 0
-
-let is_ho_reflexivity st step =
- match get_uri_of_apply step with
- | None -> false
- | Some (uri, i, j, n) ->
- st.defaults && Obj.is_eq_URI uri && i = 1 && j = 1 && n > 0
-
-let are_convertible st pred sx dx =
- let pred, sx, dx = H.cic pred, H.cic sx, H.cic dx in
- let sx, dx = C.Appl [pred; sx], C.Appl [pred; dx] in
- fst (R.are_convertible st.context sx dx Un.default_ugraph)
-
-(* proof construction *******************************************************)
-
-let anonymous_premise = C.Name "UNNAMED"
-
-let mk_lapply_args hd tl classes =
- let map _ = Cn.meta "" in
- let args = List.rev_map map tl in
- if args = [] then hd else C.AAppl ("", hd :: args)
-
-let mk_apply_args hd tl classes synth qs =
- let exp = ref 0 in
- let map v (cl, b) =
- if I.overlaps synth cl
- then if b then v, v else Cn.meta "", v
- else Cn.meta "", Cn.meta ""
- in
- let rec rev a = function
- | [] -> a
- | hd :: tl ->
- if snd hd <> Cn.meta "" then incr exp;
- rev (snd hd :: a) tl
- in
- let rec aux = function
- | [] -> []
- | hd :: tl ->
- if fst hd = Cn.meta "" then aux tl else rev [] (hd :: tl)
- in
- let args = T.list_rev_map2 map tl classes in
- let args = aux args in
- let part = !exp < List.length tl in
- if args = [] then part, hd, qs else part, C.AAppl ("", hd :: args), qs
-
-let mk_convert st ?name sty ety note =
- let ppterm t =
- let a = ref "" in Ut.pp_term (fun s -> a := !a ^ s) [] st.context t; !a
- in
- let e = Cn.hole "" in
- let csty, cety = H.cic sty, H.cic ety in
- let note =
- if !debug then
- let sname = match name with None -> "" | Some (id, _) -> id in
- Printf.sprintf "%s: %s\nSINTH: %s\nEXP: %s"
- note sname (ppterm csty) (ppterm cety)
- else ""
- in
- if H.alpha ~flatten:true st.context csty cety then [T.Note note] else
- let sty, ety = H.acic_bc st.context sty, H.acic_bc st.context ety in
- match name with
- | None -> [T.Change (sty, ety, None, e, note)]
- | Some (id, i) ->
- begin match get_entry st id with
- | C.Def _ ->
- [T.Change (ety, sty, Some (id, Some id), e, note);
- T.ClearBody (id, "")
- ]
- | C.Decl _ ->
- [T.Change (ety, sty, Some (id, Some id), e, note)]
- end
-
-let convert st ?name v =
- match get_inner_types st v with
- | None ->
- if !debug then [T.Note "NORMAL: NO INNER TYPES"] else []
- | Some (sty, ety) -> mk_convert st ?name sty ety "NORMAL"
-
-let get_intro = function
- | C.Anonymous -> None
- | C.Name s -> Some s
-
-let mk_preamble st what script = match script with
- | step :: script when is_reflexivity st step ->
- T.Reflexivity (T.note_of_step step) :: script
- | step :: script when is_ho_reflexivity st step ->
- convert st what @ T.Reflexivity (T.note_of_step step) :: script
- | T.Exact _ :: _ -> script
- | _ -> convert st what @ script
-
-let mk_arg st = function
- | C.ARel (_, _, i, name) as what -> convert st ~name:(name, i) what
- | _ -> []
-
-let mk_fwd_rewrite st dtext name tl direction v t ity ety =
- let compare premise = function
- | None -> true
- | Some s -> s = premise
- in
- assert (List.length tl = 6);
- let what, where, predicate = List.nth tl 5, List.nth tl 3, List.nth tl 2 in
- let e = Cn.mk_pattern 1 ety predicate in
- if (Cn.does_not_occur e) then st, [] else
- match where with
- | C.ARel (_, _, i, premise) as w ->
- let script name =
- let where = Some (premise, name) in
- let script = mk_arg st what @ mk_arg st w in
- T.Rewrite (direction, what, where, e, dtext) :: script
- in
- if DTI.does_not_occur (succ i) (H.cic t) || compare premise name then
- {st with context = Cn.clear st.context premise}, script name
- else begin
- assert (Ut.is_sober st.context (H.cic ity));
- let ity = H.acic_bc st.context ity in
- let br1 = [T.Id ""] in
- let br2 = List.rev (T.Exact (w, "assumption") :: script None) in
- let text = "non-linear rewrite" in
- st, [T.Branch ([br2; br1], ""); T.Cut (name, ity, text)]
- end
- | _ -> assert false
-
-let mk_rewrite st dtext where qs tl direction t ity =
- let ppterm t =
- let a = ref "" in Ut.pp_term (fun s -> a := !a ^ s) [] st.context t; !a
- in
- assert (List.length tl = 5);
- let pred, sx, dx = List.nth tl 2, List.nth tl 1, List.nth tl 4 in
- let dtext = if !debug then dtext ^ ppterm (H.cic pred) else dtext in
- let e = Cn.mk_pattern 1 ity pred in
- let script = [T.Branch (qs, "")] in
- if Cn.does_not_occur e then script else
- if st.cr && are_convertible st pred sx dx then
- let dtext = "convertible rewrite" ^ dtext in
- let ity, ety, e = Cn.beta sx pred, Cn.beta dx pred, Cn.hole "" in
- let city, cety = H.cic ity, H.cic ety in
- if H.alpha ~flatten:true st.context city cety then script else
- T.Change (ity, ety, None, e, dtext) :: script
- else
- T.Rewrite (direction, where, None, e, dtext) :: script
-
-let rec proc_lambda st what name v t =
- let dtext = if !debug then CicPp.ppcontext st.context else "" in
- let name = match name with
- | C.Anonymous -> H.mk_fresh_name true st.context anonymous_premise
- | name -> name
- in
- let entry = Some (name, C.Decl (H.cic v)) in
- let intro = get_intro name in
- let script = proc_proof (add st entry) t in
- let script = T.Intros (Some 1, [intro], dtext) :: script in
- mk_preamble st what script
-
-and proc_letin st what name v w t =
- let intro = get_intro name in
- let proceed, dtext = test_depth st in
- let script = if proceed then
- let st, hyp, rqv = match get_inner_types st what, get_inner_types st v with
- | Some (C.ALetIn (_, _, iv, iw, _), _), _ when
- H.alpha ~flatten:true st.context (H.cic v) (H.cic iv) &&
- H.alpha ~flatten:true st.context (H.cic w) (H.cic iw)
- ->
- st, C.Def (H.cic v, H.cic w), [T.Intros (Some 1, [intro], dtext)]
- | _, Some (ity, ety) ->
- let st, rqv = match v with
- | C.AAppl (_, hd :: tl) when is_fwd_rewrite_right st hd tl ->
- mk_fwd_rewrite st dtext intro tl true v t ity ety
- | C.AAppl (_, hd :: tl) when is_fwd_rewrite_left st hd tl ->
- mk_fwd_rewrite st dtext intro tl false v t ity ety
- | C.AAppl (_, hd :: tl) ->
- let ty = match get_inner_types st hd with
- | Some (ity, _) -> H.cic ity
- | None -> get_type "TC3" st hd
- in
- let classes, _ = Cl.classify st.context ty in
- let parsno, argsno = List.length classes, List.length tl in
- let decurry = parsno - argsno in
- if decurry <> 0 then begin
-(* FG: we fall back in the cut case *)
- assert (Ut.is_sober st.context (H.cic ety));
- let ety = H.acic_bc st.context ety in
- let qs = [proc_proof (next st) v; [T.Id ""]] in
- st, [T.Branch (qs, ""); T.Cut (intro, ety, dtext)]
- end else
- let names, synth = get_sub_names hd tl, I.S.empty in
- let qs = proc_bkd_proofs (next st) synth names classes tl in
- let hd = mk_lapply_args hd tl classes in
- let qs = [T.Id ""] :: qs in
- st, [T.Branch (qs, ""); T.LApply (intro, hd, dtext)]
- | v ->
- assert (Ut.is_sober st.context (H.cic ety));
- let ety = H.acic_bc st.context ety in
- let qs = [proc_proof (next st) v; [T.Id ""]] in
- st, [T.Branch (qs, ""); T.Cut (intro, ety, dtext)]
- in
- st, C.Decl (H.cic ity), rqv
- | _, None ->
- st, C.Def (H.cic v, H.cic w), [T.LetIn (intro, v, dtext)]
- in
- let entry = Some (name, hyp) in
- let qt = proc_proof (next (add st entry)) t in
- List.rev_append rqv qt
- else
- [T.Exact (what, dtext)]
- in
- mk_preamble st what script
-
-and proc_rel st what =
- let _, dtext = test_depth st in
- let text = "assumption" in
- let script = [T.Exact (what, dtext ^ text)] in
- mk_preamble st what script
-
-and proc_mutconstruct st what =
- let _, dtext = test_depth st in
- let script = [T.Exact (what, dtext)] in
- mk_preamble st what script
-
-and proc_const st what =
- let _, dtext = test_depth st in
- let script = [T.Exact (what, dtext)] in
- mk_preamble st what script
-
-and proc_appl st what hd tl =
- let proceed, dtext = test_depth st in
- let script = if proceed then
- let ty = match get_inner_types st hd with
- | Some (ity, _) -> H.cic ity
- | None -> get_type "TC2" st hd
- in
- let classes, rc = Cl.classify st.context ty in
- let goal_arity, goal = match get_inner_types st what with
- | None -> 0, None
- | Some (ity, _) ->
- snd (PEH.split_with_whd (st.context, H.cic ity)), Some (H.cic ity)
- in
- let parsno, argsno = List.length classes, List.length tl in
- let decurry = parsno - argsno in
- let diff = goal_arity - decurry in
- if diff < 0 then
- let text = Printf.sprintf "partial application: %i" diff in
- prerr_endline ("Procedural 2: " ^ text);
- [T.Exact (what, dtext ^ text)]
- else
- let classes = Cl.adjust st.context tl ?goal classes in
- let rec mk_synth a n =
- if n < 0 then a else mk_synth (I.S.add n a) (pred n)
- in
- let synth = mk_synth I.S.empty decurry in
- let text = if !debug
- then Printf.sprintf "%u %s" parsno (Cl.to_string synth (classes, rc))
- else ""
- in
- let script = List.rev (mk_arg st hd) in
- let tactic b t n = if b then T.Apply (t, n) else T.Exact (t, n) in
- match rc with
- | Some (i, j, uri, tyno) when decurry = 0 ->
- let classes2, tl2, _, where = split2_last classes tl in
- let script2 = List.rev (mk_arg st where) @ script in
- let synth2 = I.S.add 1 synth in
- let names = H.get_ind_names uri tyno in
- let qs = proc_bkd_proofs (next st) synth2 names classes2 tl2 in
- let ity = match get_inner_types st what with
- | Some (ity, _) -> ity
- | None ->
- Cn.fake_annotate "" st.context (get_type "TC3" st what)
- in
- if List.length qs <> List.length names then
- let qs = proc_bkd_proofs (next st) synth [] classes tl in
- let b, hd, qs = mk_apply_args hd tl classes synth qs in
- script @ [tactic b hd (dtext ^ text); T.Branch (qs, "")]
- else if is_rewrite_right st hd then
- script2 @ mk_rewrite st dtext where qs tl2 false what ity
- else if is_rewrite_left st hd then
- script2 @ mk_rewrite st dtext where qs tl2 true what ity
- else
- let predicate = List.nth tl2 (parsno - i) in
- let e = Cn.mk_pattern j ity predicate in
- let using = Some hd in
- script2 @
- [T.Elim (where, using, e, dtext ^ text); T.Branch (qs, "")]
- | _ ->
- let names = get_sub_names hd tl in
- let qs = proc_bkd_proofs (next st) synth names classes tl in
- let b, hd, qs = mk_apply_args hd tl classes synth qs in
- script @ [tactic b hd (dtext ^ text); T.Branch (qs, "")]
- else
- [T.Exact (what, dtext)]
- in
- mk_preamble st what script
-
-and proc_case st what uri tyno u v ts =
- let proceed, dtext = test_depth st in
- let script = if proceed then
- let synth, classes = I.S.empty, Cl.make ts in
- let names = H.get_ind_names uri tyno in
- let qs = proc_bkd_proofs (next st) synth names classes ts in
- let lpsno, _ = H.get_ind_type uri tyno in
- let ps, _ = H.get_ind_parameters st.context (H.cic v) in
- let _, rps = HEL.split_nth lpsno ps in
- let rpsno = List.length rps in
- let ity = match get_inner_types st what with
- | Some (ity, _) -> ity
- | None ->
- Cn.fake_annotate "" st.context (get_type "TC4" st what)
- in
- let e = Cn.mk_pattern rpsno ity u in
- let text = "" in
- let script = List.rev (mk_arg st v) in
- script @ [T.Cases (v, e, dtext ^ text); T.Branch (qs, "")]
- else
- [T.Exact (what, dtext)]
- in
- mk_preamble st what script
-
-and proc_other st what =
- let _, dtext = test_depth st in
- let text = Printf.sprintf "%s: %s" "UNEXPANDED" (string_of_head what) in
- let script = [T.Exact (what, dtext ^ text)] in
- mk_preamble st what script
-
-and proc_proof st t =
- let f st =
-(*
- let xtypes, note = match get_inner_types st t with
- | Some (it, et) -> Some (H.cic it, H.cic et),
- (Printf.sprintf "\nInferred: %s\nExpected: %s"
- (Pp.ppterm (H.cic it)) (Pp.ppterm (H.cic et)))
- | None -> None, "\nNo types"
- in
- let context, clears = Cn.get_clears st.context (H.cic t) xtypes in
- {st with context = context}
-*)
- st
- in
- match t with
- | C.ALambda (_, name, w, t) as what -> proc_lambda (f st) what name w t
- | C.ALetIn (_, name, v, w, t) as what -> proc_letin (f st) what name v w t
- | C.ARel _ as what -> proc_rel (f st) what
- | C.AMutConstruct _ as what -> proc_mutconstruct (f st) what
- | C.AConst _ as what -> proc_const (f st) what
- | C.AAppl (_, hd :: tl) as what -> proc_appl (f st) what hd tl
-(* FG: we deactivate the tactic "cases" because it does not work properly
- | C.AMutCase (_, uri, i, u, v, ts) as what -> proc_case (f st) what uri i u v ts
-*)
- | what -> proc_other (f st) what
-
-and proc_bkd_proofs st synth names classes ts =
-try
- let get_names b = ref (names, if b then push st else st) in
- let get_note f b names =
- match !names with
- | [], st -> f st
- | "" :: tl, st -> names := tl, st; f st
- | hd :: tl, st ->
- let note = case st hd in
- names := tl, inc st;
- if b then T.Note note :: f st else f st
- in
- let _, dtext = test_depth st in
- let aux (inv, _) v =
- if I.overlaps synth inv then None else
- if I.S.is_empty inv then Some (get_note (fun st -> proc_proof st v)) else
- Some (get_note (fun _ -> [T.Exact (v, dtext ^ "dependent")]))
- in
- let ps = T.list_map2_filter aux classes ts in
- let b = List.length ps > 1 in
- let names = get_names b in
- List.rev_map (fun f -> f b names) ps
-
-with Invalid_argument s -> failwith ("A2P.proc_bkd_proofs: " ^ s)
-
-(* initialization ***********************************************************)
-
-let init ~ids_to_inner_sorts ~ids_to_inner_types params context =
- let depth_map x y = match x, y with
- | None, G.IPDepth depth -> Some depth
- | _ -> x
- in
- {
- sorts = ids_to_inner_sorts;
- types = ids_to_inner_types;
- params = params;
- max_depth = List.fold_left depth_map None params;
- depth = 0;
- defaults = not (List.mem G.IPNoDefaults params);
- cr = List.mem G.IPCR params;
- context = context;
- case = []
- }
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type status
-
-val init:
- ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t ->
- ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t ->
- GrafiteAst.inline_param list-> Cic.context -> status
-
-val proc_proof:
- status -> Cic.annterm -> ProceduralTypes.step list
-
-val debug: bool ref
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module UM = UriManager
-module C = Cic
-module D = Deannotate
-module I = CicInspect
-module PEH = ProofEngineHelpers
-
-module H = ProceduralHelpers
-
-type dependences = (I.S.t * bool) list
-
-type conclusion = (int * int * UM.uri * int) option
-
-(* debugging ****************************************************************)
-
-let string_of_entry synth (inverse, b) =
- if I.overlaps synth inverse then begin if b then "CF" else "C" end else
- if I.S.is_empty inverse then "I" else "P"
-
-let to_string synth (classes, rc) =
- let linearize =
- String.concat " " (List.map (string_of_entry synth) classes)
- in
- match rc with
- | None -> linearize
- | Some (i, j, _, _) -> Printf.sprintf "%s %u %u" linearize i j
-
-let out_table b =
- let map i (_, inverse) =
- let map i tl = Printf.sprintf "%2u" i :: tl in
- let iset = String.concat " " (I.S.fold map inverse []) in
- Printf.eprintf "%2u|%s\n" i iset
- in
- Array.iteri map b;
- prerr_newline ()
-
-(* dummy dependences ********************************************************)
-
-let make l =
- let map _ = I.S.empty, false in
- List.rev_map map l
-
-(* classification ***********************************************************)
-
-let classify_conclusion vs =
- let rec get_argsno = function
- | c, C.Appl (t :: vs) ->
- let hd, argsno = get_argsno (c, t) in
- hd, argsno + List.length vs
- | _, t -> t, 0
- in
- let inside i = i > 1 && i <= List.length vs in
- match vs with
- | v0 :: v1 :: _ ->
- let hd0, a0 = get_argsno v0 in
- let hd1, a1 = get_argsno v1 in
- begin match hd0, hd1 with
- | C.Rel i, C.MutInd (u, n, _) when inside i -> Some (i, a0, u, n)
- | _ -> None
- end
- | _ -> None
-
-let classify c t =
-try
- let vs, h = PEH.split_with_whd (c, t) in
- let rc = classify_conclusion vs in
- let map (b, h) (c, v) =
- let _, argsno = PEH.split_with_whd (c, v) in
- let isf = argsno > 0 (* || H.is_sort v *) in
- let iu = H.is_unsafe h (List.hd vs) in
- (I.get_rels_from_premise h v, I.S.empty, isf && iu) :: b, succ h
- in
- let l, h = List.fold_left map ([], 0) vs in
- let b = Array.of_list (List.rev l) in
- let mk_closure b h =
- let map j = if j < h then I.S.union (H.fst3 b.(j)) else H.identity in
- for i = pred h downto 0 do
- let direct, unused, fa = b.(i) in
- b.(i) <- I.S.fold map direct direct, unused, fa
- done; b
- in
- let b = mk_closure b h in
- let rec mk_inverse i direct =
- if I.S.is_empty direct then () else
- let j = I.S.choose direct in
- if j < h then
- let unused, inverse, fa = b.(j) in
- b.(j) <- unused, I.S.add i inverse, fa
- else ();
- mk_inverse i (I.S.remove j direct)
- in
- let map i (direct, _, _) = mk_inverse i direct in
- Array.iteri map b;
-(* out_table b; *)
- let extract (x, y, z) = y, z in
- List.rev_map extract (List.tl (Array.to_list b)), rc
-with Invalid_argument _ -> failwith "Classify.classify"
-
-(* adjusting the inferrable arguments that do not occur in the goal *********)
-
-let adjust c vs ?goal classes =
- let list_xmap2 map l1 l2 =
- let rec aux a = function
- | hd1 :: tl1, hd2 :: tl2 -> aux (map hd1 hd2 :: a) (tl1,tl2)
- | _, l2 -> List.rev_append l2 a
- in
- List.rev (aux [] (l1, l2))
- in
- let map where what (i, b) =
- let what = H.cic what in
- (i, b || not (H.occurs c ~what ~where))
- in
- match goal with
- | None -> classes
- | Some goal -> list_xmap2 (map goal) vs classes
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type dependences = (CicInspect.S.t * bool) list
-
-type conclusion = (int * int * UriManager.uri * int) option
-
-val make: 'a list -> dependences
-
-val classify: Cic.context -> Cic.term -> dependences * conclusion
-
-val adjust: Cic.context -> Cic.annterm list -> ?goal:Cic.term -> dependences -> dependences
-
-val to_string: CicInspect.S.t -> dependences * conclusion -> string
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module C = Cic
-module E = CicEnvironment
-module Un = CicUniv
-module TC = CicTypeChecker
-module UM = UriManager
-module Rd = CicReduction
-module PEH = ProofEngineHelpers
-module PT = PrimitiveTactics
-module DTI = DoubleTypeInference
-
-module H = ProceduralHelpers
-
-(* helpers ******************************************************************)
-
-let rec list_sub start length = function
- | _ :: tl when start > 0 -> list_sub (pred start) length tl
- | hd :: tl when length > 0 -> hd :: list_sub start (pred length) tl
- | _ -> []
-
-(* proof construction *******************************************************)
-
-let iter f k =
- let rec iter_xns k (uri, t) = uri, iter_term k t
- and iter_ms k = function
- | None -> None
- | Some t -> Some (iter_term k t)
- and iter_fix len k (id, name, i, ty, bo) =
- id, name, i, iter_term k ty, iter_term (k + len) bo
- and iter_cofix len k (id, name, ty, bo) =
- id, name, iter_term k ty, iter_term (k + len) bo
- and iter_term k = function
- | C.ASort _ as t -> t
- | C.AImplicit _ as t -> t
- | C.ARel (id, rid, m, b) as t ->
- if m < k then t else f k id rid m b
- | C.AConst (id, uri, xnss) -> C.AConst (id, uri, List.map (iter_xns k) xnss)
- | C.AVar (id, uri, xnss) -> C.AVar (id, uri, List.map (iter_xns k) xnss)
- | C.AMutInd (id, uri, tyno, xnss) -> C.AMutInd (id, uri, tyno, List.map (iter_xns k) xnss)
- | C.AMutConstruct (id, uri, tyno, consno, xnss) -> C.AMutConstruct (id, uri,tyno,consno, List.map (iter_xns k) xnss)
- | C.AMeta (id, i, mss) -> C.AMeta(id, i, List.map (iter_ms k) mss)
- | C.AAppl (id, ts) -> C.AAppl (id, List.map (iter_term k) ts)
- | C.ACast (id, te, ty) -> C.ACast (id, iter_term k te, iter_term k ty)
- | C.AMutCase (id, sp, i, outty, t, pl) -> C.AMutCase (id, sp, i, iter_term k outty, iter_term k t, List.map (iter_term k) pl)
- | C.AProd (id, n, s, t) -> C.AProd (id, n, iter_term k s, iter_term (succ k) t)
- | C.ALambda (id, n, s, t) -> C.ALambda (id, n, iter_term k s, iter_term (succ k) t)
- | C.ALetIn (id, n, ty, s, t) -> C.ALetIn (id, n, iter_term k ty, iter_term k s, iter_term (succ k) t)
- | C.AFix (id, i, fl) -> C.AFix (id, i, List.map (iter_fix (List.length fl) k) fl)
- | C.ACoFix (id, i, fl) -> C.ACoFix (id, i, List.map (iter_cofix (List.length fl) k) fl)
- in
- iter_term k
-
-let lift k n =
- let f _ id rid m b =
- if m + n > 0 then C.ARel (id, rid, m + n, b) else
- begin
- HLog.error (Printf.sprintf "ProceduralConversion.lift: %i %i" m n);
- assert false
- end
- in
- iter f k
-
-let subst k v =
- let f k id rid m b =
- if m = k then lift 1 (pred k) v else C.ARel (id, rid, pred m, b)
- in
- iter f k
-
-let fake_annotate id c =
- let get_binder c m =
- try match List.nth c (pred m) with
- | Some (C.Name s, _) -> s
- | _ -> assert false
- with
- | Invalid_argument _ -> assert false
- in
- let mk_decl n v = Some (n, C.Decl v) in
- let mk_def n v ty = Some (n, C.Def (v, ty)) in
- let mk_fix (name, _, ty, bo) = mk_def (C.Name name) bo ty in
- let mk_cofix (name, ty, bo) = mk_def (C.Name name) bo ty in
- let rec ann_xns c (uri, t) = uri, ann_term c t
- and ann_ms c = function
- | None -> None
- | Some t -> Some (ann_term c t)
- and ann_fix newc c (name, i, ty, bo) =
- id, name, i, ann_term c ty, ann_term (List.rev_append newc c) bo
- and ann_cofix newc c (name, ty, bo) =
- id, name, ann_term c ty, ann_term (List.rev_append newc c) bo
- and ann_term c = function
- | C.Sort sort -> C.ASort (id, sort)
- | C.Implicit ann -> C.AImplicit (id, ann)
- | C.Rel m -> C.ARel (id, id, m, get_binder c m)
- | C.Const (uri, xnss) -> C.AConst (id, uri, List.map (ann_xns c) xnss)
- | C.Var (uri, xnss) -> C.AVar (id, uri, List.map (ann_xns c) xnss)
- | C.MutInd (uri, tyno, xnss) -> C.AMutInd (id, uri, tyno, List.map (ann_xns c) xnss)
- | C.MutConstruct (uri, tyno, consno, xnss) -> C.AMutConstruct (id, uri,tyno,consno, List.map (ann_xns c) xnss)
- | C.Meta (i, mss) -> C.AMeta(id, i, List.map (ann_ms c) mss)
- | C.Appl ts -> C.AAppl (id, List.map (ann_term c) ts)
- | C.Cast (te, ty) -> C.ACast (id, ann_term c te, ann_term c ty)
- | C.MutCase (sp, i, outty, t, pl) -> C.AMutCase (id, sp, i, ann_term c outty, ann_term c t, List.map (ann_term c) pl)
- | C.Prod (n, s, t) -> C.AProd (id, n, ann_term c s, ann_term (mk_decl n s :: c) t)
- | C.Lambda (n, s, t) -> C.ALambda (id, n, ann_term c s, ann_term (mk_decl n s :: c) t)
- | C.LetIn (n, s, ty, t) -> C.ALetIn (id, n, ann_term c s, ann_term c ty, ann_term (mk_def n s ty :: c) t)
- | C.Fix (i, fl) -> C.AFix (id, i, List.map (ann_fix (List.rev_map mk_fix fl) c) fl)
- | C.CoFix (i, fl) -> C.ACoFix (id, i, List.map (ann_cofix (List.rev_map mk_cofix fl) c) fl)
- in
- ann_term c
-
-let mk_arel k = C.ARel ("", "", k, "")
-
-let mk_aappl ts = C.AAppl ("", ts)
-
-let rec clear_absts f n k = function
- | t when n = 0 -> f k t
- | C.ALambda (_, _, _, t) -> clear_absts f (pred n) (succ k) t
- | t ->
- let u = match mk_aappl [lift (succ k) 1 t; mk_arel (succ k)] with
- | C.AAppl (_, [ C.AAppl (id, ts); t]) -> C.AAppl (id, ts @ [t])
- | t -> t
- in
- clear_absts f (pred n) (succ k) u
-
-let hole id = C.AImplicit (id, Some `Hole)
-
-let meta id = C.AImplicit (id, None)
-
-let anon = C.Anonymous
-
-let generalize n =
- let is_meta =
- let map b = function
- | C.AImplicit (_, None) when b -> b
- | _ -> false
- in
- List.fold_left map true
- in
- let rec gen_fix len k (id, name, i, ty, bo) =
- id, name, i, gen_term k ty, gen_term (k + len) bo
- and gen_cofix len k (id, name, ty, bo) =
- id, name, gen_term k ty, gen_term (k + len) bo
- and gen_term k = function
- | C.ASort (id, _)
- | C.AImplicit (id, _)
- | C.AConst (id, _, _)
- | C.AVar (id, _, _)
- | C.AMutInd (id, _, _, _)
- | C.AMutConstruct (id, _, _, _, _)
- | C.AMeta (id, _, _) -> meta id
- | C.ARel (id, _, m, _) ->
- if succ (k - n) <= m && m <= k then hole id else meta id
- | C.AAppl (id, ts) ->
- let ts = List.map (gen_term k) ts in
- if is_meta ts then meta id else C.AAppl (id, ts)
- | C.ACast (id, te, ty) ->
- let te, ty = gen_term k te, gen_term k ty in
- if is_meta [te; ty] then meta id else C.ACast (id, te, ty)
- | C.AMutCase (id, sp, i, outty, t, pl) ->
- let outty, t, pl = gen_term k outty, gen_term k t, List.map (gen_term k) pl in
- if is_meta (outty :: t :: pl) then meta id else hole id (* C.AMutCase (id, sp, i, outty, t, pl) *)
- | C.AProd (id, _, s, t) ->
- let s, t = gen_term k s, gen_term (succ k) t in
- if is_meta [s; t] then meta id else C.AProd (id, anon, s, t)
- | C.ALambda (id, _, s, t) ->
- let s, t = gen_term k s, gen_term (succ k) t in
- if is_meta [s; t] then meta id else C.ALambda (id, anon, s, t)
- | C.ALetIn (id, _, s, ty, t) ->
- let s, ty, t = gen_term k s, gen_term k ty, gen_term (succ k) t in
- if is_meta [s; t] then meta id else C.ALetIn (id, anon, s, ty, t)
- | C.AFix (id, i, fl) -> C.AFix (id, i, List.map (gen_fix (List.length fl) k) fl)
- | C.ACoFix (id, i, fl) -> C.ACoFix (id, i, List.map (gen_cofix (List.length fl) k) fl)
- in
- gen_term
-
-let convert g ity k predicate =
- let rec aux = function
- | C.ALambda (_, _, b, ity), C.ALambda (id, n, u, pred) ->
- C.ALambda (id, n, aux (b, u), aux (ity, pred))
- | C.AProd (_, _, b, ity), C.AProd (id, n, u, pred) ->
- C.AProd (id, n, aux (b, u), aux (ity, pred))
- | C.ALetIn (_, _, a, b, ity), C.ALetIn (id, n, v, u, pred) ->
- C.ALetIn (id, n, aux (a, v), aux (b, u), aux (ity, pred))
- | C.AAppl (_, bs), C.AAppl (id, us) when List.length bs = List.length us ->
- let map b u = aux (b,u) in
- C.AAppl (id, List.map2 map bs us)
- | C.ACast (_, ity, b), C.ACast (id, pred, u) ->
- C.ACast (id, aux (ity, pred), aux (b, u))
- | ity, C.AAppl (_, C.ALambda (_, _, _, pred) :: v :: []) ->
- aux (ity, subst 1 v pred)
- | ity, C.AAppl (id, C.ALambda (_, _, _, pred) :: v :: vs) ->
- aux (ity, C.AAppl (id, subst 1 v pred :: vs))
- | _, pred -> pred
- in
- g k (aux (ity, predicate))
-
-let mk_pattern psno ity predicate =
- clear_absts (convert (generalize psno) ity) psno 0 predicate
-
-let beta v = function
- | C.ALambda (_, _, _, t) -> subst 1 v t
- | _ -> assert false
-
-let get_clears c p xtypes =
- let meta = C.Implicit None in
- let rec aux c names p it et = function
- | [] ->
- List.rev c, List.rev names
- | Some (C.Name name as n, C.Decl v) as hd :: tl ->
- let hd, names, v =
- if DTI.does_not_occur 1 p && DTI.does_not_occur 1 it && DTI.does_not_occur 1 et then
- Some (C.Anonymous, C.Decl v), name :: names, meta
- else
- hd, names, v
- in
- let p = C.Lambda (n, v, p) in
- let it = C.Prod (n, v, it) in
- let et = C.Prod (n, v, et) in
- aux (hd :: c) names p it et tl
- | Some (C.Name name as n, C.Def (v, x)) as hd :: tl ->
- let hd, names, v =
- if DTI.does_not_occur 1 p && DTI.does_not_occur 1 it && DTI.does_not_occur 1 et then
- Some (C.Anonymous, C.Def (v, x)), name :: names, meta
- else
- hd, names, v
- in
- let p = C.LetIn (n, v, x, p) in
- let it = C.LetIn (n, v, x, it) in
- let et = C.LetIn (n, v, x, et) in
- aux (hd :: c) names p it et tl
- | Some (C.Anonymous as n, C.Decl v) as hd :: tl ->
- let p = C.Lambda (n, meta, p) in
- let it = C.Lambda (n, meta, it) in
- let et = C.Lambda (n, meta, et) in
- aux (hd :: c) names p it et tl
- | Some (C.Anonymous as n, C.Def (v, _)) as hd :: tl ->
- let p = C.LetIn (n, meta, meta, p) in
- let it = C.LetIn (n, meta, meta, it) in
- let et = C.LetIn (n, meta, meta, et) in
- aux (hd :: c) names p it et tl
- | None :: tl -> assert false
- in
- match xtypes with
- | Some (it, et) -> aux [] [] p it et c
- | None -> c, []
-
-let clear c hyp =
- let rec aux c = function
- | [] -> List.rev c
- | Some (C.Name name, entry) :: tail when name = hyp ->
- aux (Some (C.Anonymous, entry) :: c) tail
- | entry :: tail -> aux (entry :: c) tail
- in
- aux [] c
-(*
-let elim_inferred_type context goal arg using cpattern =
- let metasenv, ugraph = [], Un.default_ugraph in
- let ety = H.get_type "elim_inferred_type" context using in
- let _splits, args_no = PEH.split_with_whd (context, ety) in
- let _metasenv, _subst, predicate, _arg, actual_args =
- PT.mk_predicate_for_elim
- ~context ~metasenv ~subst:[] ~ugraph ~goal ~arg ~using ~cpattern ~args_no
- in
- let ty = C.Appl (predicate :: actual_args) in
- let upto = List.length actual_args in
- Rd.head_beta_reduce ~delta:false ~upto ty
-*)
-let does_not_occur = function
- | C.AImplicit (_, None) -> true
- | _ -> false
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val meta: Cic.id -> Cic.annterm
-
-val hole: Cic.id -> Cic.annterm
-
-val lift: int -> int -> Cic.annterm -> Cic.annterm
-
-val fake_annotate: Cic.id -> Cic.context -> Cic.term -> Cic.annterm
-
-val mk_pattern: int -> Cic.annterm -> Cic.annterm -> Cic.annterm
-
-val beta: Cic.annterm -> Cic.annterm -> Cic.annterm
-
-val get_clears:
- Cic.context -> Cic.term -> (Cic.term * Cic.term) option ->
- Cic.context * string list
-
-val clear: Cic.context -> string -> Cic.context
-(*
-val elim_inferred_type:
- Cic.context -> Cic.term -> Cic.term -> Cic.term -> Cic.term -> Cic.term
-*)
-val does_not_occur: Cic.annterm -> bool
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module C = Cic
-module Rf = CicRefine
-module Un = CicUniv
-module Pp = CicPp
-module TC = CicTypeChecker
-module PEH = ProofEngineHelpers
-module E = CicEnvironment
-module UM = UriManager
-module D = Deannotate
-module PER = ProofEngineReduction
-module Ut = CicUtil
-module DTI = DoubleTypeInference
-
-(* fresh name generator *****************************************************)
-
-let split name =
- let rec aux i =
- if i <= 0 then assert false else
- let c = name.[pred i] in
- if c >= '0' && c <= '9' then aux (pred i)
- else Str.string_before name i, Str.string_after name i
- in
- let before, after = aux (String.length name) in
- let i = if after = "" then -1 else int_of_string after in
- before, i
-
-let join (s, i) =
- C.Name (if i < 0 then s else s ^ string_of_int i)
-
-let mk_fresh_name context (name, k) =
- let rec aux i = function
- | [] -> name, i
- | Some (C.Name s, _) :: entries ->
- let m, j = split s in
- if m = name && j >= i then aux (succ j) entries else aux i entries
- | _ :: entries -> aux i entries
- in
- join (aux k context)
-
-let mk_fresh_name does_not_occur context = function
- | C.Name s -> mk_fresh_name context (split s)
- | C.Anonymous ->
- if does_not_occur then C.Anonymous
- else mk_fresh_name context (split "LOCAL")
-
-(* helper functions *********************************************************)
-
-let rec list_fold_right_cps g map l a =
- match l with
- | [] -> g a
- | hd :: tl ->
- let h a = map g hd a in
- list_fold_right_cps h map tl a
-
-let rec list_fold_left_cps g map a = function
- | [] -> g a
- | hd :: tl ->
- let h a = list_fold_left_cps g map a tl in
- map h a hd
-
-let rec list_map_cps g map = function
- | [] -> g []
- | hd :: tl ->
- let h hd =
- let g tl = g (hd :: tl) in
- list_map_cps g map tl
- in
- map h hd
-
-let identity x = x
-
-let compose f g x = f (g x)
-
-let fst3 (x, _, _) = x
-
-let refine c t =
- let error e =
- Printf.eprintf "Ref: context: %s\n" (Pp.ppcontext c);
- Printf.eprintf "Ref: term : %s\n" (Pp.ppterm t);
- raise e
- in
- try let t, _, _, _ = Rf.type_of_aux' [] c t Un.default_ugraph in t with
- | Rf.RefineFailure s as e ->
- Printf.eprintf "REFINE FAILURE: %s\n" (Lazy.force s);
- error e
- | e ->
- Printf.eprintf "REFINE ERROR: %s\n" (Printexc.to_string e);
- error e
-
-let get_type msg c t =
- let log s =
- prerr_endline ("TC: " ^ s);
- prerr_endline ("TC: context: " ^ Pp.ppcontext c);
- prerr_string "TC: term : "; Ut.pp_term prerr_string [] c t;
- prerr_newline (); prerr_endline ("TC: location: " ^ msg)
- in
- try let ty, _ = TC.type_of_aux' [] c t Un.default_ugraph in ty with
- | TC.TypeCheckerFailure s as e ->
- log ("failure: " ^ Lazy.force s); raise e
- | TC.AssertFailure s as e ->
- log ("assert : " ^ Lazy.force s); raise e
-
-let get_tail c t =
- match PEH.split_with_whd (c, t) with
- | (_, hd) :: _, _ -> hd
- | _ -> assert false
-
-let is_prop c t =
- match get_tail c (get_type "is_prop" c t) with
- | C.Sort C.Prop -> true
- | C.Sort _ -> false
- | _ -> assert false
-
-let is_proof c t =
- is_prop c (get_type "is_prop" c t)
-
-let is_sort = function
- | C.Sort _ -> true
- | _ -> false
-
-let is_unsafe h (c, t) = true
-
-let is_not_atomic = function
- | C.Sort _
- | C.Rel _
- | C.Const _
- | C.Var _
- | C.MutInd _
- | C.MutConstruct _ -> false
- | _ -> true
-
-let is_atomic t = not (is_not_atomic t)
-
-let get_ind_type uri tyno =
- match E.get_obj Un.default_ugraph uri with
- | C.InductiveDefinition (tys, _, lpsno, _), _ -> lpsno, List.nth tys tyno
- | _ -> assert false
-
-let get_ind_names uri tno =
-try
- let ts = match E.get_obj Un.default_ugraph uri with
- | C.InductiveDefinition (ts, _, _, _), _ -> ts
- | _ -> assert false
- in
- match List.nth ts tno with
- | (_, _, _, cs) -> List.map fst cs
-with Invalid_argument _ -> failwith "get_ind_names"
-
-let get_default_eliminator context uri tyno ty =
- let _, (name, _, _, _) = get_ind_type uri tyno in
- let ext = match get_tail context (get_type "get_def_elim" context ty) with
- | C.Sort C.Prop -> "_ind"
- | C.Sort C.Set -> "_rec"
- | C.Sort (C.CProp _) -> "_rect"
- | C.Sort (C.Type _) -> "_rect"
- | t ->
- Printf.eprintf "CicPPP get_default_eliminator: %s\n" (Pp.ppterm t);
- assert false
- in
- let buri = UM.buri_of_uri uri in
- let uri = UM.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con") in
- C.Const (uri, [])
-
-let get_ind_parameters c t =
- let ty = get_type "get_ind_pars 1" c t in
- let ps = match get_tail c ty with
- | C.MutInd _ -> []
- | C.Appl (C.MutInd _ :: args) -> args
- | _ -> assert false
- in
- let disp = match get_tail c (get_type "get_ind_pars 2" c ty) with
- | C.Sort C.Prop -> 0
- | C.Sort _ -> 1
- | _ -> assert false
- in
- ps, disp
-
-let cic = D.deannotate_term
-
-let flatten_appls =
- let rec flatten_xns (uri, t) = uri, flatten_term t
- and flatten_ms = function
- | None -> None
- | Some t -> Some (flatten_term t)
- and flatten_fix (name, i, ty, bo) =
- name, i, flatten_term ty, flatten_term bo
- and flatten_cofix (name, ty, bo) =
- name, flatten_term ty, flatten_term bo
- and flatten_term = function
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Rel _ as t -> t
- | C.Const (uri, xnss) -> C.Const (uri, List.map flatten_xns xnss)
- | C.Var (uri, xnss) -> C.Var (uri, List.map flatten_xns xnss)
- | C.MutInd (uri, tyno, xnss) -> C.MutInd (uri, tyno, List.map flatten_xns xnss)
- | C.MutConstruct (uri, tyno, consno, xnss) -> C.MutConstruct (uri, tyno, consno, List.map flatten_xns xnss)
- | C.Meta (i, mss) -> C.Meta(i, List.map flatten_ms mss)
-(* begin flattening *)
- | C.Appl [t] -> flatten_term t
- | C.Appl (C.Appl ts1 :: ts2) -> flatten_term (C.Appl (ts1 @ ts2))
- | C.Appl [] -> assert false
-(* end flattening *)
- | C.Appl ts -> C.Appl (List.map flatten_term ts)
- | C.Cast (te, ty) -> C.Cast (flatten_term te, flatten_term ty)
- | C.MutCase (sp, i, outty, t, pl) -> C.MutCase (sp, i, flatten_term outty, flatten_term t, List.map flatten_term pl)
- | C.Prod (n, s, t) -> C.Prod (n, flatten_term s, flatten_term t)
- | C.Lambda (n, s, t) -> C.Lambda (n, flatten_term s, flatten_term t)
- | C.LetIn (n, ty, s, t) -> C.LetIn (n, flatten_term ty, flatten_term s, flatten_term t)
- | C.Fix (i, fl) -> C.Fix (i, List.map flatten_fix fl)
- | C.CoFix (i, fl) -> C.CoFix (i, List.map flatten_cofix fl)
- in
- flatten_term
-
-let sober ?(flatten=false) c t =
- if flatten then flatten_appls t else (assert (Ut.is_sober c t); t)
-
-let alpha ?flatten c t1 t2 =
- let t1 = sober ?flatten c t1 in
- let t2 = sober ?flatten c t2 in
- Ut.alpha_equivalence t1 t2
-
-let occurs c ~what ~where =
- let result = ref false in
- let equality c t1 t2 =
- let r = alpha ~flatten:true c t1 t2 in
- result := !result || r; r
- in
- let context, what, with_what = c, [what], [C.Rel 0] in
- let _ = PER.replace_lifting ~equality ~context ~what ~with_what ~where in
- !result
-
-let name_of_uri uri tyno cno =
- let get_ind_type tys tyno =
- let s, _, _, cs = List.nth tys tyno in s, cs
- in
- match (fst (E.get_obj Un.default_ugraph uri)), tyno, cno with
- | C.Variable (s, _, _, _, _), _, _ -> s
- | C.Constant (s, _, _, _, _), _, _ -> s
- | C.InductiveDefinition (tys, _, _, _), Some i, None ->
- let s, _ = get_ind_type tys i in s
- | C.InductiveDefinition (tys, _, _, _), Some i, Some j ->
- let _, cs = get_ind_type tys i in
- let s, _ = List.nth cs (pred j) in s
- | _ -> assert false
-
-(* Ensuring Barendregt convenction ******************************************)
-
-let rec add_entries map c = function
- | [] -> c
- | hd :: tl ->
- let sname, w = map hd in
- let entry = Some (C.Name sname, C.Decl w) in
- add_entries map (entry :: c) tl
-
-let get_sname c i =
- try match List.nth c (pred i) with
- | Some (C.Name sname, _) -> sname
- | _ -> assert false
- with
- | Failure _ -> assert false
- | Invalid_argument _ -> assert false
-
-let cic_bc c t =
- let get_fix_decl (sname, i, w, v) = sname, w in
- let get_cofix_decl (sname, w, v) = sname, w in
- let rec bc c = function
- | C.LetIn (name, v, ty, t) ->
- let dno = DTI.does_not_occur 1 t in
- let name = mk_fresh_name dno c name in
- let entry = Some (name, C.Def (v, ty)) in
- let v, ty, t = bc c v, bc c ty, bc (entry :: c) t in
- C.LetIn (name, v, ty, t)
- | C.Lambda (name, w, t) ->
- let dno = DTI.does_not_occur 1 t in
- let name = mk_fresh_name dno c name in
- let entry = Some (name, C.Decl w) in
- let w, t = bc c w, bc (entry :: c) t in
- C.Lambda (name, w, t)
- | C.Prod (name, w, t) ->
- let dno = DTI.does_not_occur 1 t in
- let name = mk_fresh_name dno c name in
- let entry = Some (name, C.Decl w) in
- let w, t = bc c w, bc (entry :: c) t in
- C.Prod (name, w, t)
- | C.Appl vs ->
- let vs = List.map (bc c) vs in
- C.Appl vs
- | C.MutCase (uri, tyno, u, v, ts) ->
- let u, v, ts = bc c u, bc c v, List.map (bc c) ts in
- C.MutCase (uri, tyno, u, v, ts)
- | C.Cast (t, u) ->
- let t, u = bc c t, bc c u in
- C.Cast (t, u)
- | C.Fix (i, fixes) ->
- let d = add_entries get_fix_decl c fixes in
- let bc_fix (sname, i, w, v) = (sname, i, bc c w, bc d v) in
- let fixes = List.map bc_fix fixes in
- C.Fix (i, fixes)
- | C.CoFix (i, cofixes) ->
- let d = add_entries get_cofix_decl c cofixes in
- let bc_cofix (sname, w, v) = (sname, bc c w, bc d v) in
- let cofixes = List.map bc_cofix cofixes in
- C.CoFix (i, cofixes)
- | t -> t
- in
- bc c t
-
-let acic_bc c t =
- let get_fix_decl (id, sname, i, w, v) = sname, cic w in
- let get_cofix_decl (id, sname, w, v) = sname, cic w in
- let rec bc c = function
- | C.ALetIn (id, name, v, ty, t) ->
- let dno = DTI.does_not_occur 1 (cic t) in
- let name = mk_fresh_name dno c name in
- let entry = Some (name, C.Def (cic v, cic ty)) in
- let v, ty, t = bc c v, bc c ty, bc (entry :: c) t in
- C.ALetIn (id, name, v, ty, t)
- | C.ALambda (id, name, w, t) ->
- let dno = DTI.does_not_occur 1 (cic t) in
- let name = mk_fresh_name dno c name in
- let entry = Some (name, C.Decl (cic w)) in
- let w, t = bc c w, bc (entry :: c) t in
- C.ALambda (id, name, w, t)
- | C.AProd (id, name, w, t) ->
- let dno = DTI.does_not_occur 1 (cic t) in
- let name = mk_fresh_name dno c name in
- let entry = Some (name, C.Decl (cic w)) in
- let w, t = bc c w, bc (entry :: c) t in
- C.AProd (id, name, w, t)
- | C.AAppl (id, vs) ->
- let vs = List.map (bc c) vs in
- C.AAppl (id, vs)
- | C.AMutCase (id, uri, tyno, u, v, ts) ->
- let u, v, ts = bc c u, bc c v, List.map (bc c) ts in
- C.AMutCase (id, uri, tyno, u, v, ts)
- | C.ACast (id, t, u) ->
- let t, u = bc c t, bc c u in
- C.ACast (id, t, u)
- | C.AFix (id, i, fixes) ->
- let d = add_entries get_fix_decl c fixes in
- let bc_fix (id, sname, i, w, v) = (id, sname, i, bc c w, bc d v) in
- let fixes = List.map bc_fix fixes in
- C.AFix (id, i, fixes)
- | C.ACoFix (id, i, cofixes) ->
- let d = add_entries get_cofix_decl c cofixes in
- let bc_cofix (id, sname, w, v) = (id, sname, bc c w, bc d v) in
- let cofixes = List.map bc_cofix cofixes in
- C.ACoFix (id, i, cofixes)
- | C.ARel (id1, id2, i, sname) ->
- let sname = get_sname c i in
- C.ARel (id1, id2, i, sname)
- | t -> t
- in
- bc c t
-
-let is_acic_proof sorts context v =
- let id = Ut.id_of_annterm v in
- try match Hashtbl.find sorts id with
- | `Prop -> true
- | _ -> false
- with Not_found -> is_proof context (cic v)
-
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val mk_fresh_name:
- bool -> Cic.context -> Cic.name -> Cic.name
-
-val list_fold_right_cps:
- ('b -> 'c) -> (('b -> 'c) -> 'a -> 'b -> 'c) -> 'a list -> 'b -> 'c
-
-val list_fold_left_cps:
- ('b -> 'c) -> (('b -> 'c) -> 'b -> 'a -> 'c) -> 'b -> 'a list -> 'c
-
-val list_map_cps:
- ('b list -> 'c) -> (('b -> 'c) -> 'a -> 'c) -> 'a list -> 'c
-
-val identity:
- 'a -> 'a
-
-val compose:
- ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
-
-val fst3:
- 'a * 'b * 'c -> 'a
-
-val refine:
- Cic.context -> Cic.term -> Cic.term
-
-val get_type:
- string -> Cic.context -> Cic.term -> Cic.term
-
-val is_prop:
- Cic.context -> Cic.term -> bool
-
-val is_proof:
- Cic.context -> Cic.term -> bool
-
-val is_sort:
- Cic.term -> bool
-
-val is_unsafe:
- int -> Cic.context * Cic.term -> bool
-
-val is_not_atomic:
- Cic.term -> bool
-
-val is_atomic:
- Cic.term -> bool
-
-val get_ind_type:
- UriManager.uri -> int -> int * Cic.inductiveType
-
-val get_ind_names:
- UriManager.uri -> int -> string list
-
-val get_default_eliminator:
- Cic.context -> UriManager.uri -> int -> Cic.term -> Cic.term
-
-val get_ind_parameters:
- Cic.context -> Cic.term -> Cic.term list * int
-
-val cic:
- Cic.annterm -> Cic.term
-
-val occurs:
- Cic.context -> what:Cic.term -> where:Cic.term -> bool
-
-val name_of_uri:
- UriManager.uri -> int option -> int option -> string
-
-val cic_bc:
- Cic.context -> Cic.term -> Cic.term
-
-val acic_bc:
- Cic.context -> Cic.annterm -> Cic.annterm
-
-val is_acic_proof:
- (Cic.id, Cic2acic.sort_kind) Hashtbl.t -> Cic.context -> Cic.annterm ->
- bool
-
-val alpha:
- ?flatten:bool -> Cic.context -> Cic.term -> Cic.term -> bool
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module C = Cic
-module PEH = ProofEngineHelpers
-
-module Cl = ProceduralClassify
-
-let is_eliminator = function
- | _ :: (_, C.MutInd _) :: _ -> true
- | _ :: (_, C.Appl (C.MutInd _ :: _)) :: _ -> true
- | _ -> false
-
-let is_const = function
- | C.Sort _
- | C.Const _
- | C.Var _
- | C.MutInd _
- | C.MutConstruct _ -> true
- | _ -> false
-
-let rec is_appl b = function
- | C.Appl (hd :: tl) -> List.fold_left is_appl (is_const hd) tl
- | t when is_const t -> b
- | C.Rel _ -> b
- | _ -> false
-
-let bkd c t =
- let classes, rc = Cl.classify c t in
- let premises, _ = PEH.split_with_whd (c, t) in
- match rc with
- | Some (i, j, _, _) when i > 1 && i <= List.length classes && is_eliminator premises -> true
- | _ ->
- let _, conclusion = List.hd premises in
- is_appl true conclusion
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-(*
-val is_eliminator: (Cic.context * Cic.term) list -> bool
-
-val bkd: Cic.context -> Cic.term -> bool
-*)
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module UM = UriManager
-module C = Cic
-module Pp = CicPp
-module I = CicInspect
-module E = CicEnvironment
-module S = CicSubstitution
-module DTI = DoubleTypeInference
-module HEL = HExtlib
-module PEH = ProofEngineHelpers
-module TC = CicTypeChecker
-module Un = CicUniv
-module L = Librarian
-module Ut = CicUtil
-
-module H = ProceduralHelpers
-module Cl = ProceduralClassify
-
-(* debugging ****************************************************************)
-
-let debug = ref false
-
-(* term optimization ********************************************************)
-
-let critical = ref true
-
-type status = {
- dummy: unit;
- info: string
-}
-
-let info st str = {st with info = st.info ^ str ^ "\n"}
-
-let defined_premise = "LOCAL"
-
-let define c v =
- let name = C.Name defined_premise in
- let ty = H.get_type "define" c v in
- C.LetIn (name, v, ty, C.Rel 1)
-
-let clear_absts m =
- let rec aux k n = function
- | C.Lambda (s, v, t) when k > 0 ->
- C.Lambda (s, v, aux (pred k) n t)
- | C.Lambda (_, _, t) when n > 0 ->
- aux 0 (pred n) (S.lift (-1) t)
- | t when n > 0 ->
- Printf.eprintf "PO.clear_absts: %u %s\n" n (Pp.ppterm t);
- assert false
- | t -> t
- in
- aux m
-
-let rec add_abst k = function
- | C.Lambda (s, v, t) when k > 0 -> C.Lambda (s, v, add_abst (pred k) t)
- | t when k > 0 -> assert false
- | t -> C.Lambda (C.Anonymous, C.Implicit None, S.lift 1 t)
-
-let rec opt_letin g st es c name v w t =
- let name = H.mk_fresh_name true c name in
- let entry = Some (name, C.Def (v, w)) in
- let g st t =
- if DTI.does_not_occur 1 t then
- let x = S.lift (-1) t in
- opt_proof g (info st "Optimizer: remove 1") true c x
- else
- let g st = function
- | C.LetIn (nname, vv, ww, tt) when H.is_proof c v ->
- let eentry = Some (nname, C.Def (vv, ww)) in
- let ttw = H.get_type "opt_letin 1" (eentry :: c) tt in
- let x = C.LetIn (nname, vv, ww,
- C.LetIn (name, tt, ttw, S.lift_from 2 1 t))
- in
- opt_proof g (info st "Optimizer: swap 1") true c x
- | v when H.is_proof c v && H.is_atomic v ->
- let x = S.subst v t in
- opt_proof g (info st "Optimizer: remove 5") true c x
-(* | v when t = C.Rel 1 ->
- g (info st "Optimizer: remove 6") v
-*) | v ->
- g st (C.LetIn (name, v, w, t))
- in
- if es then opt_term g st es c v else g st v
- in
- if es then opt_proof g st es (entry :: c) t else g st t
-
-and opt_lambda g st es c name w t =
- let name = H.mk_fresh_name true c name in
- let entry = Some (name, C.Decl w) in
- let g st t = g st (C.Lambda (name, w, t)) in
- if es then opt_proof g st es (entry :: c) t else g st t
-
-and opt_appl g st es c t vs =
- let g (st, vs) =
- let g st = function
- | C.LetIn (mame, vv, tyty, tt) ->
- let vs = List.map (S.lift 1) vs in
- let x = C.LetIn (mame, vv, tyty, C.Appl (tt :: vs)) in
- opt_proof g (info st "Optimizer: swap 2") true c x
- | C.Lambda (name, ww, tt) ->
- let v, vs = List.hd vs, List.tl vs in
- let w = H.get_type "opt_appl 1" c v in
- let x = C.Appl (C.LetIn (name, v, w, tt) :: vs) in
- opt_proof g (info st "Optimizer: remove 2") true c x
- | C.Appl vvs ->
- let x = C.Appl (vvs @ vs) in
- opt_proof g (info st "Optimizer: nested application") true c x
- | t ->
-(*
- let rec aux st d rvs = function
- | [], _ ->
- let x = C.Appl (t :: List.rev rvs) in
- if d then opt_proof g st true c x else g st x
- | v :: vs, (cc, bb) :: cs ->
- if H.is_not_atomic v && I.S.mem 0 cc && bb then
- aux (st info "Optimizer: anticipate 1") true
- (define c v :: rvs) (vs, cs)
- else
- aux st d (v :: rvs) (vs, cs)
- | _, [] -> assert false
- in
-*)
- let h st =
- let classes, conclusion = Cl.classify c (H.get_type "opt_appl 3" c t) in
- let csno, vsno = List.length classes, List.length vs in
- if csno < vsno then
- let vvs, vs = HEL.split_nth csno vs in
- let x = C.Appl (define c (C.Appl (t :: vvs)) :: vs) in
- opt_proof g (info st "Optimizer: anticipate 2") true c x
- else match conclusion, List.rev vs with
- | Some _, rv :: rvs when csno = vsno && H.is_not_atomic rv ->
- let x = C.Appl (t :: List.rev rvs @ [define c rv]) in
- opt_proof g (info st "Optimizer: anticipate 3";) true c x
- | _ (* Some _, _ *) ->
- g st (C.Appl (t :: vs))
-(* | None, _ ->
- aux false [] (vs, classes)
-*) in
- let rec aux h st prev = function
- | C.LetIn (name, vv, tyty, tt) :: vs ->
- let t = S.lift 1 t in
- let prev = List.map (S.lift 1) prev in
- let vs = List.map (S.lift 1) vs in
- let y = C.Appl (t :: List.rev prev @ tt :: vs) in
- let ww = H.get_type "opt_appl 2" c vv in
- let x = C.LetIn (name, vv, ww, y) in
- opt_proof g (info st "Optimizer: swap 3") true c x
- | v :: vs -> aux h st (v :: prev) vs
- | [] -> h st
- in
- aux h st [] vs
- in
- if es then opt_proof g st es c t else g st t
- in
- let map h v (st, vs) =
- let h st vv = h (st, vv :: vs) in opt_term h st es c v
- in
- if es then H.list_fold_right_cps g map vs (st, []) else g (st, vs)
-
-and opt_mutcase_critical g st es c uri tyno outty arg cases =
- let eliminator = H.get_default_eliminator c uri tyno outty in
- let lpsno, (_, _, _, constructors) = H.get_ind_type uri tyno in
- let ps, sort_disp = H.get_ind_parameters c arg in
- let lps, rps = HEL.split_nth lpsno ps in
- let rpsno = List.length rps in
- if rpsno = 0 && sort_disp = 0 then
-(* FG: the transformation is not possible, we fall back into the plain case *)
- opt_mutcase_plain g st es c uri tyno outty arg cases
- else
- let predicate = clear_absts rpsno (1 - sort_disp) outty in
- if H.occurs c ~what:(C.Rel 0) ~where:predicate then
-(* FG: the transformation is not possible, we fall back into the plain case *)
- opt_mutcase_plain g st es c uri tyno outty arg cases
- else
- let is_recursive t =
- I.S.mem tyno (I.get_mutinds_of_uri uri t)
- in
- let map2 case (_, cty) =
- let map (h, case, k) (_, premise) =
- if h > 0 then pred h, case, k else
- if is_recursive premise then
- 0, add_abst k case, k + 2
- else
- 0, case, succ k
- in
- let premises, _ = PEH.split_with_whd (c, cty) in
- let _, lifted_case, _ =
- List.fold_left map (lpsno, case, 1) (List.rev (List.tl premises))
- in
- lifted_case
- in
- let lifted_cases = List.map2 map2 cases constructors in
- let args = eliminator :: lps @ predicate :: lifted_cases @ rps @ [arg] in
- try
- let x = H.refine c (C.Appl args) in
- opt_proof g (info st "Optimizer: remove 3") es c x
- with e ->
-(* FG: the transformation is not possible, we fall back into the plain case *)
- let st = info st ("Optimizer: refine_error: " ^ Printexc.to_string e) in
- opt_mutcase_plain g st es c uri tyno outty arg cases
-
-and opt_mutcase_plain g st es c uri tyno outty arg cases =
- let g st v =
- let g (st, ts) = g st (C.MutCase (uri, tyno, outty, v, ts)) in
- let map h v (st, vs) =
- let h st vv = h (st, vv :: vs) in opt_proof h st es c v
- in
- if es then H.list_fold_right_cps g map cases (st, []) else g (st, cases)
- in
- if es then opt_proof g st es c arg else g st arg
-
-and opt_mutcase g =
- if !critical then opt_mutcase_critical g else opt_mutcase_plain g
-
-and opt_cast g st es c t w =
- let g st t = g (info st "Optimizer: remove 4") t in
- if es then opt_proof g st es c t else g st t
-
-and opt_other g st es c t = g st t
-
-and opt_proof g st es c = function
- | C.LetIn (name, v, ty, t) -> opt_letin g st es c name v ty t
- | C.Lambda (name, w, t) -> opt_lambda g st es c name w t
- | C.Appl (t :: v :: vs) -> opt_appl g st es c t (v :: vs)
- | C.Appl [t] -> opt_proof g st es c t
- | C.MutCase (u, n, t, v, ws) -> opt_mutcase g st es c u n t v ws
- | C.Cast (t, w) -> opt_cast g st es c t w
- | t -> opt_other g st es c t
-
-and opt_term g st es c t =
- if H.is_proof c t then opt_proof g st es c t else g st t
-
-(* object optimization ******************************************************)
-
-let wrap g st c bo =
- try opt_term g st true c bo
- with
- | E.Object_not_found uri ->
- let msg = "optimize_obj: object not found: " ^ UM.string_of_uri uri in
- failwith msg
- | e ->
- let msg = "optimize_obj: " ^ Printexc.to_string e in
- failwith msg
-
-let optimize_obj = function
- | C.Constant (name, Some bo, ty, pars, attrs) ->
- let count_nodes = I.count_nodes ~meta:false 0 in
- let st, c = {info = ""; dummy = ()}, [] in
- L.time_stamp ("PO: OPTIMIZING " ^ name);
- let nodes = Printf.sprintf "Initial nodes: %u" (count_nodes bo) in
- if !debug then begin
- Printf.eprintf "BEGIN: %s\n" name;
- Printf.eprintf "Initial : %s\n" (Pp.ppterm bo);
- prerr_string "Ut.pp_term : ";
- Ut.pp_term prerr_string [] c bo; prerr_newline ()
- end;
- let bo, ty = H.cic_bc c bo, H.cic_bc c ty in
- let g st bo =
- if !debug then begin
- Printf.eprintf "Optimized : %s\n" (Pp.ppterm bo);
- prerr_string "Ut.pp_term : ";
- Ut.pp_term prerr_string [] c bo; prerr_newline ()
- end;
-(* let _ = H.get_type "opt" [] (C.Cast (bo, ty)) in *)
- let nodes = Printf.sprintf "Optimized nodes: %u" (count_nodes bo) in
- let st = info st nodes in
- L.time_stamp ("PO: DONE " ^ name);
- C.Constant (name, Some bo, ty, pars, attrs), st.info
- in
- wrap g (info st nodes) c bo
- | obj -> obj, ""
-
-let optimize_term c bo =
- let st = {info = ""; dummy = ()} in
- let bo = H.cic_bc c bo in
- let g st bo = bo, st.info in
- wrap g st c bo
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val optimize_obj: Cic.obj -> Cic.obj * string
-
-val optimize_term: Cic.context -> Cic.term -> Cic.term * string
-
-val critical: bool ref
-
-val debug: bool ref
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module F = Format
-module C = Cic
-module DTI = DoubleTypeInference
-module H = ProceduralHelpers
-module T = ProceduralTypes
-
-type sorts = (Cic.id, Cic2acic.sort_kind) Hashtbl.t
-
-let num n =
- if n < 2 then "" else
- if n < 27 then String.make 1 (Char.chr (n - 2 + Char.code 'b')) else
- assert false
-
-let quote str =
- Pcre.replace ~pat:"_" ~templ:"\\_" str
-
-let xn frm = function
- | C.Anonymous -> assert false
- | C.Name r -> F.fprintf frm "%s" (quote r)
-
-let xr c frm j =
- try match List.nth c (pred j) with
- | Some (r, _) -> xn frm r
- | None -> assert false
- with Invalid_argument "nth" -> assert false
-
-let xs frm = function
- | C.Set -> F.fprintf frm "\\Set"
- | C.Prop -> F.fprintf frm "\\Prop"
- | C.CProp _ -> F.fprintf frm "\\CProp"
- | C.Type _ -> F.fprintf frm "\\Type"
-
-let rec xt c frm = function
- | C.Sort s ->
- xs frm s
- | C.Const (i, []) ->
- F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i None None))
- | C.MutInd (i, n, []) ->
- F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) None))
- | C.MutConstruct (i, n, m, []) ->
- F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) (Some m)))
- | C.Rel j ->
- F.fprintf frm "\\LRef{%a}" (xr c) j
- | C.Cast (t, u) ->
- F.fprintf frm "\\Cast{%a}{%a}" (xt c) u (xt c) t
- | C.Appl (t :: vs) ->
- let z = num (List.length vs) in
- F.fprintf frm "\\%sAppl%a{%a}" z (xts c) vs (xt c) t
- | C.MutCase (_, _, u, v, ts) ->
- let z = num (List.length ts) in
- F.fprintf frm "\\%sCase{%a}{%a}%a" z (xt c) u (xt c) v (xts c) ts
- | C.LetIn (r, v, w, t) ->
- let d = Some (r, C.Def (v, w)) :: c in
- F.fprintf frm "\\Abbr{%a}{%a}{%a}" xn r (xt c) v (xt d) t
- | C.Lambda (r, w, t) ->
- let d = Some (r, C.Decl w) :: c in
- if DTI.does_not_occur 1 t then
- F.fprintf frm "\\CFun{%a}{%a}" (xt c) w (xt d) t
- else
- F.fprintf frm "\\Abst{%a}{%a}{%a}" xn r (xt c) w (xt d) t
- | C.Prod (r, w, t) ->
- let d = Some (r, C.Decl w) :: c in
- if DTI.does_not_occur 1 t then
- F.fprintf frm "\\LImp{%a}{%a}" (xt c) w (xt d) t
- else if H.is_prop d t then
- F.fprintf frm "\\LAll{%a}{%a}{%a}" xn r (xt c) w (xt d) t
- else
- F.fprintf frm "\\Prod{%a}{%a}{%a}" xn r (xt c) w (xt d) t
- | C.Const _ -> assert false
- | C.MutInd _ -> assert false
- | C.MutConstruct _ -> assert false
- | C.Var _ -> assert false
- | C.Fix _ -> assert false
- | C.CoFix _ -> assert false
- | C.Meta _ -> assert false
- | C.Implicit _ -> assert false
- | C.Appl [] -> assert false
-
-and xts c frm vs =
- let map v = F.fprintf frm "{%a}" (xt c) v in
- List.iter map vs
-
-let tex_of_term frm c t = xt c frm t
-
-let tex_of_obj frm = function
- | C.InductiveDefinition (_, [], _, _) -> ()
- | C.Constant (_, None, _, [], _) -> ()
- | C.Constant (_, Some t, _, [], _) ->
- F.fprintf frm "%a@\n" (xt []) t
- | C.Constant _ -> assert false
- | C.InductiveDefinition _ -> assert false
- | C.Variable _ -> assert false
- | C.CurrentProof _ -> assert false
-
-let is_prop sorts id =
- try match Hashtbl.find sorts id with
- | `Prop -> true
- | _ -> false
- with Not_found -> false
-
-let tex_of_annterm frm sorts t =
-
-let rec xat frm = function
- | C.ASort (_, s) ->
- xs frm s
- | C.AConst (_ ,i, []) ->
- F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i None None))
- | C.AMutInd (_, i, n, []) ->
- F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) None))
- | C.AMutConstruct (_, i, n, m, []) ->
- F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) (Some m)))
- | C.ARel (_,_, _, r) ->
- F.fprintf frm "\\LRef{%s}" (quote r)
- | C.ACast (_, t, u) ->
- F.fprintf frm "\\Cast{%a}{%a}" xat u xat t
- | C.AAppl (_, t :: vs) ->
- let z = num (List.length vs) in
- F.fprintf frm "\\%sAppl%a{%a}" z xats vs xat t
- | C.AMutCase (_, _, _, u, v, ts) ->
- let z = num (List.length ts) in
- F.fprintf frm "\\%sCase{%a}{%a}%a" z xat u xat v xats ts
- | C.ALetIn (_, r, v, w, t) ->
- F.fprintf frm "\\Abbr{%a}{%a}{%a}" xn r xat v xat t
- | C.ALambda (_, r, w, t) ->
- if DTI.does_not_occur 1 (H.cic t) then
- F.fprintf frm "\\CFun{%a}{%a}" xat w xat t
- else
- F.fprintf frm "\\Abst{%a}{%a}{%a}" xn r xat w xat t
- | C.AProd (id, r, w, t) ->
- if DTI.does_not_occur 1 (H.cic t) then
- F.fprintf frm "\\LImp{%a}{%a}" xat w xat t
- else if true then
- F.fprintf frm "\\LAll{%a}{%a}{%a}" xn r xat w xat t
- else
- F.fprintf frm "\\Prod{%a}{%a}{%a}" xn r xat w xat t
- | C.AConst _ -> assert false
- | C.AMutInd _ -> assert false
- | C.AMutConstruct _ -> assert false
- | C.AVar _ -> assert false
- | C.AFix _ -> assert false
- | C.ACoFix _ -> assert false
- | C.AMeta _ -> assert false
- | C.AImplicit _ -> assert false
- | C.AAppl (_, []) -> assert false
-
-and xats frm = function
- | [] -> F.fprintf frm "{}"
- | vs ->
- let map v = F.fprintf frm "{%a}" xat v in
- List.iter map vs
-
-in
-xat frm t
-
-let xx frm = function
- | None -> assert false
- | Some r -> F.fprintf frm "%s" (quote r)
-
-let xh how =
- if how then "\\dx" else "\\sx"
-
-let tex_of_steps frm sorts l =
-
-let xat frm t = tex_of_annterm frm sorts t in
-
-let rec xl frm = function
- | [] -> ()
- | T.Note _ :: l
- | T.Statement _ :: l
- | T.Qed _ :: l ->
- xl frm l
- | T.Reflexivity _ :: l ->
- F.fprintf frm "\\Reflexivity"; xl frm l
- | T.Exact (t, _) :: l ->
- F.fprintf frm "\\Exact{%a}" xat t; xl frm l
- | T.Intros (_, [r], _) :: l ->
- F.fprintf frm "\\Intro{%a}{%a}" xx r xl l
- | T.LetIn (r, v, _) :: l ->
- F.fprintf frm "\\Pose{%a}{%a}{%a}" xx r xat v xl l
- | T.LApply (r, v, _) :: l ->
- F.fprintf frm "\\LApply{%a}{%a}{%a}" xx r xat v xl l
- | T.Change (u, _, None, _, _) :: l ->
- F.fprintf frm "\\Change{%a}{}{%a}" xat u xl l
- | T.Change (u, _, Some (s, _), _, _) :: l ->
- F.fprintf frm "\\Change{%a}{%s}{%a}" xat u (quote s) xl l
- | T.Rewrite (b, t, None, _, _) :: l ->
- F.fprintf frm "\\Rewrite{%s}{%a}{}{}{%a}" (xh b) xat t xl l
- | T.Rewrite (b, t, Some (s1, Some s2), _, _) :: l ->
- F.fprintf frm "\\Rewrite{%s}{%a}{%s}{%s}{%a}"
- (xh b) xat t (quote s1) (quote s2) xl l
- | T.Rewrite (b, t, Some (s1, None), _, _) :: l ->
- F.fprintf frm "\\Rewrite{%s}{%a}{%s}{%s}{%a}"
- (xh b) xat t (quote s1) (quote s1) xl l
- | T.Apply (t, _) :: T.Branch (ls, _) :: l ->
- let z = num (List.length ls) in
- F.fprintf frm "\\%sApply{%a}%a" z xat t xls ls; xl frm l
- | T.Apply (t, _) :: l ->
- F.fprintf frm "\\Apply{%a}{%a}" xat t xl l
- | T.Cases (v, _, _) :: T.Branch (ls, _) :: l ->
- let z = num (List.length ls) in
- F.fprintf frm "\\%sCases{%a}%a" z xat v xls ls; xl frm l
- | T.Cases (v, _, _) :: l ->
- F.fprintf frm "\\Cases{%a}{%a}" xat v xl l
- | T.Elim (v, Some t, _, _) :: T.Branch (ls, _) :: l ->
- let z = num (List.length ls) in
- F.fprintf frm "\\%sElim{%a}{%a}{}{}%a" z xat v xat t xls ls; xl frm l
- | T.Elim (v, Some t, _, _) :: l ->
- F.fprintf frm "\\Elim{%a}{%a}{}{}{%a}" xat v xat t xl l
- | T.Cut (r, w, _) :: T.Branch ([l1; [T.Id _]], _) :: l2 ->
- F.fprintf frm "\\Cut{%a}{%a}{%a}{%a}" xx r xat w xl l1 xl l2
- | T.Record _ :: _ -> assert false
- | T.Inductive _ :: _ -> assert false
- | T.Id _ :: _ -> assert false
- | T.Clear _ :: _ -> assert false
- | T.ClearBody _ :: _ -> assert false
- | T.Branch _ :: _ -> assert false
- | T.Intros _ :: _ -> assert false
- | T.Elim _ :: _ -> assert false
- | T.Cut _ :: _ -> assert false
-
-and xls frm = function
- | [] -> F.fprintf frm "{}"
- | ls ->
- let map l = F.fprintf frm "{%a}" xl l in
- List.iter map (List.rev ls)
-
-in
-F.fprintf frm "%a@\n" xl l
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type sorts = (Cic.id, Cic2acic.sort_kind) Hashtbl.t
-
-val tex_of_term: Format.formatter -> Cic.context -> Cic.term -> unit
-
-val tex_of_obj: Format.formatter -> Cic.obj -> unit
-
-val tex_of_annterm: Format.formatter -> sorts -> Cic.annterm -> unit
-
-val tex_of_steps:
- Format.formatter -> sorts -> ProceduralTypes.step list -> unit
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module HEL = HExtlib
-module C = Cic
-module I = CicInspect
-module G = GrafiteAst
-module N = CicNotationPt
-
-module H = ProceduralHelpers
-
-(* functions to be moved ****************************************************)
-
-let list_rev_map2 map l1 l2 =
- let rec aux res = function
- | hd1 :: tl1, hd2 :: tl2 -> aux (map hd1 hd2 :: res) (tl1, tl2)
- | _ -> res
- in
- aux [] (l1, l2)
-
-let list_map2_filter map l1 l2 =
- let rec filter l = function
- | [] -> l
- | None :: tl -> filter l tl
- | Some a :: tl -> filter (a :: l) tl
- in
- filter [] (list_rev_map2 map l1 l2)
-
-let list_init f i =
- let rec aux a j = if j < 0 then a else aux (f j :: a) (pred j) in
- aux [] i
-
-(****************************************************************************)
-
-type flavour = C.object_flavour
-type name = string option
-type hyp = string
-type what = C.annterm
-type how = bool
-type using = C.annterm
-type count = int
-type note = string
-type where = (hyp * name) option
-type inferred = C.annterm
-type pattern = C.annterm
-type body = C.annterm option
-type types = C.anninductiveType list
-type lpsno = int
-type fields = (string * bool * int) list
-
-type step = Note of note
- | Record of types * lpsno * fields * note
- | Inductive of types * lpsno * note
- | Statement of flavour * name * what * body * note
- | Qed of note
- | Id of note
- | Exact of what * note
- | Intros of count option * name list * note
- | Cut of name * what * note
- | LetIn of name * what * note
- | LApply of name * what * note
- | Rewrite of how * what * where * pattern * note
- | Elim of what * using option * pattern * note
- | Cases of what * pattern * note
- | Apply of what * note
- | Change of inferred * what * where * pattern * note
- | Clear of hyp list * note
- | ClearBody of hyp * note
- | Branch of step list list * note
- | Reflexivity of note
-
-(* annterm constructors *****************************************************)
-
-let mk_arel i b = C.ARel ("", "", i, b)
-
-(* FG: this is really awful !! *)
-let arel_of_name = function
- | C.Name s -> mk_arel 0 s
- | C.Anonymous -> mk_arel 0 "_"
-
-(* helper functions on left params for use with inductive types *************)
-
-let strip_lps lpsno arity =
- let rec aux no lps = function
- | C.AProd (_, name, w, t) when no > 0 ->
- let lp = name, Some w in
- aux (pred no) (lp :: lps) t
- | t -> lps, t
- in
- aux lpsno [] arity
-
-let merge_lps lps1 lps2 =
- let map (n1, w1) (n2, _) =
- let n = match n1, n2 with
- | C.Name _, _ -> n1
- | _ -> n2
- in
- n, w1
- in
- if lps1 = [] then lps2 else
- List.map2 map lps1 lps2
-
-(* grafite ast constructors *************************************************)
-
-let floc = HEL.dummy_floc
-
-let mk_note str = G.Comment (floc, G.Note (floc, str))
-
-let mk_tacnote str a =
- if str = "" then mk_note "" :: a else mk_note "" :: mk_note str :: a
-
-let mk_notenote str a =
- if str = "" then a else mk_note str :: a
-
-let mk_thnote str a =
- if str = "" then a else mk_note "" :: mk_note str :: a
-
-let mk_pre_inductive types lpsno =
- let map1 (lps1, cons) (name, arity) =
- let lps2, arity = strip_lps lpsno arity in
- merge_lps lps1 lps2, (name, arity) :: cons
- in
- let map2 (lps1, types) (_, name, kind, arity, cons) =
- let lps2, arity = strip_lps lpsno arity in
- let lps1, rev_cons = List.fold_left map1 (lps1, []) cons in
- merge_lps lps1 lps2, (name, kind, arity, List.rev rev_cons) :: types
- in
- let map3 (name, xw) = arel_of_name name, xw in
- let rev_lps, rev_types = List.fold_left map2 ([], []) types in
- List.rev_map map3 rev_lps, List.rev rev_types
-
-let mk_inductive types lpsno =
- let lpars, types = mk_pre_inductive types lpsno in
- let obj = N.Inductive (lpars, types) in
- G.Executable (floc, G.Command (floc, G.Obj (floc, obj)))
-
-let mk_record types lpsno fields =
- match mk_pre_inductive types lpsno with
- | lpars, [name, _, ty, [_, cty]] ->
- let map (fields, cty) (name, coercion, arity) =
- match cty with
- | C.AProd (_, _, w, t) ->
- (name, w, coercion, arity) :: fields, t
- | _ ->
- assert false
- in
- let rev_fields, _ = List.fold_left map ([], cty) fields in
- let fields = List.rev rev_fields in
- let obj = N.Record (lpars, name, ty, fields) in
- G.Executable (floc, G.Command (floc, G.Obj (floc, obj)))
- | _ -> assert false
-
-let mk_statement flavour name t v =
- let name = match name with Some name -> name | None -> assert false in
- let obj = N.Theorem (flavour, name, t, v, `Regular) in
- G.Executable (floc, G.Command (floc, G.Obj (floc, obj)))
-
-let mk_qed =
- G.Executable (floc, G.Command (floc, G.Qed floc))
-
-let mk_tactic tactic punctation =
- G.Executable (floc, G.Tactic (floc, Some tactic, punctation))
-
-let mk_punctation punctation =
- G.Executable (floc, G.Tactic (floc, None, punctation))
-
-let mk_id punctation =
- let tactic = G.IdTac floc in
- mk_tactic tactic punctation
-
-let mk_exact t punctation =
- let tactic = G.Exact (floc, t) in
- mk_tactic tactic punctation
-
-let mk_intros xi xids punctation =
- let tactic = G.Intros (floc, (xi, xids)) in
- mk_tactic tactic punctation
-
-let mk_cut name what punctation =
- let name = match name with Some name -> name | None -> assert false in
- let tactic = G.Cut (floc, Some name, what) in
- mk_tactic tactic punctation
-
-let mk_letin name what punctation =
- let name = match name with Some name -> name | None -> assert false in
- let tactic = G.LetIn (floc, what, name) in
- mk_tactic tactic punctation
-
-let mk_lapply name what punctation =
- let tactic = G.LApply (floc, false, None, [], what, name) in
- mk_tactic tactic punctation
-
-let mk_rewrite direction what where pattern punctation =
- let direction = if direction then `RightToLeft else `LeftToRight in
- let pattern, rename = match where with
- | None -> (None, [], Some pattern), []
- | Some (premise, Some name) -> (None, [premise, pattern], None), [Some name]
- | Some (premise, None) -> (None, [premise, pattern], None), []
- in
- let tactic = G.Rewrite (floc, direction, what, pattern, rename) in
- mk_tactic tactic punctation
-
-let mk_elim what using pattern punctation =
- let pattern = None, [], Some pattern in
- let tactic = G.Elim (floc, what, using, pattern, (Some 0, [])) in
- mk_tactic tactic punctation
-
-let mk_cases what pattern punctation =
- let pattern = None, [], Some pattern in
- let tactic = G.Cases (floc, what, pattern, (Some 0, [])) in
- mk_tactic tactic punctation
-
-let mk_apply t punctation =
- let tactic = G.Apply (floc, t) in
- mk_tactic tactic punctation
-
-let mk_change t where pattern punctation =
- let pattern = match where with
- | None -> None, [], Some pattern
- | Some (premise, _) -> None, [premise, pattern], None
- in
- let tactic = G.Change (floc, pattern, t) in
- mk_tactic tactic punctation
-
-let mk_clear ids punctation =
- let tactic = G.Clear (floc, ids) in
- mk_tactic tactic punctation
-
-let mk_clearbody id punctation =
- let tactic = G.ClearBody (floc, id) in
- mk_tactic tactic punctation
-
-let mk_reflexivity punctation =
- let tactic = G.Reflexivity floc in
- mk_tactic tactic punctation
-
-let mk_ob =
- let punctation = G.Branch floc in
- mk_punctation punctation
-
-let mk_dot = G.Dot floc
-
-let mk_sc = G.Semicolon floc
-
-let mk_cb = G.Merge floc
-
-let mk_vb = G.Shift floc
-
-(* rendering ****************************************************************)
-
-let rec render_step sep a = function
- | Note s -> mk_notenote s a
- | Statement (f, n, t, v, s) -> mk_statement f n t v :: mk_thnote s a
- | Inductive (ts, lps, s) -> mk_inductive ts lps :: mk_thnote s a
- | Record (ts, lps, fs, s) -> mk_record ts lps fs :: mk_thnote s a
- | Qed s -> mk_qed :: mk_tacnote s a
- | Exact (t, s) -> mk_exact t sep :: mk_tacnote s a
- | Id s -> mk_id sep :: mk_tacnote s a
- | Intros (c, ns, s) -> mk_intros c ns sep :: mk_tacnote s a
- | Cut (n, t, s) -> mk_cut n t sep :: mk_tacnote s a
- | LetIn (n, t, s) -> mk_letin n t sep :: mk_tacnote s a
- | LApply (n, t, s) -> mk_lapply n t sep :: mk_tacnote s a
- | Rewrite (b, t, w, e, s) -> mk_rewrite b t w e sep :: mk_tacnote s a
- | Elim (t, xu, e, s) -> mk_elim t xu e sep :: mk_tacnote s a
- | Cases (t, e, s) -> mk_cases t e sep :: mk_tacnote s a
- | Apply (t, s) -> mk_apply t sep :: mk_tacnote s a
- | Change (t, _, w, e, s) -> mk_change t w e sep :: mk_tacnote s a
- | Clear (ns, s) -> mk_clear ns sep :: mk_tacnote s a
- | ClearBody (n, s) -> mk_clearbody n sep :: mk_tacnote s a
- | Branch ([], s) -> a
- | Branch ([ps], s) -> render_steps sep a ps
- | Branch (ps :: pss, s) ->
- let a = mk_ob :: mk_tacnote s a in
- let a = List.fold_left (render_steps mk_vb) a (List.rev pss) in
- mk_punctation sep :: render_steps mk_cb a ps
- | Reflexivity s -> mk_reflexivity sep :: mk_tacnote s a
-
-and render_steps sep a = function
- | [] -> a
- | [p] -> render_step sep a p
- | p :: Branch ([], _) :: ps ->
- render_steps sep a (p :: ps)
- | p :: ((Branch (_ :: _ :: _, _) :: _) as ps) ->
- render_steps sep (render_step mk_sc a p) ps
- | p :: ps ->
- render_steps sep (render_step mk_sc a p) ps
-
-let render_steps a = render_steps mk_dot a
-
-(* counting *****************************************************************)
-
-let rec count_step a = function
- | Note _
- | Statement _
- | Inductive _
- | Qed _ -> a
-(* level A0 *)
- | Branch (pps, _) -> List.fold_left count_steps a pps
- | Clear _
- | ClearBody _
- | Id _
- | Intros (Some 0, [], _)
-(* leval A1 *)
- | Exact _
-(* level B1 *)
- | Cut _
- | LetIn _
-(* level B2 *)
- | Change _ -> a
-(* level C *)
- | _ -> succ a
-
-and count_steps a = List.fold_left count_step a
-
-let count = I.count_nodes ~meta:false
-
-let rec count_node a = function
- | Note _
- | Record _
- | Inductive _
- | Statement _
- | Qed _
- | Reflexivity _
- | Id _
- | Intros _
- | Clear _
- | ClearBody _ -> a
- | Exact (t, _)
- | Cut (_, t, _)
- | LetIn (_, t, _)
- | LApply (_, t, _)
- | Apply (t, _) -> count a (H.cic t)
- | Rewrite (_, t, _, p, _)
- | Elim (t, _, p, _)
- | Cases (t, p, _)
- | Change (t, _, _, p, _) -> let a = count a (H.cic t) in count a (H.cic p)
- | Branch (ss, _) -> List.fold_left count_nodes a ss
-
-and count_nodes a = List.fold_left count_node a
-
-(* helpers ******************************************************************)
-
-let rec note_of_step = function
- | Note s
- | Statement (_, _, _, _, s)
- | Inductive (_, _, s)
- | Record (_, _, _, s)
- | Qed s
- | Exact (_, s)
- | Id s
- | Intros (_, _, s)
- | Cut (_, _, s)
- | LetIn (_, _, s)
- | LApply (_, _, s)
- | Rewrite (_, _, _, _, s)
- | Elim (_, _, _, s)
- | Cases (_, _, s)
- | Apply (_, s)
- | Change (_, _, _, _, s)
- | Clear (_, s)
- | ClearBody (_, s)
- | Reflexivity s
- | Branch (_, s) -> s
+++ /dev/null
-(* Copyright (C) 2003-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* functions to be moved ****************************************************)
-
-val list_rev_map2: ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-
-val list_map2_filter: ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
-
-val mk_arel: int -> string -> Cic.annterm
-
-(****************************************************************************)
-
-type flavour = Cic.object_flavour
-type name = string option
-type hyp = string
-type what = Cic.annterm
-type how = bool
-type using = Cic.annterm
-type count = int
-type note = string
-type where = (hyp * name) option
-type inferred = Cic.annterm
-type pattern = Cic.annterm
-type body = Cic.annterm option
-type types = Cic.anninductiveType list
-type lpsno = int
-type fields = (string * bool * int) list
-
-type step = Note of note
- | Record of types * lpsno * fields * note
- | Inductive of types * lpsno * note
- | Statement of flavour * name * what * body * note
- | Qed of note
- | Id of note
- | Exact of what * note
- | Intros of count option * name list * note
- | Cut of name * what * note
- | LetIn of name * what * note
- | LApply of name * what * note
- | Rewrite of how * what * where * pattern * note
- | Elim of what * using option * pattern * note
- | Cases of what * pattern * note
- | Apply of what * note
- | Change of inferred * what * where * pattern * note
- | Clear of hyp list * note
- | ClearBody of hyp * note
- | Branch of step list list * note
- | Reflexivity of note
-
-val render_steps:
- (what, inferred, [> `Whd] as 'b, what CicNotationPt.obj, hyp) GrafiteAst.statement list ->
- step list ->
- (what, inferred, 'b, what CicNotationPt.obj, hyp) GrafiteAst.statement list
-
-val count_steps:
- int -> step list -> int
-
-val count_nodes:
- int -> step list -> int
-
-val note_of_step:
- step -> note
(* $Id$ *)
-module PEH = ProofEngineHelpers
-
exception Drop
(* mo file name, ma file name *)
exception IncludedFileNotCompiled of string * string
end else
FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ
-let rec tactic_of_ast status ast =
- let module PET = ProofEngineTypes in
- match ast with
- (* Higher order tactics *)
- | GrafiteAst.Do (loc, n, tactic) ->
- Tacticals.do_tactic n (tactic_of_ast status tactic)
- | GrafiteAst.Seq (loc, tactics) -> (* tac1; tac2; ... *)
- Tacticals.seq (List.map (tactic_of_ast status) tactics)
- | GrafiteAst.Repeat (loc, tactic) ->
- Tacticals.repeat_tactic (tactic_of_ast status tactic)
- | GrafiteAst.Then (loc, tactic, tactics) -> (* tac; [ tac1 | ... ] *)
- Tacticals.thens
- (tactic_of_ast status tactic)
- (List.map (tactic_of_ast status) tactics)
- | GrafiteAst.First (loc, tactics) ->
- Tacticals.first (List.map (tactic_of_ast status) tactics)
- | GrafiteAst.Try (loc, tactic) ->
- Tacticals.try_tactic (tactic_of_ast status tactic)
- | GrafiteAst.Solve (loc, tactics) ->
- Tacticals.solve_tactics (List.map (tactic_of_ast status) tactics)
- | GrafiteAst.Progress (loc, tactic) ->
- Tacticals.progress_tactic (tactic_of_ast status tactic)
- (* First order tactics *)
- | GrafiteAst.Absurd (_, term) -> Tactics.absurd term
- | GrafiteAst.Apply (_, term) -> Tactics.apply term
- | GrafiteAst.ApplyRule (_, term) -> Tactics.apply term
- | GrafiteAst.ApplyP (_, term) -> Tactics.applyP term
- | GrafiteAst.ApplyS (_, term, params) ->
- Tactics.applyS ~term ~params ~dbd:(LibraryDb.instance ())
- ~automation_cache:status#automation_cache
- | GrafiteAst.Assumption _ -> Tactics.assumption
- | GrafiteAst.AutoBatch (_,params) ->
- Tactics.auto ~params ~dbd:(LibraryDb.instance ())
- ~automation_cache:status#automation_cache
- | GrafiteAst.Cases (_, what, pattern, (howmany, names)) ->
- Tactics.cases_intros ?howmany ~mk_fresh_name_callback:(namer_of names)
- ~pattern what
- | GrafiteAst.Change (_, pattern, with_what) ->
- Tactics.change ~pattern with_what
- | GrafiteAst.Clear (_,id) -> Tactics.clear id
- | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id
- | GrafiteAst.Compose (_,t1,t2,times,(howmany, names)) ->
- Tactics.compose times t1 t2 ?howmany
- ~mk_fresh_name_callback:(namer_of names)
- | GrafiteAst.Contradiction _ -> Tactics.contradiction
- | GrafiteAst.Constructor (_, n) -> Tactics.constructor n
- | GrafiteAst.Cut (_, ident, term) ->
- let names = match ident with None -> [] | Some id -> [Some id] in
- Tactics.cut ~mk_fresh_name_callback:(namer_of names) term
- | GrafiteAst.Decompose (_, names) ->
- let mk_fresh_name_callback = namer_of names in
- Tactics.decompose ~mk_fresh_name_callback ()
- | GrafiteAst.Demodulate (_, params) ->
- Tactics.demodulate
- ~dbd:(LibraryDb.instance ()) ~params
- ~automation_cache:status#automation_cache
- | GrafiteAst.Destruct (_,xterms) -> Tactics.destruct xterms
- | GrafiteAst.Elim (_, what, using, pattern, (depth, names)) ->
- Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names)
- ~pattern what
- | GrafiteAst.ElimType (_, what, using, (depth, names)) ->
- Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names)
- what
- | GrafiteAst.Exact (_, term) -> Tactics.exact term
- | GrafiteAst.Exists _ -> Tactics.exists
- | GrafiteAst.Fail _ -> Tactics.fail
- | GrafiteAst.Fold (_, reduction_kind, term, pattern) ->
- let reduction =
- match reduction_kind with
- | `Normalize ->
- PET.const_lazy_reduction
- (CicReduction.normalize ~delta:false ~subst:[])
- | `Simpl -> PET.const_lazy_reduction ProofEngineReduction.simpl
- | `Unfold None ->
- PET.const_lazy_reduction (ProofEngineReduction.unfold ?what:None)
- | `Unfold (Some lazy_term) ->
- (fun context metasenv ugraph ->
- let what, metasenv, ugraph = lazy_term context metasenv ugraph in
- ProofEngineReduction.unfold ~what, metasenv, ugraph)
- | `Whd ->
- PET.const_lazy_reduction (CicReduction.whd ~delta:false ~subst:[])
- in
- Tactics.fold ~reduction ~term ~pattern
- | GrafiteAst.Fourier _ -> Tactics.fourier
- | GrafiteAst.FwdSimpl (_, hyp, names) ->
- Tactics.fwd_simpl ~mk_fresh_name_callback:(namer_of names)
- ~dbd:(LibraryDb.instance ()) hyp
- | GrafiteAst.Generalize (_,pattern,ident) ->
- let names = match ident with None -> [] | Some id -> [Some id] in
- Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern
- | GrafiteAst.IdTac _ -> Tactics.id
- | GrafiteAst.Intros (_, (howmany, names)) ->
- PrimitiveTactics.intros_tac ?howmany
- ~mk_fresh_name_callback:(namer_of names) ()
- | GrafiteAst.Inversion (_, term) ->
- Tactics.inversion term
- | GrafiteAst.LApply (_, linear, how_many, to_what, what, ident) ->
- let names = match ident with None -> [] | Some id -> [Some id] in
- Tactics.lapply ~mk_fresh_name_callback:(namer_of names)
- ~linear ?how_many ~to_what what
- | GrafiteAst.Left _ -> Tactics.left
- | GrafiteAst.LetIn (loc,term,name) ->
- Tactics.letin term ~mk_fresh_name_callback:(namer_of [Some name])
- | GrafiteAst.Reduce (_, reduction_kind, pattern) ->
- (match reduction_kind with
- | `Normalize -> Tactics.normalize ~pattern
- | `Simpl -> Tactics.simpl ~pattern
- | `Unfold what -> Tactics.unfold ~pattern what
- | `Whd -> Tactics.whd ~pattern)
- | GrafiteAst.Reflexivity _ -> Tactics.reflexivity
- | GrafiteAst.Replace (_, pattern, with_what) ->
- Tactics.replace ~pattern ~with_what
- | GrafiteAst.Rewrite (_, direction, t, pattern, names) ->
- EqualityTactics.rewrite_tac ~direction ~pattern t
-(* to be replaced with ~mk_fresh_name_callback:(namer_of names) *)
- (List.map (function Some s -> s | None -> assert false) names)
- | GrafiteAst.Right _ -> Tactics.right
- | GrafiteAst.Ring _ -> Tactics.ring
- | GrafiteAst.Split _ -> Tactics.split
- | GrafiteAst.Symmetry _ -> Tactics.symmetry
- | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term
- (* Implementazioni Aggiunte *)
- | GrafiteAst.Assume (_, id, t) -> Declarative.assume id t
- | GrafiteAst.Suppose (_, t, id, t1) -> Declarative.suppose t id t1
- | GrafiteAst.By_just_we_proved (_, just, ty, id, t1) ->
- Declarative.by_just_we_proved ~dbd:(LibraryDb.instance())
- ~automation_cache:status#automation_cache just ty id t1
- | GrafiteAst.We_need_to_prove (_, t, id, t2) ->
- Declarative.we_need_to_prove t id t2
- | GrafiteAst.Bydone (_, t) ->
- Declarative.bydone ~dbd:(LibraryDb.instance())
- ~automation_cache:status#automation_cache t
- | GrafiteAst.We_proceed_by_cases_on (_, t, t1) ->
- Declarative.we_proceed_by_cases_on t t1
- | GrafiteAst.We_proceed_by_induction_on (_, t, t1) ->
- Declarative.we_proceed_by_induction_on t t1
- | GrafiteAst.Byinduction (_, t, id) -> Declarative.byinduction t id
- | GrafiteAst.Thesisbecomes (_, t) -> Declarative.thesisbecomes t
- | GrafiteAst.ExistsElim (_, just, id1, t1, id2, t2) ->
- Declarative.existselim ~dbd:(LibraryDb.instance())
- ~automation_cache:status#automation_cache just id1 t1 id2 t2
- | GrafiteAst.Case (_,id,params) -> Declarative.case id params
- | GrafiteAst.AndElim(_,just,id1,t1,id2,t2) ->
- Declarative.andelim ~dbd:(LibraryDb.instance ())
- ~automation_cache:status#automation_cache just id1 t1 id2 t2
- | GrafiteAst.RewritingStep (_,termine,t1,t2,cont) ->
- Declarative.rewritingstep ~dbd:(LibraryDb.instance ())
- ~automation_cache:status#automation_cache termine t1 t2 cont
-
-let classify_tactic tactic =
- match tactic with
- (* tactics that can't close the goal (return a goal we want to "select") *)
- | GrafiteAst.Rewrite _
- | GrafiteAst.Split _
- | GrafiteAst.Replace _
- | GrafiteAst.Reduce _
- | GrafiteAst.IdTac _
- | GrafiteAst.Generalize _
- | GrafiteAst.Elim _
- | GrafiteAst.Cut _
- | GrafiteAst.Decompose _ -> true
- (* tactics like apply *)
- | _ -> false
-
-let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal=
-(* let print_m name metasenv =
- prerr_endline (">>>>> " ^ name);
- prerr_endline (CicMetaSubst.ppmetasenv [] metasenv)
- in *)
- (* phase one calculates:
- * new_goals_from_refine: goals added by refine
- * head_goal: the first goal opened by ythe tactic
- * other_goals: other goals opened by the tactic
- *)
- let new_goals_from_refine = PEH.compare_metasenvs start refine in
- let new_goals_from_tactic = PEH.compare_metasenvs refine tactic in
- let head_goal, other_goals, goals =
- match goals with
- | [] -> None,[],goals
- | hd::tl ->
- (* assert (List.mem hd new_goals_from_tactic);
- * invalidato dalla goal_tac
- * *)
- Some hd, List.filter ((<>) hd) new_goals_from_tactic, List.filter ((<>)
- hd) goals
- in
- let produced_goals =
- match head_goal with
- | None -> new_goals_from_refine @ other_goals
- | Some x -> x :: new_goals_from_refine @ other_goals
- in
- (* extract the metas generated by refine and tactic *)
- let metas_for_tactic_head =
- match head_goal with
- | None -> []
- | Some head_goal -> List.filter (fun (n,_,_) -> n = head_goal) tactic in
- let metas_for_tactic_goals =
- List.map
- (fun x -> List.find (fun (metano,_,_) -> metano = x) tactic)
- goals
- in
- let metas_for_refine_goals =
- List.filter (fun (n,_,_) -> List.mem n new_goals_from_refine) tactic in
- let produced_metas, goals =
- let produced_metas =
- if always_opens_a_goal then
- metas_for_tactic_head @ metas_for_refine_goals @
- metas_for_tactic_goals
- else begin
-(* print_m "metas_for_refine_goals" metas_for_refine_goals;
- print_m "metas_for_tactic_head" metas_for_tactic_head;
- print_m "metas_for_tactic_goals" metas_for_tactic_goals; *)
- metas_for_refine_goals @ metas_for_tactic_head @
- metas_for_tactic_goals
- end
- in
- let goals = List.map (fun (metano, _, _) -> metano) produced_metas in
- produced_metas, goals
- in
- (* residual metas, preserving the original order *)
- let before, after =
- let rec split e =
- function
- | [] -> [],[]
- | (metano, _, _) :: tl when metano = e ->
- [], List.map (fun (x,_,_) -> x) tl
- | (metano, _, _) :: tl -> let b, a = split e tl in metano :: b, a
- in
- let find n metasenv =
- try
- Some (List.find (fun (metano, _, _) -> metano = n) metasenv)
- with Not_found -> None
- in
- let extract l =
- List.fold_right
- (fun n acc ->
- match find n tactic with
- | Some x -> x::acc
- | None -> acc
- ) l [] in
- let before_l, after_l = split current_goal start in
- let before_l =
- List.filter (fun x -> not (List.mem x produced_goals)) before_l in
- let after_l =
- List.filter (fun x -> not (List.mem x produced_goals)) after_l in
- let before = extract before_l in
- let after = extract after_l in
- before, after
- in
-(* |+ DEBUG CODE +|
- print_m "BEGIN" start;
- prerr_endline ("goal was: " ^ string_of_int current_goal);
- prerr_endline ("and metas from refine are:");
- List.iter
- (fun t -> prerr_string (" " ^ string_of_int t))
- new_goals_from_refine;
- prerr_endline "";
- print_m "before" before;
- print_m "metas_for_tactic_head" metas_for_tactic_head;
- print_m "metas_for_refine_goals" metas_for_refine_goals;
- print_m "metas_for_tactic_goals" metas_for_tactic_goals;
- print_m "produced_metas" produced_metas;
- print_m "after" after;
-|+ FINE DEBUG CODE +| *)
- before @ produced_metas @ after, goals
-
-let apply_tactic ~disambiguate_tactic (text,prefix_len,tactic) (status, goal) =
- let starting_metasenv = GrafiteTypes.get_proof_metasenv status in
- let before = List.map (fun g, _, _ -> g) starting_metasenv in
- let status, tactic = disambiguate_tactic status goal (text,prefix_len,tactic) in
- let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in
- let proof = GrafiteTypes.get_current_proof status in
- let proof_status = proof, goal in
- let always_opens_a_goal = classify_tactic tactic in
- let tactic = tactic_of_ast status tactic in
- let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in
- let after = ProofEngineTypes.goals_of_proof proof in
- let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in
- let proof, opened_goals =
- let uri, metasenv_after_tactic, subst, t, ty, attrs = proof in
- let reordered_metasenv, opened_goals =
- reorder_metasenv
- starting_metasenv
- metasenv_after_refinement metasenv_after_tactic
- opened goal always_opens_a_goal
- in
- let proof' = uri, reordered_metasenv, [], t, ty, attrs in
- proof', opened_goals
- in
- let incomplete_proof =
- match status#proof_status with
- | GrafiteTypes.Incomplete_proof p -> p
- | _ -> assert false
- in
- status#set_proof_status
- (GrafiteTypes.Incomplete_proof
- { incomplete_proof with GrafiteTypes.proof = proof }),
- opened_goals, closed_goals
-
-let apply_atomic_tactical ~disambiguate_tactic ~patch (text,prefix_len,tactic) (status, goal) =
- let starting_metasenv = GrafiteTypes.get_proof_metasenv status in
- let before = List.map (fun g, _, _ -> g) starting_metasenv in
- let status, tactic = disambiguate_tactic status goal (text,prefix_len,tactic) in
- let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in
- let proof = GrafiteTypes.get_current_proof status in
- let proof_status = proof, goal in
- let always_opens_a_goal = classify_tactic tactic in
- let tactic = tactic_of_ast status tactic in
- let tactic = patch tactic in
- let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in
- let after = ProofEngineTypes.goals_of_proof proof in
- let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in
- let proof, opened_goals =
- let uri, metasenv_after_tactic, _subst, t, ty, attrs = proof in
- let reordered_metasenv, opened_goals =
- reorder_metasenv
- starting_metasenv
- metasenv_after_refinement metasenv_after_tactic
- opened goal always_opens_a_goal
- in
- let proof' = uri, reordered_metasenv, _subst, t, ty, attrs in
- proof', opened_goals
- in
- let incomplete_proof =
- match status#proof_status with
- | GrafiteTypes.Incomplete_proof p -> p
- | _ -> assert false
- in
- status#set_proof_status
- (GrafiteTypes.Incomplete_proof
- { incomplete_proof with GrafiteTypes.proof = proof }),
- opened_goals, closed_goals
type eval_ast =
{ea_go:
'term 'lazy_term 'reduction 'obj 'ident.
- disambiguate_tactic:
- (GrafiteTypes.status ->
- ProofEngineTypes.goal ->
- (('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic)
- disambiguator_input ->
- GrafiteTypes.status *
- (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
disambiguate_command:
(GrafiteTypes.status ->
type 'a eval_executable =
{ee_go: 'term 'lazy_term 'reduction 'obj 'ident.
- disambiguate_tactic:
- (GrafiteTypes.status ->
- ProofEngineTypes.goal ->
- (('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic)
- disambiguator_input ->
- GrafiteTypes.status *
- (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
disambiguate_command:
(GrafiteTypes.status ->
let status = GrafiteTypes.add_moo_content [moo_content] status in
status, `Old []
-module MatitaStatus =
- struct
- type input_status = GrafiteTypes.status * ProofEngineTypes.goal
-
- type output_status =
- GrafiteTypes.status * ProofEngineTypes.goal list * ProofEngineTypes.goal list
-
- type tactic = input_status -> output_status
-
- let mk_tactic tac = tac
- let apply_tactic tac = tac
- let goals (_, opened, closed) = opened, closed
- let get_stack (status, _) = GrafiteTypes.get_stack status
-
- let set_stack stack (status, opened, closed) =
- GrafiteTypes.set_stack stack status, opened, closed
-
- let inject (status, _) = (status, [], [])
- let focus goal (status, _, _) = (status, goal)
- end
-
-module MatitaTacticals = Continuationals.Make(MatitaStatus)
-
-let tactic_of_ast' tac =
- MatitaTacticals.Tactical (MatitaTacticals.Tactic (MatitaStatus.mk_tactic tac))
-
-let punctuation_tactical_of_ast (text,prefix_len,punct) =
- match punct with
- | GrafiteAst.Dot _loc -> MatitaTacticals.Dot
- | GrafiteAst.Semicolon _loc -> MatitaTacticals.Semicolon
- | GrafiteAst.Branch _loc -> MatitaTacticals.Branch
- | GrafiteAst.Shift _loc -> MatitaTacticals.Shift
- | GrafiteAst.Pos (_loc, i) -> MatitaTacticals.Pos i
- | GrafiteAst.Merge _loc -> MatitaTacticals.Merge
- | GrafiteAst.Wildcard _loc -> MatitaTacticals.Wildcard
-
-let non_punctuation_tactical_of_ast (text,prefix_len,punct) =
- match punct with
- | GrafiteAst.Focus (_loc,goals) -> MatitaTacticals.Focus goals
- | GrafiteAst.Unfocus _loc -> MatitaTacticals.Unfocus
- | GrafiteAst.Skip _loc -> MatitaTacticals.Tactical MatitaTacticals.Skip
-
-let eval_tactical status tac =
- let status, _, _ = MatitaTacticals.eval tac (status, ~-1) in
- let status = (* is proof completed? *)
- match status#proof_status with
- | GrafiteTypes.Incomplete_proof
- { GrafiteTypes.stack = stack; proof = proof }
- when Continuationals.Stack.is_empty stack ->
- status#set_proof_status (GrafiteTypes.Proof proof)
- | _ -> status
- in
- status
-
-let add_obj = GrafiteSync.add_obj ~pack_coercion_obj:CicRefine.pack_coercion_obj
-
let eval_ng_punct (_text, _prefix_len, punct) =
match punct with
| GrafiteAst.Dot _ -> NTactics.dot_tac
let status,cmd = disambiguate_command status (text,prefix_len,cmd) in
let status,uris =
match cmd with
- | GrafiteAst.Index (loc,None,uri) ->
- assert false (* TODO: for user input *)
- | GrafiteAst.Index (loc,Some key,uri) ->
- let universe =
- status#automation_cache.AutomationCache.univ
- in
- let universe = Universe.index universe key (CicUtil.term_of_uri uri) in
- let cache = {
- status#automation_cache with AutomationCache.univ = universe }
- in
- let status = status#set_automation_cache cache in
-(* debug
- let msg =
- let candidates = Universe.get_candidates status.GrafiteTypes.universe key in
- ("candidates for " ^ (CicPp.ppterm key) ^ " = " ^
- (String.concat "\n" (List.map CicPp.ppterm candidates)))
- in
- prerr_endline msg;
-*)
- let status = GrafiteTypes.add_moo_content [cmd] status in
- status,`Old []
- | GrafiteAst.Select (_,uri) as cmd ->
- if List.mem cmd status#moo_content_rev then status, `Old []
- else
- let cache =
- AutomationCache.add_term_to_active status#automation_cache
- [] [] [] (CicUtil.term_of_uri uri) None
- in
- let status = status#set_automation_cache cache in
- let status = GrafiteTypes.add_moo_content [cmd] status in
- status, `Old []
- | GrafiteAst.Pump (_,steps) ->
- let cache =
- AutomationCache.pump status#automation_cache steps
- in
- let status = status#set_automation_cache cache in
- status, `Old []
| GrafiteAst.PreferCoercion (loc, coercion) ->
eval_prefer_coercion status coercion
| GrafiteAst.Coercion (loc, uri, add_composites, arity, saturations) ->
eval_coercion status ~add_composites uri arity saturations
in
res,`Old uris
- | GrafiteAst.Inverter (loc, name, indty, params) ->
- let buri = status#baseuri in
- let uri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in
- let indty_uri =
- try CicUtil.uri_of_term indty
- with Invalid_argument _ ->
- raise (Invalid_argument "not an inductive type to invert") in
- let res,uris =
- Inversion_principle.build_inverter ~add_obj status uri indty_uri params
- in
- res,`Old uris
| GrafiteAst.Default (loc, what, uris) as cmd ->
LibraryObjects.set_default what uris;
GrafiteTypes.add_moo_content [cmd] status,`Old []
[GrafiteAst.Include (loc,mode,`New,baseuri)] status
in
status,`Old []
- | GrafiteAst.Print (_,"proofterm") ->
- let _,_,_,p,_, _ = GrafiteTypes.get_current_proof status in
- prerr_endline (Auto.pp_proofterm (Lazy.force p));
- status,`Old []
| GrafiteAst.Print (_,_) -> status,`Old []
- | GrafiteAst.Qed loc ->
- let uri, metasenv, _subst, bo, ty, attrs =
- match status#proof_status with
- | GrafiteTypes.Proof (Some uri, metasenv, subst, body, ty, attrs) ->
- uri, metasenv, subst, body, ty, attrs
- | GrafiteTypes.Proof (None, metasenv, subst, body, ty, attrs) ->
- raise (GrafiteTypes.Command_error
- ("Someone allows to start a theorem without giving the "^
- "name/uri. This should be fixed!"))
- | _->
- raise
- (GrafiteTypes.Command_error "You can't Qed an incomplete theorem")
- in
- if metasenv <> [] then
- raise
- (GrafiteTypes.Command_error
- "Proof not completed! metasenv is not empty!");
- let name = UriManager.name_of_uri uri in
- let obj = Cic.Constant (name,Some (Lazy.force bo),ty,[],attrs) in
- let status, lemmas = add_obj uri obj status in
- status#set_proof_status GrafiteTypes.No_proof,
- (*CSC: I throw away the arities *)
- `Old (uri::lemmas)
- | GrafiteAst.Relation (loc, id, a, aeq, refl, sym, trans) ->
- Setoids.add_relation id a aeq refl sym trans;
- status, `Old [] (*CSC: TO BE FIXED *)
| GrafiteAst.Set (loc, name, value) -> status, `Old []
(* GrafiteTypes.set_option status name value,[] *)
| GrafiteAst.Obj (loc,obj) -> (* MATITA 1.0 *) assert false
in
- match status#proof_status with
- GrafiteTypes.Intermediate _ ->
- status#set_proof_status GrafiteTypes.No_proof,uris
- | _ -> status,uris
+ status,uris
-} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command
+} and eval_executable = {ee_go = fun ~disambiguate_command
~disambiguate_macro opts status (text,prefix_len,ex) ->
match ex with
- | GrafiteAst.Tactic (_(*loc*), Some tac, punct) ->
- let tac = apply_tactic ~disambiguate_tactic (text,prefix_len,tac) in
- let status = eval_tactical status (tactic_of_ast' tac) in
- (* CALL auto on every goal, easy way of testing it
- let auto =
- GrafiteAst.AutoBatch
- (loc, ([],["depth","2";"timeout","1";"type","1"])) in
- (try
- let auto = apply_tactic ~disambiguate_tactic ("",0,auto) in
- let _ = eval_tactical status (tactic_of_ast' auto) in
- print_endline "GOOD"; ()
- with ProofEngineTypes.Fail _ -> print_endline "BAD" | _ -> ());*)
- eval_tactical status
- (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old []
- | GrafiteAst.Tactic (_, None, punct) ->
- eval_tactical status
- (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old []
| GrafiteAst.NTactic (_(*loc*), tacl) ->
if status#ng_mode <> `ProofMode then
raise (GrafiteTypes.Command_error "Not in proof mode")
status tacl
in
status,`New []
- | GrafiteAst.NonPunctuationTactical (_, tac, punct) ->
- let status =
- eval_tactical status
- (non_punctuation_tactical_of_ast (text,prefix_len,tac))
- in
- eval_tactical status
- (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old []
| GrafiteAst.Command (_, cmd) ->
eval_command.ec_go ~disambiguate_command opts status (text,prefix_len,cmd)
| GrafiteAst.NCommand (_, cmd) ->
let ast = ast_of_cmd ast in
let status,lemmas =
eval_ast.ea_go
- ~disambiguate_tactic:(fun status _ (_,_,tactic) -> status,tactic)
~disambiguate_command:(fun status (_,_,cmd) -> status,cmd)
~disambiguate_macro:(fun _ _ -> assert false)
status ast
assert (lemmas=`Old []);
status)
status moo
-} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command
+} and eval_ast = {ea_go = fun ~disambiguate_command
~disambiguate_macro ?(do_heavy_checks=false) status
(text,prefix_len,st)
->
let opts = { do_heavy_checks = do_heavy_checks ; } in
match st with
| GrafiteAst.Executable (_,ex) ->
- eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command
+ eval_executable.ee_go ~disambiguate_command
~disambiguate_macro opts status (text,prefix_len,ex)
| GrafiteAst.Comment (_,c) ->
eval_comment.ecm_go ~disambiguate_command opts status (text,prefix_len,c)
type 'a disambiguator_input = string * int * 'a
val eval_ast :
- disambiguate_tactic:
- (GrafiteTypes.status ->
- ProofEngineTypes.goal ->
- (('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic)
- disambiguator_input ->
- GrafiteTypes.status *
- (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
-
disambiguate_command:
(GrafiteTypes.status ->
(('term,'obj) GrafiteAst.command) disambiguator_input ->
aux [] ty
;;
-let add_obj ~pack_coercion_obj uri obj status =
- let lemmas = LibrarySync.add_obj ~pack_coercion_obj uri obj in
- let add_to_universe (automation_cache,status) uri =
- let term = CicUtil.term_of_uri uri in
- let ty,_ = CicTypeChecker.type_of_aux' [] [] term CicUniv.oblivion_ugraph in
- let tkeys = Universe.keys [] ty in
- let universe = automation_cache.AutomationCache.univ in
- let universe, index_cmd =
- List.fold_left
- (fun (universe,acc) key ->
- let cands = Universe.get_candidates universe key in
- let tys =
- List.map
- (fun t ->
- let ty, _ =
- CicTypeChecker.type_of_aux' [] [] t CicUniv.oblivion_ugraph
- in
- ty)
- cands
- in
- if List.for_all
- (fun cty ->
- not (fst(CicReduction.are_convertible [] ty cty
- CicUniv.oblivion_ugraph))) tys
- then
- Universe.index universe key term,
- GrafiteAst.Index(HExtlib.dummy_floc,(Some key),uri)::acc
- else
- universe, acc)
- (universe,[]) tkeys
- in
- let is_equational = is_equational_fact ty in
- let select_cmd =
- if is_equational then
- [ GrafiteAst.Select(HExtlib.dummy_floc,uri) ]
- else
- []
- in
- let automation_cache =
- if is_equational then
- AutomationCache.add_term_to_active automation_cache [] [] [] term None
- else
- automation_cache
- in
- let automation_cache =
- { automation_cache with AutomationCache.univ = universe } in
- let status = GrafiteTypes.add_moo_content index_cmd status in
- let status = GrafiteTypes.add_moo_content select_cmd status in
- (automation_cache,status)
- in
- let uris_to_index =
- if is_a_variant obj then []
- else (uris_for_inductive_type uri obj) @ lemmas
- in
- let automation_cache,status =
- List.fold_left add_to_universe
- (status#automation_cache,status)
- uris_to_index
- in
- (status
- #set_objects (uri :: lemmas @ status#objects))
- #set_automation_cache automation_cache,
- lemmas
-
let add_coercion ~pack_coercion_obj ~add_composites status uri arity
saturations baseuri
=
* http://helm.cs.unibo.it/
*)
-val add_obj:
- pack_coercion_obj:(Cic.obj -> Cic.obj) ->
- UriManager.uri -> Cic.obj -> GrafiteTypes.status ->
- GrafiteTypes.status * UriManager.uri list
-
val add_coercion:
pack_coercion_obj:(Cic.obj -> Cic.obj) ->
add_composites:bool -> GrafiteTypes.status ->
let command_error msg = raise (Command_error msg)
-type incomplete_proof = {
- proof: ProofEngineTypes.proof;
- stack: Continuationals.Stack.t;
-}
-
-type proof_status =
- | No_proof
- | Incomplete_proof of incomplete_proof
- | Proof of ProofEngineTypes.proof
- | Intermediate of Cic.metasenv
- (* Status in which the proof could be while it is being processed by the
- * engine. No status entering/exiting the engine could be in it. *)
-
class status = fun (b : string) ->
let fake_obj =
NUri.uri_of_string "cic:/matita/dummy.decl",0,[],[],
in
object
val moo_content_rev = ([] : GrafiteMarshal.moo)
- val proof_status = No_proof
val objects = ([] : UriManager.uri list)
val coercions = CoercDb.empty_coerc_db
- val automation_cache = AutomationCache.empty ()
val baseuri = b
val ng_mode = (`CommandMode : [`CommandMode | `ProofMode])
method moo_content_rev = moo_content_rev
method set_moo_content_rev v = {< moo_content_rev = v >}
- method proof_status = proof_status
- method set_proof_status v = {< proof_status = v >}
method objects = objects
method set_objects v = {< objects = v >}
method coercions = coercions
method set_coercions v = {< coercions = v >}
- method automation_cache = automation_cache
- method set_automation_cache v = {< automation_cache = v >}
method baseuri = baseuri
method set_baseuri v = {< baseuri = v >}
method ng_mode = ng_mode;
inherit ([Continuationals.Stack.t] NTacStatus.status fake_obj (Continuationals.Stack.empty))
end
-let get_current_proof status =
- match status#proof_status with
- | Incomplete_proof { proof = p } -> p
- | Proof p -> p
- | _ -> raise (Statement_error "no ongoing proof")
-
-let get_proof_metasenv status =
- match status#proof_status with
- | No_proof -> []
- | Proof (_, metasenv, _, _, _, _)
- | Incomplete_proof { proof = (_, metasenv, _, _, _, _) }
- | Intermediate metasenv ->
- metasenv
-
-let get_stack status =
- match status#proof_status with
- | Incomplete_proof p -> p.stack
- | Proof _ -> Continuationals.Stack.empty
- | _ -> assert false
-
-let set_stack stack status =
- match status#proof_status with
- | Incomplete_proof p ->
- status#set_proof_status (Incomplete_proof { p with stack = stack })
- | Proof _ ->
- assert (Continuationals.Stack.is_empty stack);
- status
- | _ -> assert false
-
-let set_metasenv metasenv status =
- let proof_status =
- match status#proof_status with
- | No_proof -> Intermediate metasenv
- | Incomplete_proof ({ proof = (uri, _, subst, proof, ty, attrs) } as incomplete_proof) ->
- Incomplete_proof
- { incomplete_proof with proof = (uri, metasenv, subst, proof, ty, attrs) }
- | Intermediate _ -> Intermediate metasenv
- | Proof (_, metasenv', _, _, _, _) ->
- assert (metasenv = metasenv');
- status#proof_status
- in
- status#set_proof_status proof_status
-
-let get_proof_context status goal =
- match status#proof_status with
- | Incomplete_proof { proof = (_, metasenv, _, _, _, _) } ->
- let (_, context, _) = CicUtil.lookup_meta goal metasenv in
- context
- | _ -> []
-
-let get_proof_conclusion status goal =
- match status#proof_status with
- | Incomplete_proof { proof = (_, metasenv, _, _, _, _) } ->
- let (_, _, conclusion) = CicUtil.lookup_meta goal metasenv in
- conclusion
- | _ -> raise (Statement_error "no ongoing proof")
-
let add_moo_content cmds status =
let content = status#moo_content_rev in
let content' =
let dump_status status =
HLog.message "status.aliases:\n";
HLog.message "status.proof_status:";
- HLog.message
- (match status#proof_status with
- | No_proof -> "no proof\n"
- | Incomplete_proof _ -> "incomplete proof\n"
- | Proof _ -> "proof\n"
- | Intermediate _ -> "Intermediate\n");
HLog.message "status.options\n";
HLog.message "status.coercions\n";
HLog.message "status.objects:\n";
val command_error: string -> 'a (** @raise Command_error *)
-type incomplete_proof = {
- proof: ProofEngineTypes.proof;
- stack: Continuationals.Stack.t;
-}
-
-type proof_status =
- No_proof
- | Incomplete_proof of incomplete_proof
- | Proof of ProofEngineTypes.proof
- | Intermediate of Cic.metasenv
-
class status :
string ->
object ('self)
method moo_content_rev: GrafiteMarshal.moo
method set_moo_content_rev: GrafiteMarshal.moo -> 'self
- method proof_status: proof_status
- method set_proof_status: proof_status -> 'self
method objects: UriManager.uri list
method set_objects: UriManager.uri list -> 'self
method coercions: CoercDb.coerc_db
method set_coercions: CoercDb.coerc_db -> 'self
- method automation_cache:AutomationCache.cache
- method set_automation_cache:AutomationCache.cache -> 'self
method baseuri: string
method set_baseuri: string -> 'self
method ng_mode: [`ProofMode | `CommandMode]
(** list is not reversed, head command will be the first emitted *)
val add_moo_content: GrafiteMarshal.ast_command list -> status -> status
-
-val get_current_proof: status -> ProofEngineTypes.proof
-val get_proof_metasenv: status -> Cic.metasenv
-val get_stack: status -> Continuationals.Stack.t
-val get_proof_context : status -> int -> Cic.context
-val get_proof_conclusion : status -> int -> Cic.term
-
-val set_stack: Continuationals.Stack.t -> status -> status
-val set_metasenv: Cic.metasenv -> status -> status
let estatus = LexiconEngine.set_proof_aliases estatus diff in
estatus, cic
;;
-let disambiguate_command estatus ?baseuri metasenv (text,prefix_len,cmd)=
+let disambiguate_command estatus ?baseuri (text,prefix_len,cmd)=
match cmd with
| GrafiteAst.Index(loc,key,uri) -> (* MATITA 1.0 *) assert false
| GrafiteAst.Select (loc,uri) ->
- estatus, metasenv, GrafiteAst.Select(loc,uri)
- | GrafiteAst.Pump(loc,i) ->
- estatus, metasenv, GrafiteAst.Pump(loc,i)
+ estatus, GrafiteAst.Select(loc,uri)
| GrafiteAst.PreferCoercion (loc,t) -> (* MATITA 1.0 *) assert false
| GrafiteAst.Coercion (loc,t,b,a,s) -> (* MATITA 1.0 *) assert false
| GrafiteAst.Inverter (loc,n,indty,params) -> (* MATITA 1.0 *) assert false
| GrafiteAst.Print _
| GrafiteAst.Qed _
| GrafiteAst.Set _ as cmd ->
- estatus,metasenv,cmd
+ estatus,cmd
| GrafiteAst.Obj (loc,obj) -> (* MATITA 1.0 *) assert false
| GrafiteAst.Relation (loc,id,a,aeq,refl,sym,trans) -> (* MATITA 1.0 *) assert false
val disambiguate_command:
LexiconEngine.status as 'status ->
?baseuri:string ->
- Cic.metasenv ->
((CicNotationPt.term,CicNotationPt.term CicNotationPt.obj) GrafiteAst.command) Disambiguate.disambiguator_input ->
- 'status * Cic.metasenv * (Cic.term,Cic.obj) GrafiteAst.command
+ 'status * (Cic.term,Cic.obj) GrafiteAst.command
val disambiguate_nterm :
NCic.term option ->
disambiguateChoices.cmx: disambiguateChoices.cmi
nCicDisambiguate.cmo: nCicDisambiguate.cmi
nCicDisambiguate.cmx: nCicDisambiguate.cmi
-nnumber_notation.cmo:
-nnumber_notation.cmx:
+nnumber_notation.cmo: disambiguateChoices.cmi
+nnumber_notation.cmx: disambiguateChoices.cmx
+continuationals.cmi:
nCicTacReduction.cmi:
-nTacStatus.cmi:
+nTacStatus.cmi: continuationals.cmi
nCicElim.cmi:
-nTactics.cmi: nTacStatus.cmi
-zipTree.cmi:
-andOrTree.cmi: zipTree.cmi
+nTactics.cmi: nTacStatus.cmi continuationals.cmi
nnAuto.cmi: nTacStatus.cmi
-nAuto.cmi: nTacStatus.cmi
-nInversion.cmi: nTacStatus.cmi
nDestructTac.cmi: nTacStatus.cmi
+nInversion.cmi: nTacStatus.cmi
+continuationals.cmo: continuationals.cmi
+continuationals.cmx: continuationals.cmi
nCicTacReduction.cmo: nCicTacReduction.cmi
nCicTacReduction.cmx: nCicTacReduction.cmi
-nTacStatus.cmo: nCicTacReduction.cmi nTacStatus.cmi
-nTacStatus.cmx: nCicTacReduction.cmx nTacStatus.cmi
+nTacStatus.cmo: nCicTacReduction.cmi continuationals.cmi nTacStatus.cmi
+nTacStatus.cmx: nCicTacReduction.cmx continuationals.cmx nTacStatus.cmi
nCicElim.cmo: nCicElim.cmi
nCicElim.cmx: nCicElim.cmi
-nTactics.cmo: nTacStatus.cmi nCicElim.cmi nTactics.cmi
-nTactics.cmx: nTacStatus.cmx nCicElim.cmx nTactics.cmi
-zipTree.cmo: zipTree.cmi
-zipTree.cmx: zipTree.cmi
-andOrTree.cmo: zipTree.cmi andOrTree.cmi
-andOrTree.cmx: zipTree.cmx andOrTree.cmi
-nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi nnAuto.cmi
-nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx nnAuto.cmi
-nAuto.cmo: zipTree.cmi nnAuto.cmi nTactics.cmi nTacStatus.cmi andOrTree.cmi \
- nAuto.cmi
-nAuto.cmx: zipTree.cmx nnAuto.cmx nTactics.cmx nTacStatus.cmx andOrTree.cmx \
- nAuto.cmi
-nInversion.cmo: nTactics.cmi nCicElim.cmi nInversion.cmi
-nInversion.cmx: nTactics.cmx nCicElim.cmx nInversion.cmi
-nDestructTac.cmo: nTactics.cmi nTacStatus.cmi nDestructTac.cmi
-nDestructTac.cmx: nTactics.cmx nTacStatus.cmx nDestructTac.cmi
+nTactics.cmo: nTacStatus.cmi nCicElim.cmi continuationals.cmi nTactics.cmi
+nTactics.cmx: nTacStatus.cmx nCicElim.cmx continuationals.cmx nTactics.cmi
+nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi \
+ continuationals.cmi nnAuto.cmi
+nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx \
+ continuationals.cmx nnAuto.cmi
+nDestructTac.cmo: nTactics.cmi nTacStatus.cmi continuationals.cmi \
+ nDestructTac.cmi
+nDestructTac.cmx: nTactics.cmx nTacStatus.cmx continuationals.cmx \
+ nDestructTac.cmi
+nInversion.cmo: nTactics.cmi nCicElim.cmi continuationals.cmi nInversion.cmi
+nInversion.cmx: nTactics.cmx nCicElim.cmx continuationals.cmx nInversion.cmi
+continuationals.cmi:
nCicTacReduction.cmi:
-nTacStatus.cmi:
+nTacStatus.cmi: continuationals.cmi
nCicElim.cmi:
-nTactics.cmi: nTacStatus.cmi
-zipTree.cmi:
-andOrTree.cmi: zipTree.cmi
+nTactics.cmi: nTacStatus.cmi continuationals.cmi
nnAuto.cmi: nTacStatus.cmi
-nAuto.cmi: nTacStatus.cmi
-nInversion.cmi: nTacStatus.cmi
nDestructTac.cmi: nTacStatus.cmi
+nInversion.cmi: nTacStatus.cmi
+continuationals.cmo: continuationals.cmi
+continuationals.cmx: continuationals.cmi
nCicTacReduction.cmo: nCicTacReduction.cmi
nCicTacReduction.cmx: nCicTacReduction.cmi
-nTacStatus.cmo: nCicTacReduction.cmi nTacStatus.cmi
-nTacStatus.cmx: nCicTacReduction.cmx nTacStatus.cmi
+nTacStatus.cmo: nCicTacReduction.cmi continuationals.cmi nTacStatus.cmi
+nTacStatus.cmx: nCicTacReduction.cmx continuationals.cmx nTacStatus.cmi
nCicElim.cmo: nCicElim.cmi
nCicElim.cmx: nCicElim.cmi
-nTactics.cmo: nTacStatus.cmi nCicElim.cmi nTactics.cmi
-nTactics.cmx: nTacStatus.cmx nCicElim.cmx nTactics.cmi
-zipTree.cmo: zipTree.cmi
-zipTree.cmx: zipTree.cmi
-andOrTree.cmo: zipTree.cmi andOrTree.cmi
-andOrTree.cmx: zipTree.cmx andOrTree.cmi
-nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi nnAuto.cmi
-nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx nnAuto.cmi
-nAuto.cmo: zipTree.cmi nnAuto.cmi nTactics.cmi nTacStatus.cmi andOrTree.cmi \
- nAuto.cmi
-nAuto.cmx: zipTree.cmx nnAuto.cmx nTactics.cmx nTacStatus.cmx andOrTree.cmx \
- nAuto.cmi
-nInversion.cmo: nTactics.cmi nCicElim.cmi nInversion.cmi
-nInversion.cmx: nTactics.cmx nCicElim.cmx nInversion.cmi
-nDestructTac.cmo: nTactics.cmi nTacStatus.cmi nDestructTac.cmi
-nDestructTac.cmx: nTactics.cmx nTacStatus.cmx nDestructTac.cmi
+nTactics.cmo: nTacStatus.cmi nCicElim.cmi continuationals.cmi nTactics.cmi
+nTactics.cmx: nTacStatus.cmx nCicElim.cmx continuationals.cmx nTactics.cmi
+nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi \
+ continuationals.cmi nnAuto.cmi
+nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx \
+ continuationals.cmx nnAuto.cmi
+nDestructTac.cmo: nTactics.cmi nTacStatus.cmi continuationals.cmi \
+ nDestructTac.cmi
+nDestructTac.cmx: nTactics.cmx nTacStatus.cmx continuationals.cmx \
+ nDestructTac.cmi
+nInversion.cmo: nTactics.cmi nCicElim.cmi continuationals.cmi nInversion.cmi
+nInversion.cmx: nTactics.cmx nCicElim.cmx continuationals.cmx nInversion.cmi
PACKAGE = ng_tactics
INTERFACE_FILES = \
+ continuationals.mli \
nCicTacReduction.mli \
nTacStatus.mli \
nCicElim.mli \
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+let debug = false
+let debug_print s = if debug then prerr_endline (Lazy.force s) else ()
+
+exception Error of string lazy_t
+let fail msg = raise (Error msg)
+
+type goal = int
+
+module Stack =
+struct
+ type switch = Open of goal | Closed of goal
+ type locator = int * switch
+ type tag = [ `BranchTag | `FocusTag | `NoTag ]
+ type entry = locator list * locator list * locator list * tag
+ type t = entry list
+
+ let empty = [ [], [], [], `NoTag ]
+
+ let fold ~env ~cont ~todo init stack =
+ let rec aux acc depth =
+ function
+ | [] -> acc
+ | (locs, todos, conts, tag) :: tl ->
+ let acc = List.fold_left (fun acc -> env acc depth tag) acc locs in
+ let acc = List.fold_left (fun acc -> cont acc depth tag) acc conts in
+ let acc = List.fold_left (fun acc -> todo acc depth tag) acc todos in
+ aux acc (depth + 1) tl
+ in
+ assert (stack <> []);
+ aux init 0 stack
+
+ let iter ~env ~cont ~todo =
+ fold ~env:(fun _ -> env) ~cont:(fun _ -> cont) ~todo:(fun _ -> todo) ()
+
+ let map ~env ~cont ~todo =
+ let depth = ref ~-1 in
+ List.map
+ (fun (s, t, c, tag) ->
+ incr depth;
+ let d = !depth in
+ env d tag s, todo d tag t, cont d tag c, tag)
+
+ let is_open = function _, Open _ -> true | _ -> false
+ let close = function n, Open g -> n, Closed g | l -> l
+ let filter_open = List.filter is_open
+ let is_fresh =
+ function n, Open _ when n > 0 -> true | _,Closed _ -> true | _ -> false
+ let goal_of_loc = function _, Open g | _, Closed g -> g
+ let goal_of_switch = function Open g | Closed g -> g
+ let switch_of_loc = snd
+
+ let zero_pos = List.map (fun g -> 0, Open g)
+
+ let init_pos locs =
+ let pos = ref 0 in (* positions are 1-based *)
+ List.map (function _, sw -> incr pos; !pos, sw) locs
+
+ let extract_pos i =
+ let rec aux acc =
+ function
+ | [] -> fail (lazy (sprintf "relative position %d not found" i))
+ | (i', _) as loc :: tl when i = i' -> loc, (List.rev acc) @ tl
+ | hd :: tl -> aux (hd :: acc) tl
+ in
+ aux []
+
+ let deep_close gs =
+ let close _ _ =
+ List.map (fun l -> if List.mem (goal_of_loc l) gs then close l else l)
+ in
+ let rm _ _ = List.filter (fun l -> not (List.mem (goal_of_loc l) gs)) in
+ map ~env:close ~cont:rm ~todo:rm
+
+ let rec find_goal =
+ function
+ | [] -> raise (Failure "Continuationals.find_goal")
+ | (l :: _, _ , _ , _) :: _ -> goal_of_loc l
+ | ( _ , _ , l :: _, _) :: _ -> goal_of_loc l
+ | ( _ , l :: _, _ , _) :: _ -> goal_of_loc l
+ | _ :: tl -> find_goal tl
+
+ let is_empty =
+ function
+ | [] -> assert false
+ | [ [], [], [], `NoTag ] -> true
+ | _ -> false
+
+ let of_metasenv metasenv =
+ let goals = List.map (fun (g, _, _) -> g) metasenv in
+ [ zero_pos goals, [], [], `NoTag ]
+
+ let of_nmetasenv metasenv =
+ let goals = List.map (fun (g, _) -> g) metasenv in
+ [ zero_pos goals, [], [], `NoTag ]
+
+ let head_switches =
+ function
+ | (locs, _, _, _) :: _ -> List.map switch_of_loc locs
+ | [] -> assert false
+
+ let head_goals =
+ function
+ | (locs, _, _, _) :: _ -> List.map goal_of_loc locs
+ | [] -> assert false
+
+ let head_tag =
+ function
+ | (_, _, _, tag) :: _ -> tag
+ | [] -> assert false
+
+ let shift_goals =
+ function
+ | _ :: (locs, _, _, _) :: _ -> List.map goal_of_loc locs
+ | [] -> assert false
+ | _ -> []
+
+ let open_goals stack =
+ let add_open acc _ _ l = if is_open l then goal_of_loc l :: acc else acc in
+ List.rev (fold ~env:add_open ~cont:add_open ~todo:add_open [] stack)
+
+ let (@+) = (@) (* union *)
+
+ let (@-) s1 s2 = (* difference *)
+ List.fold_right
+ (fun e acc -> if List.mem e s2 then acc else e :: acc)
+ s1 []
+
+ let (@~-) locs gs = (* remove some goals from a locators list *)
+ List.fold_right
+ (fun loc acc -> if List.mem (goal_of_loc loc) gs then acc else loc :: acc)
+ locs []
+
+ let pp stack =
+ let pp_goal = string_of_int in
+ let pp_switch =
+ function Open g -> "o" ^ pp_goal g | Closed g -> "c" ^ pp_goal g
+ in
+ let pp_loc (i, s) = string_of_int i ^ pp_switch s in
+ let pp_env env = sprintf "[%s]" (String.concat ";" (List.map pp_loc env)) in
+ let pp_tag = function `BranchTag -> "B" | `FocusTag -> "F" | `NoTag -> "N" in
+ let pp_stack_entry (env, todo, cont, tag) =
+ sprintf "(%s, %s, %s, %s)" (pp_env env) (pp_env todo) (pp_env cont)
+ (pp_tag tag)
+ in
+ String.concat " :: " (List.map pp_stack_entry stack)
+end
+
+module type Status =
+sig
+ type input_status
+ type output_status
+
+ type tactic
+ val mk_tactic : (input_status -> output_status) -> tactic
+ val apply_tactic : tactic -> input_status -> output_status
+
+ val goals : output_status -> goal list * goal list (** opened, closed goals *)
+ val get_stack : input_status -> Stack.t
+ val set_stack : Stack.t -> output_status -> output_status
+
+ val inject : input_status -> output_status
+ val focus : goal -> output_status -> input_status
+end
+
+module type C =
+sig
+ type input_status
+ type output_status
+ type tactic
+
+ type tactical =
+ | Tactic of tactic
+ | Skip
+
+ type t =
+ | Dot
+ | Semicolon
+
+ | Branch
+ | Shift
+ | Pos of int list
+ | Wildcard
+ | Merge
+
+ | Focus of goal list
+ | Unfocus
+
+ | Tactical of tactical
+
+ val eval: t -> input_status -> output_status
+end
+
+module Make (S: Status) =
+struct
+ open Stack
+
+ type input_status = S.input_status
+ type output_status = S.output_status
+ type tactic = S.tactic
+
+ type tactical =
+ | Tactic of tactic
+ | Skip
+
+ type t =
+ | Dot
+ | Semicolon
+ | Branch
+ | Shift
+ | Pos of int list
+ | Wildcard
+ | Merge
+ | Focus of goal list
+ | Unfocus
+ | Tactical of tactical
+
+ let pp_t =
+ function
+ | Dot -> "Dot"
+ | Semicolon -> "Semicolon"
+ | Branch -> "Branch"
+ | Shift -> "Shift"
+ | Pos i -> "Pos " ^ (String.concat "," (List.map string_of_int i))
+ | Wildcard -> "Wildcard"
+ | Merge -> "Merge"
+ | Focus gs ->
+ sprintf "Focus [%s]" (String.concat "; " (List.map string_of_int gs))
+ | Unfocus -> "Unfocus"
+ | Tactical _ -> "Tactical <abs>"
+
+ let eval_tactical tactical ostatus switch =
+ match tactical, switch with
+ | Tactic tac, Open n ->
+ let ostatus = S.apply_tactic tac (S.focus n ostatus) in
+ let opened, closed = S.goals ostatus in
+ ostatus, opened, closed
+ | Skip, Closed n -> ostatus, [], [n]
+ | Tactic _, Closed _ -> fail (lazy "can't apply tactic to a closed goal")
+ | Skip, Open _ -> fail (lazy "can't skip an open goal")
+
+ let eval cmd istatus =
+ let stack = S.get_stack istatus in
+ debug_print (lazy (sprintf "EVAL CONT %s <- %s" (pp_t cmd) (pp stack)));
+ let new_stack stack = S.inject istatus, stack in
+ let ostatus, stack =
+ match cmd, stack with
+ | _, [] -> assert false
+ | Tactical tac, (g, t, k, tag) :: s ->
+(* COMMENTED OUT TO ALLOW PARAMODULATION TO DO A
+ * auto paramodulation.try assumption.
+ * EVEN IF NO GOALS ARE LEFT OPEN BY AUTO.
+
+ if g = [] then fail (lazy "can't apply a tactic to zero goals");
+
+*)
+ debug_print (lazy ("context length " ^string_of_int (List.length g)));
+ let rec aux s go gc =
+ function
+ | [] -> s, go, gc
+ | loc :: loc_tl ->
+ debug_print (lazy "inner eval tactical");
+ let s, go, gc =
+ if List.exists ((=) (goal_of_loc loc)) gc then
+ s, go, gc
+ else
+ let s, go', gc' = eval_tactical tac s (switch_of_loc loc) in
+ s, (go @- gc') @+ go', gc @+ gc'
+ in
+ aux s go gc loc_tl
+ in
+ let s0, go0, gc0 = S.inject istatus, [], [] in
+ let sn, gon, gcn = aux s0 go0 gc0 g in
+ debug_print (lazy ("opened: "
+ ^ String.concat " " (List.map string_of_int gon)));
+ debug_print (lazy ("closed: "
+ ^ String.concat " " (List.map string_of_int gcn)));
+ let stack =
+ (zero_pos gon, t @~- gcn, k @~- gcn, tag) :: deep_close gcn s
+ in
+ sn, stack
+ | Dot, ([], _, [], _) :: _ ->
+ (* backward compatibility: do-nothing-dot *)
+ new_stack stack
+ | Dot, (g, t, k, tag) :: s ->
+ (match filter_open g, k with
+ | loc :: loc_tl, _ -> new_stack (([ loc ], t, loc_tl @+ k, tag) :: s)
+ | [], loc :: k ->
+ assert (is_open loc);
+ new_stack (([ loc ], t, k, tag) :: s)
+ | _ -> fail (lazy "can't use \".\" here"))
+ | Semicolon, _ -> new_stack stack
+ | Branch, (g, t, k, tag) :: s ->
+ (match init_pos g with
+ | [] | [ _ ] -> fail (lazy "too few goals to branch");
+ | loc :: loc_tl ->
+ new_stack
+ (([ loc ], [], [], `BranchTag) :: (loc_tl, t, k, tag) :: s))
+ | Shift, (g, t, k, `BranchTag) :: (g', t', k', tag) :: s ->
+ (match g' with
+ | [] -> fail (lazy "no more goals to shift")
+ | loc :: loc_tl ->
+ new_stack
+ (([ loc ], t @+ filter_open g @+ k, [],`BranchTag)
+ :: (loc_tl, t', k', tag) :: s))
+ | Shift, _ -> fail (lazy "can't shift goals here")
+ | Pos i_s, ([ loc ], t, [],`BranchTag) :: (g', t', k', tag) :: s
+ when is_fresh loc ->
+ let l_js = List.filter (fun (i, _) -> List.mem i i_s) ([loc] @+ g') in
+ new_stack
+ ((l_js, t , [],`BranchTag)
+ :: (([ loc ] @+ g') @- l_js, t', k', tag) :: s)
+ | Pos _, _ -> fail (lazy "can't use relative positioning here")
+ | Wildcard, ([ loc ] , t, [], `BranchTag) :: (g', t', k', tag) :: s
+ when is_fresh loc ->
+ new_stack
+ (([loc] @+ g', t, [], `BranchTag)
+ :: ([], t', k', tag) :: s)
+ | Wildcard, _ -> fail (lazy "can't use wildcard here")
+ | Merge, (g, t, k,`BranchTag) :: (g', t', k', tag) :: s ->
+ new_stack ((t @+ filter_open g @+ g' @+ k, t', k', tag) :: s)
+ | Merge, _ -> fail (lazy "can't merge goals here")
+ | Focus [], _ -> assert false
+ | Focus gs, s ->
+ let stack_locs =
+ let add_l acc _ _ l = if is_open l then l :: acc else acc in
+ Stack.fold ~env:add_l ~cont:add_l ~todo:add_l [] s
+ in
+ List.iter
+ (fun g ->
+ if not (List.exists (fun l -> goal_of_loc l = g) stack_locs) then
+ fail (lazy (sprintf "goal %d not found (or closed)" g)))
+ gs;
+ new_stack ((zero_pos gs, [], [], `FocusTag) :: deep_close gs s)
+ | Unfocus, ([], [], [], `FocusTag) :: s -> new_stack s
+ | Unfocus, _ -> fail (lazy "can't unfocus, some goals are still open")
+ in
+ debug_print (lazy (sprintf "EVAL CONT %s -> %s" (pp_t cmd) (pp stack)));
+ S.set_stack stack ostatus
+end
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+exception Error of string Lazy.t
+
+type goal = int
+
+(** {2 Goal stack} *)
+
+module Stack:
+sig
+ type switch = Open of goal | Closed of goal
+ type locator = int * switch
+ type tag = [ `BranchTag | `FocusTag | `NoTag ]
+ type entry = locator list * locator list * locator list * tag
+ type t = entry list
+
+ val empty: t
+
+ val find_goal: t -> goal (** find "next" goal *)
+ val is_empty: t -> bool (** a singleton empty level *)
+ val of_metasenv: Cic.metasenv -> t
+ val of_nmetasenv: (goal * 'a) list -> t
+ val head_switches: t -> switch list (** top level switches *)
+ val head_goals: t -> goal list (** top level goals *)
+ val head_tag: t -> tag (** top level tag *)
+ val shift_goals: t -> goal list (** second level goals *)
+ val open_goals: t -> goal list (** all (Open) goals *)
+ val goal_of_switch: switch -> goal
+ val filter_open : (goal * switch) list -> (goal * switch) list
+ val is_open: goal * switch -> bool
+ val is_fresh: goal * switch -> bool
+ val init_pos: (goal * switch) list -> (goal * switch) list
+ val goal_of_loc: goal * switch -> goal
+ val switch_of_loc: goal * switch -> switch
+ val zero_pos : goal list -> (goal * switch) list
+ val deep_close: goal list -> t -> t
+
+
+ val ( @+ ) : 'a list -> 'a list -> 'a list
+ val ( @- ) : 'a list -> 'a list -> 'a list
+ val ( @~- ) : ('a * switch) list -> goal list -> ('a * switch) list
+
+
+
+ (** @param int depth, depth 0 is the top of the stack *)
+ val fold:
+ env: ('a -> int -> tag -> locator -> 'a) ->
+ cont:('a -> int -> tag -> locator -> 'a) ->
+ todo:('a -> int -> tag -> locator -> 'a) ->
+ 'a -> t -> 'a
+
+ val iter: (** @param depth as above *)
+ env: (int -> tag -> locator -> unit) ->
+ cont:(int -> tag -> locator -> unit) ->
+ todo:(int -> tag -> locator -> unit) ->
+ t -> unit
+
+ val map: (** @param depth as above *)
+ env: (int -> tag -> locator list -> locator list) ->
+ cont:(int -> tag -> locator list -> locator list) ->
+ todo:(int -> tag -> locator list -> locator list) ->
+ t -> t
+
+ val pp: t -> string
+end
+
+(** {2 Functorial interface} *)
+
+module type Status =
+sig
+ type input_status
+ type output_status
+
+ type tactic
+ val mk_tactic : (input_status -> output_status) -> tactic
+ val apply_tactic : tactic -> input_status -> output_status
+
+ val goals : output_status -> goal list * goal list (** opened, closed goals *)
+ val get_stack : input_status -> Stack.t
+ val set_stack : Stack.t -> output_status -> output_status
+
+ val inject : input_status -> output_status
+ val focus : goal -> output_status -> input_status
+end
+
+module type C =
+sig
+ type input_status
+ type output_status
+ type tactic
+
+ type tactical =
+ | Tactic of tactic
+ | Skip
+
+ type t =
+ | Dot
+ | Semicolon
+
+ | Branch
+ | Shift
+ | Pos of int list
+ | Wildcard
+ | Merge
+
+ | Focus of goal list
+ | Unfocus
+
+ | Tactical of tactical
+
+ val eval: t -> input_status -> output_status
+end
+
+module Make (S: Status) : C
+ with type tactic = S.tactic
+ and type input_status = S.input_status
+ and type output_status = S.output_status
+
+++ /dev/null
-proofEngineTypes.cmi:
-proofEngineHelpers.cmi: proofEngineTypes.cmi
-proofEngineReduction.cmi:
-continuationals.cmi: proofEngineTypes.cmi
-tacticals.cmi: proofEngineTypes.cmi
-reductionTactics.cmi: proofEngineTypes.cmi
-proofEngineStructuralRules.cmi: proofEngineTypes.cmi
-primitiveTactics.cmi: proofEngineTypes.cmi
-hashtbl_equiv.cmi:
-metadataQuery.cmi: proofEngineTypes.cmi
-universe.cmi:
-autoTypes.cmi: proofEngineTypes.cmi
-autoCache.cmi:
-paramodulation/utils.cmi:
-closeCoercionGraph.cmi:
-paramodulation/subst.cmi:
-paramodulation/equality.cmi: paramodulation/utils.cmi \
- paramodulation/subst.cmi
-paramodulation/founif.cmi: paramodulation/subst.cmi
-paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \
- paramodulation/equality.cmi
-paramodulation/indexing.cmi: paramodulation/utils.cmi \
- paramodulation/subst.cmi paramodulation/equality_indexing.cmi \
- paramodulation/equality.cmi
-paramodulation/saturation.cmi: paramodulation/utils.cmi proofEngineTypes.cmi \
- paramodulation/indexing.cmi paramodulation/equality.cmi
-automationCache.cmi: universe.cmi paramodulation/saturation.cmi \
- paramodulation/equality.cmi
-variousTactics.cmi: proofEngineTypes.cmi
-compose.cmi: proofEngineTypes.cmi
-introductionTactics.cmi: proofEngineTypes.cmi
-eliminationTactics.cmi: proofEngineTypes.cmi
-negationTactics.cmi: proofEngineTypes.cmi
-equalityTactics.cmi: proofEngineTypes.cmi
-auto.cmi: proofEngineTypes.cmi automationCache.cmi
-destructTactic.cmi: proofEngineTypes.cmi
-inversion.cmi: proofEngineTypes.cmi
-inversion_principle.cmi:
-ring.cmi: proofEngineTypes.cmi
-setoids.cmi: proofEngineTypes.cmi
-fourier.cmi:
-fourierR.cmi: proofEngineTypes.cmi
-fwdSimplTactic.cmi: proofEngineTypes.cmi
-history.cmi:
-statefulProofEngine.cmi: proofEngineTypes.cmi
-tactics.cmi: tacticals.cmi proofEngineTypes.cmi automationCache.cmi auto.cmi
-declarative.cmi: proofEngineTypes.cmi automationCache.cmi auto.cmi
-proofEngineTypes.cmo: proofEngineTypes.cmi
-proofEngineTypes.cmx: proofEngineTypes.cmi
-proofEngineHelpers.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi
-proofEngineHelpers.cmx: proofEngineTypes.cmx proofEngineHelpers.cmi
-proofEngineReduction.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi \
- proofEngineReduction.cmi
-proofEngineReduction.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \
- proofEngineReduction.cmi
-continuationals.cmo: proofEngineTypes.cmi continuationals.cmi
-continuationals.cmx: proofEngineTypes.cmx continuationals.cmi
-tacticals.cmo: proofEngineTypes.cmi continuationals.cmi tacticals.cmi
-tacticals.cmx: proofEngineTypes.cmx continuationals.cmx tacticals.cmi
-reductionTactics.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi reductionTactics.cmi
-reductionTactics.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx reductionTactics.cmi
-proofEngineStructuralRules.cmo: proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi
-proofEngineStructuralRules.cmx: proofEngineTypes.cmx \
- proofEngineStructuralRules.cmi
-primitiveTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi
-primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmi
-hashtbl_equiv.cmo: hashtbl_equiv.cmi
-hashtbl_equiv.cmx: hashtbl_equiv.cmi
-metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- hashtbl_equiv.cmi metadataQuery.cmi
-metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- hashtbl_equiv.cmx metadataQuery.cmi
-universe.cmo: proofEngineTypes.cmi proofEngineReduction.cmi universe.cmi
-universe.cmx: proofEngineTypes.cmx proofEngineReduction.cmx universe.cmi
-autoTypes.cmo: autoTypes.cmi
-autoTypes.cmx: autoTypes.cmi
-autoCache.cmo: universe.cmi autoCache.cmi
-autoCache.cmx: universe.cmx autoCache.cmi
-paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi
-paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi
-closeCoercionGraph.cmo: closeCoercionGraph.cmi
-closeCoercionGraph.cmx: closeCoercionGraph.cmi
-paramodulation/subst.cmo: paramodulation/subst.cmi
-paramodulation/subst.cmx: paramodulation/subst.cmi
-paramodulation/equality.cmo: paramodulation/utils.cmi \
- paramodulation/subst.cmi proofEngineTypes.cmi proofEngineReduction.cmi \
- paramodulation/equality.cmi
-paramodulation/equality.cmx: paramodulation/utils.cmx \
- paramodulation/subst.cmx proofEngineTypes.cmx proofEngineReduction.cmx \
- paramodulation/equality.cmi
-paramodulation/founif.cmo: paramodulation/utils.cmi paramodulation/subst.cmi \
- paramodulation/founif.cmi
-paramodulation/founif.cmx: paramodulation/utils.cmx paramodulation/subst.cmx \
- paramodulation/founif.cmi
-paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \
- paramodulation/equality.cmi paramodulation/equality_indexing.cmi
-paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \
- paramodulation/equality.cmx paramodulation/equality_indexing.cmi
-paramodulation/indexing.cmo: paramodulation/utils.cmi \
- paramodulation/subst.cmi proofEngineTypes.cmi paramodulation/founif.cmi \
- paramodulation/equality_indexing.cmi paramodulation/equality.cmi \
- paramodulation/indexing.cmi
-paramodulation/indexing.cmx: paramodulation/utils.cmx \
- paramodulation/subst.cmx proofEngineTypes.cmx paramodulation/founif.cmx \
- paramodulation/equality_indexing.cmx paramodulation/equality.cmx \
- paramodulation/indexing.cmi
-paramodulation/saturation.cmo: paramodulation/utils.cmi \
- paramodulation/subst.cmi proofEngineTypes.cmi proofEngineHelpers.cmi \
- paramodulation/indexing.cmi paramodulation/founif.cmi \
- paramodulation/equality.cmi paramodulation/saturation.cmi
-paramodulation/saturation.cmx: paramodulation/utils.cmx \
- paramodulation/subst.cmx proofEngineTypes.cmx proofEngineHelpers.cmx \
- paramodulation/indexing.cmx paramodulation/founif.cmx \
- paramodulation/equality.cmx paramodulation/saturation.cmi
-automationCache.cmo: universe.cmi paramodulation/saturation.cmi \
- paramodulation/equality.cmi automationCache.cmi
-automationCache.cmx: universe.cmx paramodulation/saturation.cmx \
- paramodulation/equality.cmx automationCache.cmi
-variousTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- variousTactics.cmi
-variousTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- variousTactics.cmi
-compose.cmo: proofEngineTypes.cmi primitiveTactics.cmi closeCoercionGraph.cmi \
- compose.cmi
-compose.cmx: proofEngineTypes.cmx primitiveTactics.cmx closeCoercionGraph.cmx \
- compose.cmi
-introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- introductionTactics.cmi
-introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- introductionTactics.cmi
-eliminationTactics.cmo: tacticals.cmi reductionTactics.cmi \
- proofEngineTypes.cmi proofEngineStructuralRules.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi eliminationTactics.cmi
-eliminationTactics.cmx: tacticals.cmx reductionTactics.cmx \
- proofEngineTypes.cmx proofEngineStructuralRules.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx eliminationTactics.cmi
-negationTactics.cmo: variousTactics.cmi tacticals.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi eliminationTactics.cmi negationTactics.cmi
-negationTactics.cmx: variousTactics.cmx tacticals.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx eliminationTactics.cmx negationTactics.cmi
-equalityTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi introductionTactics.cmi \
- equalityTactics.cmi
-equalityTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx introductionTactics.cmx \
- equalityTactics.cmi
-auto.cmo: paramodulation/utils.cmi universe.cmi paramodulation/subst.cmi \
- paramodulation/saturation.cmi proofEngineTypes.cmi \
- proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- metadataQuery.cmi paramodulation/indexing.cmi equalityTactics.cmi \
- paramodulation/equality.cmi automationCache.cmi autoTypes.cmi \
- autoCache.cmi auto.cmi
-auto.cmx: paramodulation/utils.cmx universe.cmx paramodulation/subst.cmx \
- paramodulation/saturation.cmx proofEngineTypes.cmx \
- proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- metadataQuery.cmx paramodulation/indexing.cmx equalityTactics.cmx \
- paramodulation/equality.cmx automationCache.cmx autoTypes.cmx \
- autoCache.cmx auto.cmi
-destructTactic.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
- primitiveTactics.cmi introductionTactics.cmi equalityTactics.cmi \
- eliminationTactics.cmi destructTactic.cmi
-destructTactic.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
- primitiveTactics.cmx introductionTactics.cmx equalityTactics.cmx \
- eliminationTactics.cmx destructTactic.cmi
-inversion.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- equalityTactics.cmi inversion.cmi
-inversion.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- equalityTactics.cmx inversion.cmi
-inversion_principle.cmo: tacticals.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi inversion.cmi inversion_principle.cmi
-inversion_principle.cmx: tacticals.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx inversion.cmx inversion_principle.cmi
-ring.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineStructuralRules.cmi \
- primitiveTactics.cmi equalityTactics.cmi eliminationTactics.cmi ring.cmi
-ring.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineStructuralRules.cmx \
- primitiveTactics.cmx equalityTactics.cmx eliminationTactics.cmx ring.cmi
-setoids.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi equalityTactics.cmi setoids.cmi
-setoids.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx equalityTactics.cmx setoids.cmi
-fourier.cmo: fourier.cmi
-fourier.cmx: fourier.cmi
-fourierR.cmo: tacticals.cmi ring.cmi reductionTactics.cmi \
- proofEngineTypes.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- fourier.cmi equalityTactics.cmi fourierR.cmi
-fourierR.cmx: tacticals.cmx ring.cmx reductionTactics.cmx \
- proofEngineTypes.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- fourier.cmx equalityTactics.cmx fourierR.cmi
-fwdSimplTactic.cmo: tacticals.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
- primitiveTactics.cmi fwdSimplTactic.cmi
-fwdSimplTactic.cmx: tacticals.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
- primitiveTactics.cmx fwdSimplTactic.cmi
-history.cmo: history.cmi
-history.cmx: history.cmi
-statefulProofEngine.cmo: proofEngineTypes.cmi history.cmi \
- statefulProofEngine.cmi
-statefulProofEngine.cmx: proofEngineTypes.cmx history.cmx \
- statefulProofEngine.cmi
-tactics.cmo: variousTactics.cmi tacticals.cmi setoids.cmi ring.cmi \
- reductionTactics.cmi proofEngineStructuralRules.cmi primitiveTactics.cmi \
- negationTactics.cmi inversion.cmi introductionTactics.cmi \
- fwdSimplTactic.cmi fourierR.cmi equalityTactics.cmi \
- eliminationTactics.cmi destructTactic.cmi compose.cmi \
- closeCoercionGraph.cmi auto.cmi tactics.cmi
-tactics.cmx: variousTactics.cmx tacticals.cmx setoids.cmx ring.cmx \
- reductionTactics.cmx proofEngineStructuralRules.cmx primitiveTactics.cmx \
- negationTactics.cmx inversion.cmx introductionTactics.cmx \
- fwdSimplTactic.cmx fourierR.cmx equalityTactics.cmx \
- eliminationTactics.cmx destructTactic.cmx compose.cmx \
- closeCoercionGraph.cmx auto.cmx tactics.cmi
-declarative.cmo: tactics.cmi tacticals.cmi proofEngineTypes.cmi auto.cmi \
- declarative.cmi
-declarative.cmx: tactics.cmx tacticals.cmx proofEngineTypes.cmx auto.cmx \
- declarative.cmi
+++ /dev/null
-proofEngineTypes.cmi:
-proofEngineHelpers.cmi: proofEngineTypes.cmi
-proofEngineReduction.cmi:
-continuationals.cmi: proofEngineTypes.cmi
-tacticals.cmi: proofEngineTypes.cmi
-reductionTactics.cmi: proofEngineTypes.cmi
-proofEngineStructuralRules.cmi: proofEngineTypes.cmi
-primitiveTactics.cmi: proofEngineTypes.cmi
-hashtbl_equiv.cmi:
-metadataQuery.cmi: proofEngineTypes.cmi
-universe.cmi:
-autoTypes.cmi: proofEngineTypes.cmi
-autoCache.cmi:
-paramodulation/utils.cmi:
-closeCoercionGraph.cmi:
-paramodulation/subst.cmi:
-paramodulation/equality.cmi: paramodulation/utils.cmi \
- paramodulation/subst.cmi
-paramodulation/founif.cmi: paramodulation/subst.cmi
-paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \
- paramodulation/equality.cmi
-paramodulation/indexing.cmi: paramodulation/utils.cmi \
- paramodulation/subst.cmi paramodulation/equality_indexing.cmi \
- paramodulation/equality.cmi
-paramodulation/saturation.cmi: paramodulation/utils.cmi proofEngineTypes.cmi \
- paramodulation/indexing.cmi paramodulation/equality.cmi
-automationCache.cmi: universe.cmi paramodulation/saturation.cmi \
- paramodulation/equality.cmi
-variousTactics.cmi: proofEngineTypes.cmi
-compose.cmi: proofEngineTypes.cmi
-introductionTactics.cmi: proofEngineTypes.cmi
-eliminationTactics.cmi: proofEngineTypes.cmi
-negationTactics.cmi: proofEngineTypes.cmi
-equalityTactics.cmi: proofEngineTypes.cmi
-auto.cmi: proofEngineTypes.cmi automationCache.cmi
-destructTactic.cmi: proofEngineTypes.cmi
-inversion.cmi: proofEngineTypes.cmi
-inversion_principle.cmi:
-ring.cmi: proofEngineTypes.cmi
-setoids.cmi: proofEngineTypes.cmi
-fourier.cmi:
-fourierR.cmi: proofEngineTypes.cmi
-fwdSimplTactic.cmi: proofEngineTypes.cmi
-history.cmi:
-statefulProofEngine.cmi: proofEngineTypes.cmi
-tactics.cmi: tacticals.cmi proofEngineTypes.cmi automationCache.cmi auto.cmi
-declarative.cmi: proofEngineTypes.cmi automationCache.cmi auto.cmi
-proofEngineTypes.cmo: proofEngineTypes.cmi
-proofEngineTypes.cmx: proofEngineTypes.cmi
-proofEngineHelpers.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi
-proofEngineHelpers.cmx: proofEngineTypes.cmx proofEngineHelpers.cmi
-proofEngineReduction.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi \
- proofEngineReduction.cmi
-proofEngineReduction.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \
- proofEngineReduction.cmi
-continuationals.cmo: proofEngineTypes.cmi continuationals.cmi
-continuationals.cmx: proofEngineTypes.cmx continuationals.cmi
-tacticals.cmo: proofEngineTypes.cmi continuationals.cmi tacticals.cmi
-tacticals.cmx: proofEngineTypes.cmx continuationals.cmx tacticals.cmi
-reductionTactics.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi reductionTactics.cmi
-reductionTactics.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx reductionTactics.cmi
-proofEngineStructuralRules.cmo: proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi
-proofEngineStructuralRules.cmx: proofEngineTypes.cmx \
- proofEngineStructuralRules.cmi
-primitiveTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi
-primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmi
-hashtbl_equiv.cmo: hashtbl_equiv.cmi
-hashtbl_equiv.cmx: hashtbl_equiv.cmi
-metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- hashtbl_equiv.cmi metadataQuery.cmi
-metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- hashtbl_equiv.cmx metadataQuery.cmi
-universe.cmo: proofEngineTypes.cmi proofEngineReduction.cmi universe.cmi
-universe.cmx: proofEngineTypes.cmx proofEngineReduction.cmx universe.cmi
-autoTypes.cmo: autoTypes.cmi
-autoTypes.cmx: autoTypes.cmi
-autoCache.cmo: universe.cmi autoCache.cmi
-autoCache.cmx: universe.cmx autoCache.cmi
-paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi
-paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi
-closeCoercionGraph.cmo: closeCoercionGraph.cmi
-closeCoercionGraph.cmx: closeCoercionGraph.cmi
-paramodulation/subst.cmo: paramodulation/subst.cmi
-paramodulation/subst.cmx: paramodulation/subst.cmi
-paramodulation/equality.cmo: paramodulation/utils.cmi \
- paramodulation/subst.cmi proofEngineTypes.cmi proofEngineReduction.cmi \
- paramodulation/equality.cmi
-paramodulation/equality.cmx: paramodulation/utils.cmx \
- paramodulation/subst.cmx proofEngineTypes.cmx proofEngineReduction.cmx \
- paramodulation/equality.cmi
-paramodulation/founif.cmo: paramodulation/utils.cmi paramodulation/subst.cmi \
- paramodulation/founif.cmi
-paramodulation/founif.cmx: paramodulation/utils.cmx paramodulation/subst.cmx \
- paramodulation/founif.cmi
-paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \
- paramodulation/equality.cmi paramodulation/equality_indexing.cmi
-paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \
- paramodulation/equality.cmx paramodulation/equality_indexing.cmi
-paramodulation/indexing.cmo: paramodulation/utils.cmi \
- paramodulation/subst.cmi proofEngineTypes.cmi paramodulation/founif.cmi \
- paramodulation/equality_indexing.cmi paramodulation/equality.cmi \
- paramodulation/indexing.cmi
-paramodulation/indexing.cmx: paramodulation/utils.cmx \
- paramodulation/subst.cmx proofEngineTypes.cmx paramodulation/founif.cmx \
- paramodulation/equality_indexing.cmx paramodulation/equality.cmx \
- paramodulation/indexing.cmi
-paramodulation/saturation.cmo: paramodulation/utils.cmi \
- paramodulation/subst.cmi proofEngineTypes.cmi proofEngineHelpers.cmi \
- paramodulation/indexing.cmi paramodulation/founif.cmi \
- paramodulation/equality.cmi paramodulation/saturation.cmi
-paramodulation/saturation.cmx: paramodulation/utils.cmx \
- paramodulation/subst.cmx proofEngineTypes.cmx proofEngineHelpers.cmx \
- paramodulation/indexing.cmx paramodulation/founif.cmx \
- paramodulation/equality.cmx paramodulation/saturation.cmi
-automationCache.cmo: universe.cmi paramodulation/saturation.cmi \
- paramodulation/equality.cmi automationCache.cmi
-automationCache.cmx: universe.cmx paramodulation/saturation.cmx \
- paramodulation/equality.cmx automationCache.cmi
-variousTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- variousTactics.cmi
-variousTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- variousTactics.cmi
-compose.cmo: proofEngineTypes.cmi primitiveTactics.cmi closeCoercionGraph.cmi \
- compose.cmi
-compose.cmx: proofEngineTypes.cmx primitiveTactics.cmx closeCoercionGraph.cmx \
- compose.cmi
-introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- introductionTactics.cmi
-introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- introductionTactics.cmi
-eliminationTactics.cmo: tacticals.cmi reductionTactics.cmi \
- proofEngineTypes.cmi proofEngineStructuralRules.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi eliminationTactics.cmi
-eliminationTactics.cmx: tacticals.cmx reductionTactics.cmx \
- proofEngineTypes.cmx proofEngineStructuralRules.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx eliminationTactics.cmi
-negationTactics.cmo: variousTactics.cmi tacticals.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi eliminationTactics.cmi negationTactics.cmi
-negationTactics.cmx: variousTactics.cmx tacticals.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx eliminationTactics.cmx negationTactics.cmi
-equalityTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi introductionTactics.cmi \
- equalityTactics.cmi
-equalityTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx introductionTactics.cmx \
- equalityTactics.cmi
-auto.cmo: paramodulation/utils.cmi universe.cmi paramodulation/subst.cmi \
- paramodulation/saturation.cmi proofEngineTypes.cmi \
- proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- metadataQuery.cmi paramodulation/indexing.cmi equalityTactics.cmi \
- paramodulation/equality.cmi automationCache.cmi autoTypes.cmi \
- autoCache.cmi auto.cmi
-auto.cmx: paramodulation/utils.cmx universe.cmx paramodulation/subst.cmx \
- paramodulation/saturation.cmx proofEngineTypes.cmx \
- proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- metadataQuery.cmx paramodulation/indexing.cmx equalityTactics.cmx \
- paramodulation/equality.cmx automationCache.cmx autoTypes.cmx \
- autoCache.cmx auto.cmi
-destructTactic.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
- primitiveTactics.cmi introductionTactics.cmi equalityTactics.cmi \
- eliminationTactics.cmi destructTactic.cmi
-destructTactic.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
- primitiveTactics.cmx introductionTactics.cmx equalityTactics.cmx \
- eliminationTactics.cmx destructTactic.cmi
-inversion.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- equalityTactics.cmi inversion.cmi
-inversion.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- equalityTactics.cmx inversion.cmi
-inversion_principle.cmo: tacticals.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi inversion.cmi inversion_principle.cmi
-inversion_principle.cmx: tacticals.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx inversion.cmx inversion_principle.cmi
-ring.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineStructuralRules.cmi \
- primitiveTactics.cmi equalityTactics.cmi eliminationTactics.cmi ring.cmi
-ring.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineStructuralRules.cmx \
- primitiveTactics.cmx equalityTactics.cmx eliminationTactics.cmx ring.cmi
-setoids.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi equalityTactics.cmi setoids.cmi
-setoids.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx equalityTactics.cmx setoids.cmi
-fourier.cmo: fourier.cmi
-fourier.cmx: fourier.cmi
-fourierR.cmo: tacticals.cmi ring.cmi reductionTactics.cmi \
- proofEngineTypes.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- fourier.cmi equalityTactics.cmi fourierR.cmi
-fourierR.cmx: tacticals.cmx ring.cmx reductionTactics.cmx \
- proofEngineTypes.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- fourier.cmx equalityTactics.cmx fourierR.cmi
-fwdSimplTactic.cmo: tacticals.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
- primitiveTactics.cmi fwdSimplTactic.cmi
-fwdSimplTactic.cmx: tacticals.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
- primitiveTactics.cmx fwdSimplTactic.cmi
-history.cmo: history.cmi
-history.cmx: history.cmi
-statefulProofEngine.cmo: proofEngineTypes.cmi history.cmi \
- statefulProofEngine.cmi
-statefulProofEngine.cmx: proofEngineTypes.cmx history.cmx \
- statefulProofEngine.cmi
-tactics.cmo: variousTactics.cmi tacticals.cmi setoids.cmi ring.cmi \
- reductionTactics.cmi proofEngineStructuralRules.cmi primitiveTactics.cmi \
- negationTactics.cmi inversion.cmi introductionTactics.cmi \
- fwdSimplTactic.cmi fourierR.cmi equalityTactics.cmi \
- eliminationTactics.cmi destructTactic.cmi compose.cmi \
- closeCoercionGraph.cmi auto.cmi tactics.cmi
-tactics.cmx: variousTactics.cmx tacticals.cmx setoids.cmx ring.cmx \
- reductionTactics.cmx proofEngineStructuralRules.cmx primitiveTactics.cmx \
- negationTactics.cmx inversion.cmx introductionTactics.cmx \
- fwdSimplTactic.cmx fourierR.cmx equalityTactics.cmx \
- eliminationTactics.cmx destructTactic.cmx compose.cmx \
- closeCoercionGraph.cmx auto.cmx tactics.cmi
-declarative.cmo: tactics.cmi tacticals.cmi proofEngineTypes.cmi auto.cmi \
- declarative.cmi
-declarative.cmx: tactics.cmx tacticals.cmx proofEngineTypes.cmx auto.cmx \
- declarative.cmi
+++ /dev/null
-PACKAGE = tactics
-
-INTERFACE_FILES = \
- proofEngineTypes.mli \
- proofEngineHelpers.mli proofEngineReduction.mli \
- continuationals.mli \
- tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \
- primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \
- universe.mli \
- autoTypes.mli \
- autoCache.mli \
- paramodulation/utils.mli \
- closeCoercionGraph.mli \
- paramodulation/subst.mli \
- paramodulation/equality.mli\
- paramodulation/founif.mli\
- paramodulation/equality_indexing.mli\
- paramodulation/indexing.mli \
- paramodulation/saturation.mli \
- automationCache.mli \
- variousTactics.mli \
- compose.mli \
- introductionTactics.mli eliminationTactics.mli negationTactics.mli \
- equalityTactics.mli \
- auto.mli \
- destructTactic.mli \
- inversion.mli inversion_principle.mli ring.mli setoids.mli \
- fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \
- statefulProofEngine.mli tactics.mli declarative.mli
-
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-
-all:
-
-# we omit dependencies since it is a pain when distributing
-tactics_mli_deps = tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli
-tactics.mli: tactics.ml
- $(H)echo " OCAMLC -i $$(tactics_mli_deps) > $@"
- $(H)echo "(* GENERATED FILE, DO NOT EDIT. STAMP:`date` *)" > $@
- $(H)$(OCAMLC) -I paramodulation -i tactics.ml >> $@
-
-UTF8DIR = $(shell $(OCAMLFIND) query helm-syntax_extensions)
-STR=$(shell $(OCAMLFIND) query str)
-MY_SYNTAXOPTIONS = -pp "camlp5o -I $(UTF8DIR) -I $(STR) str.cma pa_extend.cmo profiling_macros.cma -loc loc"
-paramodulation/%.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS)
-paramodulation/%.cmo: OCAMLC = $(OCAMLC_P4)
-paramodulation/%.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS)
-paramodulation/%.cmx: OCAMLOPT = $(OCAMLOPT_P4)
-
-depend: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS)
-depend.opt: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS)
-
-STATS_EXCLUDE = tactics.mli
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-OCAMLOPTIONS+= -I paramodulation
-OCAMLDEPOPTIONS+= -I paramodulation
-#PREPROCOPTIONS:=
-#OCAML_PROF=p -p a
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-open AutoTypes;;
-open AutoCache;;
-
-let debug = false;;
-let debug_print s =
- if debug then prerr_endline (Lazy.force s);;
-
-
-let mk_irl ctx = CicMkImplicit.identity_relocation_list_for_metavariable ctx;;
-let ugraph = CicUniv.oblivion_ugraph;;
-let typeof = CicTypeChecker.type_of_aux';;
-let ppterm ctx t =
- let names = List.map (function None -> None | Some (x,_) -> Some x) ctx in
- CicPp.pp t names
-;;
-
-let is_propositional context sort =
- match CicReduction.whd context sort with
- | Cic.Sort Cic.Prop
- | Cic.Sort (Cic.CProp _) -> true
- | _-> false
-;;
-
-let is_in_prop context subst metasenv ty =
- let sort,u = typeof ~subst metasenv context ty CicUniv.oblivion_ugraph in
- is_propositional context sort
-;;
-
-exception NotConvertible;;
-
-let check_proof_is_valid proof metasenv context goalty =
- if debug then
- begin
- try
- let ty,u = typeof metasenv context proof CicUniv.oblivion_ugraph in
- let b,_ = CicReduction.are_convertible context ty goalty u in
- if not b then raise NotConvertible else b
- with _ ->
- let names =
- List.map (function None -> None | Some (x,_) -> Some x) context
- in
- debug_print (lazy ("PROOF:" ^ CicPp.pp proof names));
- (* debug_print (lazy ("PROOFTY:" ^ CicPp.pp ty names)); *)
- debug_print (lazy ("GOAL:" ^ CicPp.pp goalty names));
- debug_print (lazy ("MENV:" ^ CicMetaSubst.ppmetasenv [] metasenv));
- false
- end
- else true
-;;
-
-let assert_proof_is_valid proof metasenv context goalty =
- assert (check_proof_is_valid proof metasenv context goalty)
-;;
-
-let assert_subst_are_disjoint subst subst' =
- if debug then
- assert(List.for_all
- (fun (i,_) -> List.for_all (fun (j,_) -> i<>j) subst')
- subst)
- else ()
-;;
-
-let split_goals_in_prop metasenv subst gl =
- List.partition
- (fun g ->
- let _,context,ty = CicUtil.lookup_meta g metasenv in
- try
- let sort,u = typeof ~subst metasenv context ty ugraph in
- is_propositional context sort
- with
- | CicTypeChecker.AssertFailure s
- | CicTypeChecker.TypeCheckerFailure s ->
- debug_print
- (lazy ("NON TIPA" ^ ppterm context (CicMetaSubst.apply_subst subst ty)));
- debug_print s;
- false)
- (* FIXME... they should type! *)
- gl
-;;
-
-let split_goals_with_metas metasenv subst gl =
- List.partition
- (fun g ->
- let _,context,ty = CicUtil.lookup_meta g metasenv in
- let ty = CicMetaSubst.apply_subst subst ty in
- CicUtil.is_meta_closed ty)
- gl
-;;
-
-let order_new_goals metasenv subst open_goals ppterm =
- let prop,rest = split_goals_in_prop metasenv subst open_goals in
- let closed_prop, open_prop = split_goals_with_metas metasenv subst prop in
- let closed_type, open_type = split_goals_with_metas metasenv subst rest in
- let open_goals =
- (List.map (fun x -> x,P) (open_prop @ closed_prop))
- @
- (List.map (fun x -> x,T) (open_type @ closed_type))
- in
- let tys =
- List.map
- (fun (i,sort) ->
- let _,_,ty = CicUtil.lookup_meta i metasenv in i,ty,sort) open_goals
- in
- debug_print (lazy (" OPEN: "^
- String.concat "\n"
- (List.map
- (function
- | (i,t,P) -> string_of_int i ^ ":"^ppterm t^ "Prop"
- | (i,t,T) -> string_of_int i ^ ":"^ppterm t^ "Type")
- tys)));
- open_goals
-;;
-
-let is_an_equational_goal = function
- | Cic.Appl [Cic.MutInd(u,_,_);_;_;_] when LibraryObjects.is_eq_URI u -> true
- | _ -> false
-;;
-
-type auto_params = Cic.term list option * (string * string) list
-
-let elems = ref [] ;;
-
-(* closing a term w.r.t. its metavariables
- very naif version: it does not take dependencies properly into account *)
-
-let naif_closure ?(prefix_name="xxx_") t metasenv context =
- let in_term t (i,_,_) =
- List.exists (fun (j,_) -> j=i) (CicUtil.metas_of_term t)
- in
- let metasenv = List.filter (in_term t) metasenv in
- let metasenv = ProofEngineHelpers.sort_metasenv metasenv in
- let n = List.length metasenv in
- let what = List.map (fun (i,cc,ty) -> Cic.Meta(i,[])) metasenv in
- let _,with_what =
- List.fold_left
- (fun (i,acc) (_,cc,ty) -> (i-1,Cic.Rel i::acc))
- (n,[]) metasenv
- in
- let t = CicSubstitution.lift n t in
- let body =
- ProofEngineReduction.replace_lifting
- ~equality:(fun c t1 t2 ->
- match t1,t2 with
- | Cic.Meta(i,_),Cic.Meta(j,_) -> i = j
- | _ -> false)
- ~context ~what ~with_what ~where:t
- in
- let _, t =
- List.fold_left
- (fun (n,t) (_,cc,ty) ->
- n-1, Cic.Lambda(Cic.Name (prefix_name^string_of_int n),
- CicSubstitution.lift n ty,t))
- (n-1,body) metasenv
- in
- t, List.length metasenv
-;;
-
-let lambda_close ?prefix_name t menv ctx =
- let t, num_lambdas = naif_closure ?prefix_name t menv ctx in
- List.fold_left
- (fun (t,i) -> function
- | None -> CicSubstitution.subst (Cic.Implicit None) t,i (* delift *)
- | Some (name, Cic.Decl ty) -> Cic.Lambda (name, ty, t),i+1
- | Some (name, Cic.Def (bo, ty)) -> Cic.LetIn (name, bo, ty, t),i+1)
- (t,num_lambdas) ctx
-;;
-
-(* functions for retrieving theorems *)
-
-
-exception FillingFailure of AutoCache.cache * AutomationCache.tables
-
-let rec unfold context = function
- | Cic.Prod(name,s,t) ->
- let t' = unfold ((Some (name,Cic.Decl s))::context) t in
- Cic.Prod(name,s,t')
- | t -> ProofEngineReduction.unfold context t
-
-let find_library_theorems dbd proof goal =
- let univ = MetadataQuery.universe_of_goal ~dbd false proof goal in
- let terms = List.map CicUtil.term_of_uri univ in
- List.map
- (fun t ->
- (t,fst(CicTypeChecker.type_of_aux' [] [] t CicUniv.oblivion_ugraph)))
- terms
-
-let find_context_theorems context metasenv =
- let l,_ =
- List.fold_left
- (fun (res,i) ctxentry ->
- match ctxentry with
- | Some (_,Cic.Decl t) ->
- (Cic.Rel i, CicSubstitution.lift i t)::res,i+1
- | Some (_,Cic.Def (_,t)) ->
- (Cic.Rel i, CicSubstitution.lift i t)::res,i+1
- | None -> res,i+1)
- ([],1) context
- in l
-
-let rec is_an_equality = function
- | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _]
- when (LibraryObjects.is_eq_URI uri) -> true
- | Cic.Prod (_, _, t) -> is_an_equality t
- | _ -> false
-;;
-
-let partition_equalities =
- List.partition (fun (_,ty) -> is_an_equality ty)
-
-
-let default_auto tables _ cache _ _ _ _ = [],cache,tables ;;
-
-(* giusto per provare che succede
-let is_unit_equation context metasenv oldnewmeta term =
- let head, metasenv, args, newmeta =
- TermUtil.saturate_term oldnewmeta metasenv context term 0
- in
- let newmetas =
- List.filter (fun (i,_,_) -> i >= oldnewmeta) metasenv
- in
- Some (args,metasenv,newmetas,head,newmeta) *)
-
-let is_unit_equation context metasenv oldnewmeta term =
- let head, metasenv, args, newmeta =
- TermUtil.saturate_term oldnewmeta metasenv context term 0
- in
- let propositional_args =
- HExtlib.filter_map
- (function
- | Cic.Meta(i,_) ->
- let _,_,mt = CicUtil.lookup_meta i metasenv in
- let sort,u =
- CicTypeChecker.type_of_aux' metasenv context mt
- CicUniv.oblivion_ugraph
- in
- if is_propositional context sort then Some i else None
- | _ -> assert false)
- args
- in
- if propositional_args = [] then
- let newmetas =
- List.filter (fun (i,_,_) -> i >= oldnewmeta) metasenv
- in
- Some (args,metasenv,newmetas,head,newmeta)
- else None
-;;
-
-let get_candidates skip_trie_filtering universe cache t =
- let t = if skip_trie_filtering then Cic.Meta(0,[]) else t in
- let candidates=
- (Universe.get_candidates universe t)@(AutoCache.get_candidates cache t)
- in
- let debug_msg =
- (lazy ("candidates for " ^ (CicPp.ppterm t) ^ " = " ^
- (String.concat "\n" (List.map CicPp.ppterm candidates)))) in
- debug_print debug_msg;
- candidates
-;;
-
-let only signature context metasenv t =
- try
- let ty,_ =
- CicTypeChecker.type_of_aux' metasenv context t CicUniv.oblivion_ugraph
- in
- let consts = MetadataConstraints.constants_of ty in
- let b = MetadataConstraints.UriManagerSet.subset consts signature in
-(* if b then (prerr_endline ("keeping " ^ (CicPp.ppterm t)); b) *)
- if b then b
- else
- let ty' = unfold context ty in
- let consts' = MetadataConstraints.constants_of ty' in
- let b = MetadataConstraints.UriManagerSet.subset consts' signature in
-(*
- if not b then prerr_endline ("filtering " ^ (CicPp.ppterm t))
- else prerr_endline ("keeping " ^ (CicPp.ppterm t));
-*)
- b
- with
- | CicTypeChecker.TypeCheckerFailure _ -> assert false
- | ProofEngineTypes.Fail _ -> false (* unfold may fail *)
-;;
-
-let not_default_eq_term t =
- try
- let uri = CicUtil.uri_of_term t in
- not (LibraryObjects.in_eq_URIs uri)
- with Invalid_argument _ -> true
-
-let retrieve_equations dont_filter signature universe cache context metasenv =
- match LibraryObjects.eq_URI() with
- | None -> []
- | Some eq_uri ->
- let eq_uri = UriManager.strip_xpointer eq_uri in
- let fake= Cic.Meta(-1,[]) in
- let fake_eq = Cic.Appl [Cic.MutInd (eq_uri,0, []);fake;fake;fake] in
- let candidates = get_candidates false universe cache fake_eq in
- if dont_filter then candidates
- else let eq_uri = UriManager.uri_of_uriref eq_uri 0 None in
- (* let candidates = List.filter not_default_eq_term candidates in *)
- List.filter
- (only (MetadataConstraints.UriManagerSet.add eq_uri signature)
- context metasenv) candidates
-
-let build_equality bag head args proof newmetas =
- match head with
- | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] ->
- let p =
- if args = [] then proof else Cic.Appl (proof::args)
- in
- let o = !Utils.compare_terms t1 t2 in
- let stat = (ty,t1,t2,o) in
- (* let w = compute_equality_weight stat in *)
- let w = 0 in
- let proof = Equality.Exact p in
- let bag, e = Equality.mk_equality bag (w, proof, stat, newmetas) in
- (* to clean the local context of metas *)
- Equality.fix_metas bag e
- | _ -> assert false
-;;
-
-let partition_unit_equalities context metasenv newmeta bag equations =
- List.fold_left
- (fun (bag,units,other,maxmeta)(t,ty) ->
- if not (CicUtil.is_meta_closed t && CicUtil.is_meta_closed ty) then
- let _ =
- HLog.warn
- ("Skipping " ^ CicMetaSubst.ppterm_in_context ~metasenv [] t context
- ^ " since it is not meta closed")
- in
- bag, units,(t,ty)::other,maxmeta
- else
- match is_unit_equation context metasenv maxmeta ty with
- | Some (args,metasenv,newmetas,head,newmeta') ->
- let bag, equality =
- build_equality bag head args t newmetas in
- bag, equality::units,other,maxmeta
- | None ->
- bag, units,(t,ty)::other,maxmeta)
- (bag,[],[],newmeta) equations
-;;
-
-let init_cache_and_tables
- ?dbd ~use_library ~use_context
- automation_cache restricted_univ (proof, goal)
-=
- let _, metasenv, subst, _, _, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let add_list_to_tables metasenv subst automation_cache ct =
- List.fold_left
- (fun automation_cache (t,_) ->
- AutomationCache.add_term_to_active automation_cache
- metasenv subst context t None)
- automation_cache ct
- in
- match restricted_univ with
- | None ->
- let ct =
- if use_context then find_context_theorems context metasenv else []
- in
- let lt =
- match use_library, dbd with
- | true, Some dbd -> find_library_theorems dbd metasenv goal
- | _ -> []
- in
- let cache = AutoCache.cache_empty in
- let cache = cache_add_list cache context (ct@lt) in
- let automation_cache =
- add_list_to_tables metasenv subst automation_cache ct
- in
-(* AutomationCache.pp_cache automation_cache; *)
- automation_cache.AutomationCache.univ,
- automation_cache.AutomationCache.tables,
- cache
- | Some restricted_univ ->
- let t_ty =
- List.map
- (fun t ->
- let ty, _ = CicTypeChecker.type_of_aux'
- metasenv ~subst:[] context t CicUniv.oblivion_ugraph
- in
- t, ty)
- restricted_univ
- in
- (* let automation_cache = AutomationCache.empty () in *)
- let automation_cache =
- let universe = Universe.empty in
- let universe =
- Universe.index_list universe context t_ty
- in
- { automation_cache with AutomationCache.univ = universe }
- in
- let ct =
- if use_context then find_context_theorems context metasenv else t_ty
- in
- let automation_cache =
- add_list_to_tables metasenv subst automation_cache ct
- in
- (* AutomationCache.pp_cache automation_cache; *)
- automation_cache.AutomationCache.univ,
- automation_cache.AutomationCache.tables,
- cache_empty
-;;
-
-let fill_hypothesis context metasenv subst term tables (universe:Universe.universe) cache auto fast =
- let actives, passives, bag = tables in
- let bag, head, metasenv, args =
- Equality.saturate_term bag metasenv subst context term
- in
- let tables = actives, passives, bag in
- let propositional_args =
- HExtlib.filter_map
- (function
- | Cic.Meta(i,_) ->
- let _,_,mt = CicUtil.lookup_meta i metasenv in
- let sort,u =
- CicTypeChecker.type_of_aux' metasenv context mt
- CicUniv.oblivion_ugraph
- in
- if is_propositional context sort then Some i else None
- | _ -> assert false)
- args
- in
- let results,cache,tables =
- if propositional_args = [] then
- let _,_,bag = tables in
- let newmetas = Equality.filter_metasenv_gt_maxmeta bag metasenv in
- [args,metasenv,newmetas,head],cache,tables
- else
- (*
- let proof =
- None,metasenv,term,term (* term non e' significativo *)
- in *)
- let flags =
- if fast then
- {AutoTypes.default_flags() with
- AutoTypes.timeout = Unix.gettimeofday() +. 1.0;
- maxwidth = 2;maxdepth = 2;
- use_paramod=true;use_only_paramod=false}
- else
- {AutoTypes.default_flags() with
- AutoTypes.timeout = Unix.gettimeofday() +. 1.0;
- maxwidth = 2;maxdepth = 4;
- use_paramod=true;use_only_paramod=false}
- in
- match auto tables universe cache context metasenv propositional_args flags with
- | [],cache,tables -> raise (FillingFailure (cache,tables))
- | substs,cache,tables ->
- let actives, passaives, bag = tables in
- let bag, res =
- List.fold_right
- (fun subst (bag,acc) ->
- let metasenv =
- CicMetaSubst.apply_subst_metasenv subst metasenv
- in
- let head = CicMetaSubst.apply_subst subst head in
- let newmetas = Equality.filter_metasenv_gt_maxmeta bag metasenv in
- let args = List.map (CicMetaSubst.apply_subst subst) args in
- let newm = CicMkImplicit.new_meta metasenv subst in
- let bag = Equality.push_maxmeta bag newm in
- bag, ((args,metasenv,newmetas,head) :: acc))
- substs (bag,[])
- in
- let tables = actives, passives, bag in
- res, cache, tables
- in
- results,cache,tables
-;;
-
-let build_equalities auto context metasenv subst tables universe cache equations =
- List.fold_left
- (fun (tables,facts,cache) (t,ty) ->
- (* in any case we add the equation to the cache *)
- let cache = AutoCache.cache_add_list cache context [(t,ty)] in
- try
- let saturated, cache, tables =
- fill_hypothesis context metasenv subst ty tables universe cache auto true
- in
- let eqs, tables =
- List.fold_left
- (fun (acc, tables) (args,metasenv,newmetas,head) ->
- let actives, passives, bag = tables in
- let bag, equality =
- build_equality bag head args t newmetas
- in
- let tables = actives, passives, bag in
- equality::acc,tables)
- ([],tables) saturated
- in
- (tables, eqs@facts, cache)
- with FillingFailure (cache,tables) ->
- (* if filling hypothesis fails we add the equation to
- the cache *)
- (tables,facts,cache)
- )
- (tables,[],cache) equations
-
-let close_more tables context status auto signature universe cache =
- let proof, goalno = status in
- let _, metasenv,subst,_,_, _ = proof in
- let equations =
- retrieve_equations false signature universe cache context metasenv
- in
- let eqs_and_types =
- HExtlib.filter_map
- (fun t ->
- let ty,_ =
- CicTypeChecker.type_of_aux' metasenv context t
- CicUniv.oblivion_ugraph in
- (* retrieve_equations could also return flexible terms *)
- if is_an_equality ty then Some(t,ty) else None)
- equations in
- let tables, units, cache =
- build_equalities auto context metasenv subst tables universe cache eqs_and_types
- in
- let active,passive,bag = tables in
- let passive = Saturation.add_to_passive units passive in
- let no = List.length units in
- let active, passive, bag =
- Saturation.pump_actives context bag active passive (no+1) infinity
- in
- (active,passive,bag), cache
-;;
-
-let find_context_equalities dbd tables context proof (universe:Universe.universe) cache
-=
- let module C = Cic in
- let module S = CicSubstitution in
- let module T = CicTypeChecker in
- let _,metasenv,subst,_,_, _ = proof in
- (* if use_auto is true, we try to close the hypothesis of equational
- statements using auto; a naif, and probably wrong approach *)
- let rec aux tables cache index = function
- | [] -> tables, [], cache
- | (Some (_, C.Decl (term)))::tl ->
- debug_print
- (lazy
- (Printf.sprintf "Examining: %d (%s)" index (CicPp.ppterm term)));
- let do_find tables context term =
- match term with
- | C.Prod (name, s, t) when is_an_equality t ->
- (try
- let term = S.lift index term in
- let saturated, cache, tables =
- fill_hypothesis context metasenv subst term
- tables universe cache default_auto false
- in
- let actives, passives, bag = tables in
- let bag,eqs =
- List.fold_left
- (fun (bag,acc) (args,metasenv,newmetas,head) ->
- let bag, equality =
- build_equality bag head args (Cic.Rel index) newmetas
- in
- bag, equality::acc)
- (bag,[]) saturated
- in
- let tables = actives, passives, bag in
- tables, eqs, cache
- with FillingFailure (cache,tables) ->
- tables, [], cache)
- | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
- when LibraryObjects.is_eq_URI uri ->
- let term = S.lift index term in
- let actives, passives, bag = tables in
- let bag, e =
- build_equality bag term [] (Cic.Rel index) []
- in
- let tables = actives, passives, bag in
- tables, [e], cache
- | _ -> tables, [], cache
- in
- let tables, eqs, cache = do_find tables context term in
- let tables, rest, cache = aux tables cache (index+1) tl in
- tables, List.map (fun x -> index,x) eqs @ rest, cache
- | _::tl ->
- aux tables cache (index+1) tl
- in
- let tables, il, cache = aux tables cache 1 context in
- let indexes, equalities = List.split il in
- tables, indexes, equalities, cache
-;;
-
-(********** PARAMETERS PASSING ***************)
-
-let bool params name default =
- try
- let s = List.assoc name params in
- if s = "" || s = "1" || s = "true" || s = "yes" || s = "on" then true
- else if s = "0" || s = "false" || s = "no" || s= "off" then false
- else
- let msg = "Unrecognized value for parameter "^name^"\n" in
- let msg = msg^"Accepted values are 1,true,yes,on and 0,false,no,off" in
- raise (ProofEngineTypes.Fail (lazy msg))
- with Not_found -> default
-;;
-
-let string params name default =
- try List.assoc name params with
- | Not_found -> default
-;;
-
-let int params name default =
- try int_of_string (List.assoc name params) with
- | Not_found -> default
- | Failure _ ->
- raise (ProofEngineTypes.Fail (lazy (name ^ " must be an integer")))
-;;
-
-let flags_of_params params ?(for_applyS=false) () =
- let int = int params in
- let bool = bool params in
- let close_more = bool "close_more" false in
- let use_paramod = bool "use_paramod" true in
- let skip_trie_filtering = bool "skip_trie_filtering" false in
- let skip_context = bool "skip_context" false in
- let use_only_paramod =
- if for_applyS then true else bool "paramodulation" false in
- let use_library = bool "library"
- ((AutoTypes.default_flags()).AutoTypes.use_library) in
- let depth = int "depth" ((AutoTypes.default_flags()).AutoTypes.maxdepth) in
- let width = int "width" ((AutoTypes.default_flags()).AutoTypes.maxwidth) in
- let size = int "size" ((AutoTypes.default_flags()).AutoTypes.maxsize) in
- let gsize = int "gsize" ((AutoTypes.default_flags()).AutoTypes.maxgoalsizefactor) in
- let do_type = bool "type" false in
- let timeout = int "timeout" 0 in
- { AutoTypes.maxdepth =
- if use_only_paramod then 2 else depth;
- AutoTypes.maxwidth = width;
- AutoTypes.maxsize = size;
- AutoTypes.timeout =
- if timeout = 0 then
- if for_applyS then Unix.gettimeofday () +. 30.0
- else
- infinity
- else
- Unix.gettimeofday() +. (float_of_int timeout);
- AutoTypes.use_library = use_library;
- AutoTypes.use_paramod = use_paramod;
- AutoTypes.use_only_paramod = use_only_paramod;
- AutoTypes.close_more = close_more;
- AutoTypes.dont_cache_failures = false;
- AutoTypes.maxgoalsizefactor = gsize;
- AutoTypes.do_types = do_type;
- AutoTypes.skip_trie_filtering = skip_trie_filtering;
- AutoTypes.skip_context = skip_context;
- }
-
-
-let eq_of_goal = function
- | Cic.Appl [Cic.MutInd(uri,0,_);_;_;_] when LibraryObjects.is_eq_URI uri ->
- uri
- | _ -> raise (ProofEngineTypes.Fail (lazy ("The goal is not an equality ")))
-;;
-
-(* performs steps of rewrite with the universe, obtaining if possible
- * a trivial goal *)
-let solve_rewrite ~automation_cache ~params:(univ,params) (proof,goal)=
- let steps = int_of_string (string params "steps" "4") in
- let use_context = bool params "use_context" true in
- let universe, tables, cache =
- init_cache_and_tables ~use_library:false ~use_context
- automation_cache univ (proof,goal)
- in
- let actives, passives, bag = tables in
- let pa,metasenv,subst,pb,pc,pd = proof in
- let _,context,ty = CicUtil.lookup_meta goal metasenv in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let context = CicMetaSubst.apply_subst_context subst context in
- let ty = CicMetaSubst.apply_subst subst ty in
- let eq_uri = eq_of_goal ty in
- let initgoal = [], metasenv, ty in
- let table =
- let equalities = (Saturation.list_of_passive passives) in
- List.fold_left (fun tbl eq -> Indexing.index tbl eq) (snd actives) equalities
- in
- let env = metasenv,context,CicUniv.oblivion_ugraph in
- debug_print (lazy ("demod to solve: " ^ CicPp.ppterm ty));
- match Indexing.solve_demodulating bag env table initgoal steps with
- | Some (bag, gproof, metasenv, sub_subst, proof) ->
- let subst_candidates,extra_infos =
- List.split
- (HExtlib.filter_map
- (fun (i,c,_) ->
- if i <> goal && c = context then Some (i,(c,ty)) else None)
- metasenv)
- in
- let proofterm,proto_subst =
- let proof = Equality.add_subst sub_subst proof in
- Equality.build_goal_proof
- bag eq_uri gproof proof ty subst_candidates context metasenv
- in
- let proofterm = Subst.apply_subst sub_subst proofterm in
- let extrasubst =
- HExtlib.filter_map
- (fun (i,((c,ty),t)) ->
- match t with
- | Cic.Meta (j,_) when i=j -> None
- | _ -> Some (i,(c,t,ty)))
- (List.combine subst_candidates
- (List.combine extra_infos proto_subst))
- in
- let subst = subst @ extrasubst in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let proofterm, _, metasenv,subst, _ =
- CicRefine.type_of metasenv subst context proofterm
- CicUniv.oblivion_ugraph
- in
- let status = (pa,metasenv,subst,pb,pc,pd), goal in
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac ~term:proofterm) status
- | None ->
- raise
- (ProofEngineTypes.Fail (lazy
- ("Unable to solve with " ^ string_of_int steps ^ " demodulations")))
-;;
-
-(* Demodulate thorem *)
-let open_type ty bo =
- let rec open_type_aux context ty k args =
- match ty with
- | Cic.Prod (n,s,t) ->
- let n' =
- FreshNamesGenerator.mk_fresh_name [] context n ~typ:s ~subst:[] in
- let entry = match n' with
- | Cic.Name _ -> Some (n',(Cic.Decl s))
- | Cic.Anonymous -> None
- in
- open_type_aux (entry::context) t (k+1) ((Cic.Rel k)::args)
- | Cic.LetIn (n,s,sty,t) ->
- let entry = Some (n,(Cic.Def (s,sty)))
- in
- open_type_aux (entry::context) t (k+1) args
- | _ -> context, ty, args
- in
- let context, ty, args = open_type_aux [] ty 1 [] in
- match args with
- | [] -> context, ty, bo
- | _ -> context, ty, Cic.Appl (bo::args)
-;;
-
-let rec close_type bo ty context =
- match context with
- | [] -> assert_proof_is_valid bo [] [] ty; (bo,ty)
- | Some (n,(Cic.Decl s))::tl ->
- close_type (Cic.Lambda (n,s,bo)) (Cic.Prod (n,s,ty)) tl
- | Some (n,(Cic.Def (s,sty)))::tl ->
- close_type (Cic.LetIn (n,s,sty,bo)) (Cic.LetIn (n,s,sty,ty)) tl
- | _ -> assert false
-;;
-
-let is_subsumed univ context ty =
- let candidates = Universe.get_candidates univ ty in
- List.fold_left
- (fun res cand ->
- match res with
- | Some found -> Some found
- | None ->
- try
- let mk_irl =
- CicMkImplicit.identity_relocation_list_for_metavariable in
- let metasenv = [(0,context,ty)] in
- let fake_proof =
- None,metasenv,[] , (lazy (Cic.Meta(0,mk_irl context))),ty,[]
- in
- let (_,metasenv,subst,_,_,_), open_goals =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac ~term:cand)
- (fake_proof,0)
- in
- let prop_goals, other =
- split_goals_in_prop metasenv subst open_goals
- in
- if prop_goals = [] then Some cand else None
- with
- | ProofEngineTypes.Fail s -> None
- | CicUnification.Uncertain s -> None
- ) None candidates
-;;
-
-let demodulate_theorem ~automation_cache uri =
- let eq_uri =
- match LibraryObjects.eq_URI () with
- | Some (uri) -> uri
- | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in
- let obj,_ = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- let context,ty,bo =
- match obj with
- | Cic.Constant(n, _, ty ,_, _) -> open_type ty (Cic.Const(uri,[]))
- | _ -> raise (ProofEngineTypes.Fail (lazy "not a theorem"))
- in
- if CicUtil.is_closed ty then
- raise (ProofEngineTypes.Fail (lazy ("closed term: dangerous reduction")));
- let initgoal = [], [], ty in
- (* compute the signature *)
- let signature =
- let ty_set = MetadataConstraints.constants_of ty in
- let hyp_set = MetadataQuery.signature_of_hypothesis context [] in
- let set = MetadataConstraints.UriManagerSet.union ty_set hyp_set in
- MetadataQuery.close_with_types set [] context
- in
- (* retrieve equations from the universe universe *)
- (* XXX automation_cache *)
- let universe = automation_cache.AutomationCache.univ in
- let equations =
- retrieve_equations true signature universe AutoCache.cache_empty context []
- in
- debug_print
- (lazy ("ho trovato equazioni n. "^(string_of_int (List.length equations))));
- let eqs_and_types =
- HExtlib.filter_map
- (fun t ->
- let ty,_ =
- CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph
- in
- (* retrieve_equations could also return flexible terms *)
- if is_an_equality ty then Some(t,ty)
- else
- try
- let ty' = unfold context ty in
- if is_an_equality ty' then Some(t,ty') else None
- with ProofEngineTypes.Fail _ -> None)
- equations
- in
- let bag = Equality.mk_equality_bag () in
-
- let bag, units, _, newmeta =
- partition_unit_equalities context [] (CicMkImplicit.new_meta [] []) bag eqs_and_types
- in
- let table =
- List.fold_left
- (fun tbl eq -> Indexing.index tbl eq)
- Indexing.empty units
- in
- let changed,(newproof,newmetasenv, newty) =
- Indexing.demod bag
- ([],context,CicUniv.oblivion_ugraph) table initgoal in
- if changed then
- begin
- let oldproof = Equality.Exact bo in
- let proofterm,_ =
- Equality.build_goal_proof (~contextualize:false) (~forward:true) bag
- eq_uri newproof oldproof ty [] context newmetasenv
- in
- if newmetasenv <> [] then
- raise (ProofEngineTypes.Fail (lazy ("metasenv not empty")))
- else
- begin
- assert_proof_is_valid proofterm newmetasenv context newty;
- match is_subsumed universe context newty with
- | Some t -> raise
- (ProofEngineTypes.Fail (lazy ("subsumed by " ^ CicPp.ppterm t)))
- | None -> close_type proofterm newty context
- end
- end
- else (* if newty = ty then *)
- raise (ProofEngineTypes.Fail (lazy "no progress"))
- (*else ProofEngineTypes.apply_tactic
- (ReductionTactics.simpl_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern None)) initialstatus*)
-;;
-
-
-(* NEW DEMODULATE *)
-let demodulate ~dbd ~automation_cache ~params:(univ, params) (proof,goal)=
- let universe, tables, cache =
- init_cache_and_tables
- ~dbd ~use_library:false ~use_context:true
- automation_cache univ (proof,goal)
- in
- let eq_uri =
- match LibraryObjects.eq_URI () with
- | Some (uri) -> uri
- | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in
- let active, passive, bag = tables in
- let curi,metasenv,subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
- let initgoal = [], metasenv, ty in
- let equalities = (Saturation.list_of_passive passive) in
- (* we demodulate using both actives passives *)
- let env = metasenv,context,CicUniv.empty_ugraph in
- debug_print (lazy ("PASSIVES:" ^ string_of_int(List.length equalities)));
- List.iter (fun e -> debug_print (lazy (Equality.string_of_equality ~env e)))
- equalities;
- let table =
- List.fold_left
- (fun tbl eq -> Indexing.index tbl eq)
- (snd active) equalities
- in
- let changed,(newproof,newmetasenv, newty) =
- (* Indexing.demodulation_goal bag *)
- Indexing.demod bag
- (metasenv,context,CicUniv.oblivion_ugraph) table initgoal
- in
- if changed then
- begin
- let maxm = CicMkImplicit.new_meta metasenv subst in
- let opengoal = Equality.Exact (Cic.Meta(maxm,irl)) in
- let subst_candidates = List.map (fun (i,_,_) -> i) metasenv in
- let subst_candidates = List.filter (fun x-> x <> goal) subst_candidates in
- let proofterm, proto_subst =
- Equality.build_goal_proof (~contextualize:false) bag
- eq_uri newproof opengoal ty subst_candidates context metasenv
- in
- (* XXX understan what to do with proto subst *)
- let metasenv = (maxm,context,newty)::metasenv in
- let proofterm, _, metasenv, subst, _ =
- CicRefine.type_of metasenv subst context proofterm
- CicUniv.oblivion_ugraph
- in
- let extended_status = (curi,metasenv,subst,pbo,pty, attrs),goal in
- let proof,gl =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac ~term:proofterm) extended_status
- in
- proof,maxm::gl
- end
- else
- raise (ProofEngineTypes.Fail (lazy "no progress"))
-;;
-
-let demodulate_tac ~dbd ~params:(_,flags as params) ~automation_cache =
- ProofEngineTypes.mk_tactic
- (fun status ->
- let all = bool flags "all" false in
- if all then
- solve_rewrite ~params ~automation_cache status
- else
- demodulate ~dbd ~params ~automation_cache status)
-;;
-(***************** applyS *******************)
-
-let apply_smart_aux
- dbd automation_cache (params:auto_params) proof goal newmeta' metasenv' subst
- context term' ty termty goal_arity
-=
- let consthead,newmetasenv,arguments,_ =
- TermUtil.saturate_term newmeta' metasenv' context termty goal_arity in
- let term'' =
- match arguments with
- | [] -> term'
- | _ -> Cic.Appl (term'::arguments)
- in
- let consthead =
- let rec aux t = function
- | [] ->
- let t = CicReduction.normalize ~delta:false context t in
- (match t, ty with
- | Cic.Appl (hd1::_), Cic.Appl (hd2::_) when hd1 <> hd2 ->
- let t = ProofEngineReduction.unfold context t in
- (match t with
- | Cic.Appl (hd1'::_) when hd1' = hd2 -> t
- | _ -> raise (ProofEngineTypes.Fail (lazy "incompatible head")))
- | _ -> t)
- | arg :: tl ->
- match CicReduction.whd context t with
- | Cic.Prod (_,_,tgt) ->
- aux (CicSubstitution.subst arg tgt) tl
- | _ -> assert false
- in
- aux termty arguments
- in
- let goal_for_paramod =
- match LibraryObjects.eq_URI () with
- | Some uri ->
- Cic.Appl [Cic.MutInd (uri,0,[]); Cic.Implicit (Some `Type); consthead; ty]
- | None -> raise (ProofEngineTypes.Fail (lazy "No equality defined"))
- in
- try
- let goal_for_paramod, _, newmetasenv, subst, _ =
- CicRefine.type_of newmetasenv subst context goal_for_paramod
- CicUniv.oblivion_ugraph
- in
- let newmeta = CicMkImplicit.new_meta newmetasenv subst in
- let metasenv_for_paramod = (newmeta,context,goal_for_paramod)::newmetasenv in
- let proof'' =
- let uri,_,_,p,ty, attrs = proof in
- uri,metasenv_for_paramod,subst,p,ty, attrs
- in
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
-(*
- prerr_endline ("------ prima di rewrite su ------ " ^ string_of_int goal);
- prerr_endline ("menv:\n"^CicMetaSubst.ppmetasenv [] metasenv_for_paramod);
- prerr_endline ("subst:\n"^CicMetaSubst.ppsubst
- ~metasenv:(metasenv_for_paramod)
- subst);
-*)
-
- let (proof''',goals) =
- ProofEngineTypes.apply_tactic
- (EqualityTactics.rewrite_tac ~direction:`RightToLeft
- ~pattern:(ProofEngineTypes.conclusion_pattern None)
- (Cic.Meta(newmeta,irl)) []) (proof'',goal)
- in
- let goal = match goals with [g] -> g | _ -> assert false in
- let proof'''', _ =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac term'')
- (proof''',goal)
- in
-
-
- let (_,m,_,_,_,_ as p) =
- let pu,metasenv,subst,proof,px,py = proof'''' in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let proof'''' = pu,metasenv,subst,proof,px,py in
- let univ, params = params in
- let use_context = bool params "use_context" true in
- let universe, (active,passive,bag), cache =
- init_cache_and_tables ~use_library:false ~use_context
- automation_cache univ (proof'''',newmeta)
- in
- match
- Saturation.solve_narrowing bag (proof'''',newmeta) active passive
- 2 (*0 infinity*)
- with
- | None, active, passive, bag ->
- raise (ProofEngineTypes.Fail (lazy ("paramod fails")))
- | Some(subst',(pu,metasenv,_,proof,px, py),open_goals),active,
- passive,bag ->
- assert_subst_are_disjoint subst subst';
- let subst = subst@subst' in
- pu,metasenv,subst,proof,px,py
- in
-
-(*
- let (_,m,_,_,_,_ as p),_ =
- solve_rewrite ~params ~automation_cache (proof'''',newmeta)
- in
-*)
-
- let open_goals =
- ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv' ~newmetasenv:m
- in
- p, open_goals
- with
- CicRefine.RefineFailure msg ->
- raise (ProofEngineTypes.Fail msg)
-;;
-
-let apply_smart
- ~dbd ~term ~automation_cache ~params (proof, goal)
-=
- let module T = CicTypeChecker in
- let module R = CicReduction in
- let module C = Cic in
- let (_,metasenv,subst,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let newmeta = CicMkImplicit.new_meta metasenv subst in
- let exp_named_subst_diff,newmeta',newmetasenvfragment,term' =
- match term with
- C.Var (uri,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- PrimitiveTactics.generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.Var (uri,exp_named_subst')
- | C.Const (uri,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- PrimitiveTactics.generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- PrimitiveTactics.generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.MutInd (uri,tyno,exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- PrimitiveTactics.generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.MutConstruct (uri,tyno,consno,exp_named_subst')
- | _ -> [],newmeta,[],term
- in
- let metasenv' = metasenv@newmetasenvfragment in
- let termty,_ =
- CicTypeChecker.type_of_aux'
- metasenv' ~subst context term' CicUniv.oblivion_ugraph
- in
- let termty = CicSubstitution.subst_vars exp_named_subst_diff termty in
- let goal_arity =
- let rec count_prods context ty =
- match CicReduction.whd ~subst context ty with
- | Cic.Prod (n,s,t) -> 1 + count_prods (Some (n,Cic.Decl s)::context) t
- | _ -> 0
- in
- count_prods context ty
- in
- apply_smart_aux dbd automation_cache params proof goal
- newmeta' metasenv' subst context term' ty termty goal_arity
-;;
-
-let applyS_tac ~dbd ~term ~params ~automation_cache =
- ProofEngineTypes.mk_tactic
- (fun status ->
- try
- apply_smart ~dbd ~term ~params ~automation_cache status
- with
- | CicUnification.UnificationFailure msg
- | CicTypeChecker.TypeCheckerFailure msg ->
- raise (ProofEngineTypes.Fail msg))
-;;
-
-
-(****************** AUTO ********************)
-
-let calculate_timeout flags =
- if flags.timeout = 0. then
- (debug_print (lazy "AUTO WITH NO TIMEOUT");
- {flags with timeout = infinity})
- else
- flags
-;;
-let is_equational_case goalty flags =
- let ensure_equational t =
- if is_an_equational_goal t then true
- else false
- in
- (flags.use_paramod && is_an_equational_goal goalty) ||
- (flags.use_only_paramod && ensure_equational goalty)
-;;
-
-type menv = Cic.metasenv
-type subst = Cic.substitution
-type goal = ProofEngineTypes.goal * int * AutoTypes.sort
-let candidate_no = ref 0;;
-type candidate = int * Cic.term Lazy.t
-type cache = AutoCache.cache
-
-type fail =
- (* the goal (mainly for depth) and key of the goal *)
- goal * AutoCache.cache_key
-type op =
- (* goal has to be proved *)
- | D of goal
- (* goal has to be cached as a success obtained using candidate as the first
- * step *)
- | S of goal * AutoCache.cache_key * candidate * int
-type elem =
- (* menv, subst, size, operations done (only S), operations to do, failures to cache if any op fails *)
- menv * subst * int * op list * op list * fail list
-type status =
- (* list of computations that may lead to the solution: all op list will
- * end with the same (S(g,_)) *)
- elem list
-type auto_result =
- (* menv, subst, alternatives, tables, cache *)
- | Proved of menv * subst * elem list * AutomationCache.tables * cache
- | Gaveup of AutomationCache.tables * cache
-
-
-(* the status exported to the external observer *)
-type auto_status =
- (* context, (goal,candidate) list, and_list, history *)
- Cic.context * (int * Cic.term * bool * int * (int * Cic.term Lazy.t) list) list *
- (int * Cic.term * int) list * Cic.term Lazy.t list
-
-let d_prefix l =
- let rec aux acc = function
- | (D g)::tl -> aux (acc@[g]) tl
- | _ -> acc
- in
- aux [] l
-;;
-let prop_only l =
- List.filter (function (_,_,P) -> true | _ -> false) l
-;;
-
-let d_goals l =
- let rec aux acc = function
- | (D g)::tl -> aux (acc@[g]) tl
- | (S _)::tl -> aux acc tl
- | [] -> acc
- in
- aux [] l
-;;
-
-let calculate_goal_ty (goalno,_,_) s m =
- try
- let _,cc,goalty = CicUtil.lookup_meta goalno m in
- (* XXX applicare la subst al contesto? *)
- Some (cc, CicMetaSubst.apply_subst s goalty)
- with CicUtil.Meta_not_found i when i = goalno -> None
-;;
-
-let calculate_closed_goal_ty (goalno,_,_) s =
- try
- let cc,_,goalty = List.assoc goalno s in
- (* XXX applicare la subst al contesto? *)
- Some (cc, CicMetaSubst.apply_subst s goalty)
- with Not_found ->
- None
-;;
-
-let pp_status ctx status =
- if debug then
- let names = Utils.names_of_context ctx in
- let pp x =
- let x =
- ProofEngineReduction.replace
- ~equality:(fun a b -> match b with Cic.Meta _ -> true | _ -> false)
- ~what:[Cic.Rel 1] ~with_what:[Cic.Implicit None] ~where:x
- in
- CicPp.pp x names
- in
- let string_of_do m s (gi,_,_ as g) d =
- match calculate_goal_ty g s m with
- | Some (_,gty) -> Printf.sprintf "D(%d, %s, %d)" gi (pp gty) d
- | None -> Printf.sprintf "D(%d, _, %d)" gi d
- in
- let string_of_s m su k (ci,ct) gi =
- Printf.sprintf "S(%d, %s, %s, %d)" gi (pp k) (pp (Lazy.force ct)) ci
- in
- let string_of_ol m su l =
- String.concat " | "
- (List.map
- (function
- | D (g,d,s) -> string_of_do m su (g,d,s) d
- | S ((gi,_,_),k,c,_) -> string_of_s m su k c gi)
- l)
- in
- let string_of_fl m s fl =
- String.concat " | "
- (List.map (fun ((i,_,_),ty) ->
- Printf.sprintf "(%d, %s)" i (pp ty)) fl)
- in
- let rec aux = function
- | [] -> ()
- | (m,s,_,_,ol,fl)::tl ->
- Printf.eprintf "< [%s] ;;; [%s]>\n"
- (string_of_ol m s ol) (string_of_fl m s fl);
- aux tl
- in
- Printf.eprintf "-------------------------- status -------------------\n";
- aux status;
- Printf.eprintf "-----------------------------------------------------\n";
-;;
-
-let auto_status = ref [] ;;
-let auto_context = ref [];;
-let in_pause = ref false;;
-let pause b = in_pause := b;;
-let cond = Condition.create ();;
-let mutex = Mutex.create ();;
-let hint = ref None;;
-let prune_hint = ref [];;
-
-let step _ = Condition.signal cond;;
-let give_hint n = hint := Some n;;
-let give_prune_hint hint =
- prune_hint := hint :: !prune_hint
-;;
-
-let check_pause _ =
- if !in_pause then
- begin
- Mutex.lock mutex;
- Condition.wait cond mutex;
- Mutex.unlock mutex
- end
-;;
-
-let get_auto_status _ =
- let status = !auto_status in
- let and_list,elems,last =
- match status with
- | [] -> [],[],[]
- | (m,s,_,don,gl,fail)::tl ->
- let and_list =
- HExtlib.filter_map
- (fun (id,d,_ as g) ->
- match calculate_goal_ty g s m with
- | Some (_,x) -> Some (id,x,d) | None -> None)
- (d_goals gl)
- in
- let rows =
- (* these are the S goalsin the or list *)
- let orlist =
- List.map
- (fun (m,s,_,don,gl,fail) ->
- HExtlib.filter_map
- (function S (g,k,c,_) -> Some (g,k,c) | _ -> None)
- (List.rev don @ gl))
- status
- in
- (* this function eats id from a list l::[id,x] returning x, l *)
- let eat_tail_if_eq id l =
- let rec aux (s, l) = function
- | [] -> s, l
- | ((id1,_,_),k1,c)::tl when id = id1 ->
- (match s with
- | None -> aux (Some c,l) tl
- | Some _ -> assert false)
- | ((id1,_,_),k1,c as e)::tl -> aux (s, e::l) tl
- in
- let c, l = aux (None, []) l in
- c, List.rev l
- in
- let eat_in_parallel id l =
- let rec aux (b,eaten, new_l as acc) l =
- match l with
- | [] -> acc
- | l::tl ->
- match eat_tail_if_eq id l with
- | None, l -> aux (b@[false], eaten, new_l@[l]) tl
- | Some t,l -> aux (b@[true],eaten@[t], new_l@[l]) tl
- in
- aux ([],[],[]) l
- in
- let rec eat_all rows l =
- match l with
- | [] -> rows
- | elem::or_list ->
- match List.rev elem with
- | ((to_eat,depth,_),k,_)::next_lunch ->
- let b, eaten, l = eat_in_parallel to_eat l in
- let eaten = HExtlib.list_uniq eaten in
- let eaten = List.rev eaten in
- let b = true (* List.hd (List.rev b) *) in
- let rows = rows @ [to_eat,k,b,depth,eaten] in
- eat_all rows l
- | [] -> eat_all rows or_list
- in
- eat_all [] (List.rev orlist)
- in
- let history =
- HExtlib.filter_map
- (function (S (_,_,(_,c),_)) -> Some c | _ -> None)
- gl
- in
-(* let rows = List.filter (fun (_,l) -> l <> []) rows in *)
- and_list, rows, history
- in
- !auto_context, elems, and_list, last
-;;
-
-(* Works if there is no dependency over proofs *)
-let is_a_green_cut goalty =
- CicUtil.is_meta_closed goalty
-;;
-let rec first_s = function
- | (D _)::tl -> first_s tl
- | (S (g,k,c,s))::tl -> Some ((g,k,c,s),tl)
- | [] -> None
-;;
-let list_union l1 l2 =
- (* TODO ottimizzare compare *)
- HExtlib.list_uniq (List.sort compare (l1 @ l1))
-;;
-let rec eq_todo l1 l2 =
- match l1,l2 with
- | (D g1) :: tl1,(D g2) :: tl2 when g1=g2 -> eq_todo tl1 tl2
- | (S (g1,k1,(c1,lt1),i1)) :: tl1, (S (g2,k2,(c2,lt2),i2)) :: tl2
- when i1 = i2 && g1 = g2 && k1 = k2 && c1 = c2 ->
- if Lazy.force lt1 = Lazy.force lt2 then eq_todo tl1 tl2 else false
- | [],[] -> true
- | _ -> false
-;;
-let eat_head todo id fl orlist =
- let rec aux acc = function
- | [] -> [], acc
- | (m, s, _, _, todo1, fl1)::tl as orlist ->
- let rec aux1 todo1 =
- match first_s todo1 with
- | None -> orlist, acc
- | Some (((gno,_,_),_,_,_), todo11) ->
- (* TODO confronto tra todo da ottimizzare *)
- if gno = id && eq_todo todo11 todo then
- aux (list_union fl1 acc) tl
- else
- aux1 todo11
- in
- aux1 todo1
- in
- aux fl orlist
-;;
-let close_proof p ty menv context =
- let metas =
- List.map fst (CicUtil.metas_of_term p @ CicUtil.metas_of_term ty)
- in
- let menv = List.filter (fun (i,_,_) -> List.exists ((=)i) metas) menv in
- naif_closure p menv context
-;;
-(* XXX capire bene quando aggiungere alla cache *)
-let add_to_cache_and_del_from_orlist_if_green_cut
- g s m cache key todo orlist fl ctx size minsize
-=
- let cache = cache_remove_underinspection cache key in
- (* prima per fare la irl usavamo il contesto vero e proprio e non quello
- * canonico! XXX *)
- match calculate_closed_goal_ty g s with
- | None -> assert false
- | Some (canonical_ctx , gty) ->
- let goalno,depth,sort = g in
- let irl = mk_irl canonical_ctx in
- let goal = Cic.Meta(goalno, irl) in
- let proof = CicMetaSubst.apply_subst s goal in
- let green_proof, closed_proof =
- let b = is_a_green_cut proof in
- if not b then
- b, (* close_proof proof gty m ctx *) proof
- else
- b, proof
- in
- debug_print (lazy ("TENTATIVE CACHE: " ^ CicPp.ppterm key));
- if is_a_green_cut key then
- (* if the initia goal was closed, we cut alternatives *)
- let _ = debug_print (lazy ("MANGIO: " ^ string_of_int goalno)) in
- let orlist, fl = eat_head todo goalno fl orlist in
- let cache =
- if size < minsize then
- (debug_print (lazy ("NO CACHE: 2 (size <= minsize)"));cache)
- else
- (* if the proof is closed we cache it *)
- if green_proof then cache_add_success cache key proof
- else (* cache_add_success cache key closed_proof *)
- (debug_print (lazy ("NO CACHE: (no gree proof)"));cache)
- in
- cache, orlist, fl, true
- else
- let cache =
- debug_print (lazy ("TENTATIVE CACHE: " ^ CicPp.ppterm gty));
- if size < minsize then
- (debug_print (lazy ("NO CACHE: (size <= minsize)")); cache) else
- (* if the substituted goal and the proof are closed we cache it *)
- if is_a_green_cut gty then
- if green_proof then cache_add_success cache gty proof
- else (* cache_add_success cache gty closed_proof *)
- (debug_print (lazy ("NO CACHE: (no green proof (gty))"));cache)
- else (*
- try
- let ty, _ =
- CicTypeChecker.type_of_aux' ~subst:s
- m ctx closed_proof CicUniv.oblivion_ugraph
- in
- if is_a_green_cut ty then
- cache_add_success cache ty closed_proof
- else cache
- with
- | CicTypeChecker.TypeCheckerFailure _ ->*)
- (debug_print (lazy ("NO CACHE: (no green gty )"));cache)
- in
- cache, orlist, fl, false
-;;
-let close_failures (fl : fail list) (cache : cache) =
- List.fold_left
- (fun cache ((gno,depth,_),gty) ->
- if CicUtil.is_meta_closed gty then
- ( debug_print (lazy ("FAIL: INDUCED: " ^ string_of_int gno));
- cache_add_failure cache gty depth)
- else
- cache)
- cache fl
-;;
-let put_in_subst subst metasenv (goalno,_,_) canonical_ctx t ty =
- let entry = goalno, (canonical_ctx, t,ty) in
- assert_subst_are_disjoint subst [entry];
- let subst = entry :: subst in
-
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
-
- subst, metasenv
-;;
-
-let mk_fake_proof metasenv subst (goalno,_,_) goalty context =
- None,metasenv,subst ,(lazy (Cic.Meta(goalno,mk_irl context))),goalty, []
-;;
-
-let equational_case
- tables cache depth fake_proof goalno goalty subst context
- flags
-=
- let active,passive,bag = tables in
- let ppterm = ppterm context in
- let status = (fake_proof,goalno) in
- if flags.use_only_paramod then
- begin
- debug_print (lazy ("PARAMODULATION SU: " ^
- string_of_int goalno ^ " " ^ ppterm goalty ));
- let goal_steps, saturation_steps, timeout =
- max_int,max_int,flags.timeout
- in
- match
- Saturation.given_clause bag status active passive
- goal_steps saturation_steps timeout
- with
- | None, active, passive, bag ->
- [], (active,passive,bag), cache, flags
- | Some(subst',(_,metasenv,_subst,proof,_, _),open_goals),active,
- passive,bag ->
- assert_subst_are_disjoint subst subst';
- let subst = subst@subst' in
- let open_goals =
- order_new_goals metasenv subst open_goals ppterm
- in
- let open_goals =
- List.map (fun (x,sort) -> x,depth-1,sort) open_goals
- in
- incr candidate_no;
- [(!candidate_no,proof),metasenv,subst,open_goals],
- (active,passive,bag), cache, flags
- end
- else
- begin
- debug_print (lazy ("NARROWING DEL GOAL: " ^
- string_of_int goalno ^ " " ^ ppterm goalty ));
- let goal_steps, saturation_steps, timeout =
- 1,0,flags.timeout
- in
- match
- Saturation.solve_narrowing bag status active passive goal_steps
- with
- | None, active, passive, bag ->
- [], (active,passive,bag), cache, flags
- | Some(subst',(_,metasenv,_subst,proof,_, _),open_goals),active,
- passive,bag ->
- assert_subst_are_disjoint subst subst';
- let subst = subst@subst' in
- let open_goals =
- order_new_goals metasenv subst open_goals ppterm
- in
- let open_goals =
- List.map (fun (x,sort) -> x,depth-1,sort) open_goals
- in
- incr candidate_no;
- [(!candidate_no,proof),metasenv,subst,open_goals],
- (active,passive,bag), cache, flags
- end
-(*
- begin
- let params = ([],["use_context","false"]) in
- let automation_cache = {
- AutomationCache.tables = tables ;
- AutomationCache.univ = Universe.empty; }
- in
- try
- let ((_,metasenv,subst,_,_,_),open_goals) =
-
- solve_rewrite ~params ~automation_cache
- (fake_proof, goalno)
- in
- let proof = lazy (Cic.Meta (-1,[])) in
- [(!candidate_no,proof),metasenv,subst,[]],tables, cache, flags
- with ProofEngineTypes.Fail _ -> [], tables, cache, flags
-(*
- let res = Saturation.all_subsumed bag status active passive in
- let res' =
- List.map
- (fun (subst',(_,metasenv,_subst,proof,_, _),open_goals) ->
- assert_subst_are_disjoint subst subst';
- let subst = subst@subst' in
- let open_goals =
- order_new_goals metasenv subst open_goals ppterm
- in
- let open_goals =
- List.map (fun (x,sort) -> x,depth-1,sort) open_goals
- in
- incr candidate_no;
- (!candidate_no,proof),metasenv,subst,open_goals)
- res
- in
- res', (active,passive,bag), cache, flags
-*)
- end
-*)
-;;
-
-let sort_new_elems =
- List.sort (fun (_,_,_,l1) (_,_,_,l2) ->
- let p1 = List.length (prop_only l1) in
- let p2 = List.length (prop_only l2) in
- if p1 = p2 then List.length l1 - List.length l2 else p1-p2)
-;;
-
-
-let try_candidate dbd
- goalty tables subst fake_proof goalno depth context cand
-=
- let ppterm = ppterm context in
- try
- let actives, passives, bag = tables in
- let (_,metasenv,subst,_,_,_), open_goals =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac ~term:cand)
- (fake_proof,goalno)
- in
- let tables = actives, passives,
- Equality.push_maxmeta bag
- (max (Equality.maxmeta bag) (CicMkImplicit.new_meta metasenv subst))
- in
- debug_print (lazy (" OK: " ^ ppterm cand));
- let metasenv = CicRefine.pack_coercion_metasenv metasenv in
- let open_goals = order_new_goals metasenv subst open_goals ppterm in
- let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in
- incr candidate_no;
- Some ((!candidate_no,lazy cand),metasenv,subst,open_goals), tables
- with
- | ProofEngineTypes.Fail s -> None,tables
- | CicUnification.Uncertain s -> None,tables
-;;
-
-let applicative_case dbd
- tables depth subst fake_proof goalno goalty metasenv context
- signature universe cache flags
-=
- (* let goalty_aux =
- match goalty with
- | Cic.Appl (hd::tl) ->
- Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl))
- | _ -> goalty
- in *)
- let goalty_aux = goalty in
- let candidates =
- get_candidates flags.skip_trie_filtering universe cache goalty_aux
- in
- (* if the goal is an equality we skip the congruence theorems
- let candidates =
- if is_equational_case goalty flags
- then List.filter not_default_eq_term candidates
- else candidates
- in *)
- let candidates = List.filter (only signature context metasenv) candidates
- in
- let tables, elems =
- List.fold_left
- (fun (tables,elems) cand ->
- match
- try_candidate dbd goalty
- tables subst fake_proof goalno depth context cand
- with
- | None, tables -> tables, elems
- | Some x, tables -> tables, x::elems)
- (tables,[]) candidates
- in
- let elems = sort_new_elems elems in
- elems, tables, cache
-;;
-
-let try_smart_candidate dbd
- goalty tables subst fake_proof goalno depth context cand
-=
- let ppterm = ppterm context in
- try
- let params = (None,[]) in
- let automation_cache = {
- AutomationCache.tables = tables ;
- AutomationCache.univ = Universe.empty; }
- in
- debug_print (lazy ("candidato per " ^ string_of_int goalno
- ^ ": " ^ CicPp.ppterm cand));
-(*
- let (_,metasenv,subst,_,_,_) = fake_proof in
- prerr_endline ("metasenv:\n" ^ CicMetaSubst.ppmetasenv [] metasenv);
- prerr_endline ("subst:\n" ^ CicMetaSubst.ppsubst ~metasenv subst);
-*)
- let ((_,metasenv,subst,_,_,_),open_goals) =
- apply_smart ~dbd ~term:cand ~params ~automation_cache
- (fake_proof, goalno)
- in
- let metasenv = CicRefine.pack_coercion_metasenv metasenv in
- let open_goals = order_new_goals metasenv subst open_goals ppterm in
- let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in
- incr candidate_no;
- Some ((!candidate_no,lazy cand),metasenv,subst,open_goals), tables
- with
- | ProofEngineTypes.Fail s -> None,tables
- | CicUnification.Uncertain s -> None,tables
-;;
-
-let smart_applicative_case dbd
- tables depth subst fake_proof goalno goalty metasenv context signature
- universe cache flags
-=
- let goalty_aux =
- match goalty with
- | Cic.Appl (hd::tl) ->
- Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl))
- | _ -> goalty
- in
- let smart_candidates =
- get_candidates flags.skip_trie_filtering universe cache goalty_aux
- in
- let candidates =
- get_candidates flags.skip_trie_filtering universe cache goalty
- in
- let smart_candidates =
- List.filter
- (fun x -> not(List.mem x candidates)) smart_candidates
- in
- let debug_msg =
- (lazy ("smart_candidates" ^ " = " ^
- (String.concat "\n" (List.map CicPp.ppterm smart_candidates)))) in
- debug_print debug_msg;
- let candidates = List.filter (only signature context metasenv) candidates in
- let smart_candidates =
- List.filter (only signature context metasenv) smart_candidates
- in
-(*
- let penalty cand depth =
- if only signature context metasenv cand then depth else ((prerr_endline (
- "penalizzo " ^ CicPp.ppterm cand));depth -1)
- in
-*)
- let tables, elems =
- List.fold_left
- (fun (tables,elems) cand ->
- match
- try_candidate dbd goalty
- tables subst fake_proof goalno depth context cand
- with
- | None, tables ->
- (* if normal application fails we try to be smart *)
- (match try_smart_candidate dbd goalty
- tables subst fake_proof goalno depth context cand
- with
- | None, tables -> tables, elems
- | Some x, tables -> tables, x::elems)
- | Some x, tables -> tables, x::elems)
- (tables,[]) candidates
- in
- let tables, smart_elems =
- List.fold_left
- (fun (tables,elems) cand ->
- match
- try_smart_candidate dbd goalty
- tables subst fake_proof goalno depth context cand
- with
- | None, tables -> tables, elems
- | Some x, tables -> tables, x::elems)
- (tables,[]) smart_candidates
- in
- let elems = sort_new_elems (elems @ smart_elems) in
- elems, tables, cache
-;;
-
-let equational_and_applicative_case dbd
- signature universe flags m s g gty tables cache context
-=
- let goalno, depth, sort = g in
- let fake_proof = mk_fake_proof m s g gty context in
- if is_equational_case gty flags then
- let elems,tables,cache, flags =
- equational_case tables cache
- depth fake_proof goalno gty s context flags
- in
- let more_elems, tables, cache =
- if flags.use_only_paramod then
- [],tables, cache
- else
- applicative_case dbd
- tables depth s fake_proof goalno
- gty m context signature universe cache flags
- in
- elems@more_elems, tables, cache, flags
- else
- let elems, tables, cache =
- match LibraryObjects.eq_URI () with
- | Some _ ->
- smart_applicative_case dbd tables depth s fake_proof goalno
- gty m context signature universe cache flags
- | None ->
- applicative_case dbd tables depth s fake_proof goalno
- gty m context signature universe cache flags
- in
- elems, tables, cache, flags
-;;
-let rec condition_for_hint i = function
- | [] -> false
- | S (_,_,(j,_),_):: tl -> j <> i (* && condition_for_hint i tl *)
- | _::tl -> condition_for_hint i tl
-;;
-let remove_s_from_fl (id,_,_) (fl : fail list) =
- let rec aux = function
- | [] -> []
- | ((id1,_,_),_)::tl when id = id1 -> tl
- | hd::tl -> hd :: aux tl
- in
- aux fl
-;;
-
-let prunable_for_size flags s m todo =
- let rec aux b = function
- | (S _)::tl -> aux b tl
- | (D (_,_,T))::tl -> aux b tl
- | (D g)::tl ->
- (match calculate_goal_ty g s m with
- | None -> aux b tl
- | Some (canonical_ctx, gty) ->
- let gsize, _ =
- Utils.weight_of_term
- ~consider_metas:false ~count_metas_occurrences:true gty in
- let newb = b || gsize > flags.maxgoalsizefactor in
- aux newb tl)
- | [] -> b
- in
- aux false todo
-
-(*
-let prunable ty todo =
- let rec aux b = function
- | (S(_,k,_,_))::tl -> aux (b || Equality.meta_convertibility k ty) tl
- | (D (_,_,T))::tl -> aux b tl
- | D _::_ -> false
- | [] -> b
- in
- aux false todo
-;;
-*)
-
-let prunable menv subst ty todo =
- let rec aux = function
- | (S(_,k,_,_))::tl ->
- (match Equality.meta_convertibility_subst k ty menv with
- | None -> aux tl
- | Some variant ->
- no_progress variant tl (* || aux tl*))
- | (D (_,_,T))::tl -> aux tl
- | _ -> false
- and no_progress variant = function
- | [] -> (*prerr_endline "++++++++++++++++++++++++ no_progress";*) true
- | D ((n,_,P) as g)::tl ->
- (match calculate_goal_ty g subst menv with
- | None -> no_progress variant tl
- | Some (_, gty) ->
- (match calculate_goal_ty g variant menv with
- | None -> assert false
- | Some (_, gty') ->
- if gty = gty' then no_progress variant tl
-(*
-(prerr_endline (string_of_int n);
- prerr_endline (CicPp.ppterm gty);
- prerr_endline (CicPp.ppterm gty');
- prerr_endline "---------- subst";
- prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv subst);
- prerr_endline "---------- variant";
- prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv variant);
- prerr_endline "---------- menv";
- prerr_endline (CicMetaSubst.ppmetasenv [] menv);
- no_progress variant tl) *)
- else false))
- | _::tl -> no_progress variant tl
- in
- aux todo
-
-;;
-let condition_for_prune_hint prune (m, s, size, don, todo, fl) =
- let s =
- HExtlib.filter_map (function S (_,_,(c,_),_) -> Some c | _ -> None) todo
- in
- List.for_all (fun i -> List.for_all (fun j -> i<>j) prune) s
-;;
-let filter_prune_hint c l =
- let prune = !prune_hint in
- prune_hint := []; (* possible race... *)
- if prune = [] then c,l
- else
- cache_reset_underinspection c,
- List.filter (condition_for_prune_hint prune) l
-;;
-
-let auto_main dbd tables context flags signature universe cache elems =
- auto_context := context;
- let rec aux tables flags cache (elems : status) =
- pp_status context elems;
-(* DEBUGGING CODE: uncomment these two lines to stop execution at each iteration
- auto_status := elems;
- check_pause ();
-*)
- let cache, elems = filter_prune_hint cache elems in
- match elems with
- | (m, s, size, don, todo, fl)::orlist when !hint <> None ->
- debug_print (lazy "skip");
- (match !hint with
- | Some i when condition_for_hint i todo ->
- aux tables flags cache orlist
- | _ ->
- hint := None;
- aux tables flags cache elems)
- | [] ->
- (* complete failure *)
- debug_print (lazy "give up");
- Gaveup (tables, cache)
- | (m, s, _, _, [],_)::orlist ->
- (* complete success *)
- debug_print (lazy "success");
- Proved (m, s, orlist, tables, cache)
- | (m, s, size, don, (D (_,_,T))::todo, fl)::orlist
- when not flags.AutoTypes.do_types ->
- (* skip since not Prop, don't even check if closed by side-effect *)
- debug_print (lazy "skip existential goal");
- aux tables flags cache ((m, s, size, don, todo, fl)::orlist)
- | (m, s, size, don, (S(g, key, c,minsize) as op)::todo, fl)::orlist ->
- (* partial success, cache g and go on *)
- let cache, orlist, fl, sibling_pruned =
- add_to_cache_and_del_from_orlist_if_green_cut
- g s m cache key todo orlist fl context size minsize
- in
- debug_print (lazy (AutoCache.cache_print context cache));
- let fl = remove_s_from_fl g fl in
- let don = if sibling_pruned then don else op::don in
- aux tables flags cache ((m, s, size, don, todo, fl)::orlist)
- | (m, s, size, don, todo, fl)::orlist
- when List.length(prop_only (d_goals todo)) > flags.maxwidth ->
- debug_print (lazy ("FAIL: WIDTH"));
- (* too many goals in and generated by last th *)
- let cache = close_failures fl cache in
- aux tables flags cache orlist
- | (m, s, size, don, todo, fl)::orlist when size > flags.maxsize ->
- debug_print
- (lazy ("FAIL: SIZE: "^string_of_int size ^
- " > " ^ string_of_int flags.maxsize ));
- (* we already have a too large proof term *)
- let cache = close_failures fl cache in
- aux tables flags cache orlist
- | _ when Unix.gettimeofday () > flags.timeout ->
- (* timeout *)
- debug_print (lazy ("FAIL: TIMEOUT"));
- Gaveup (tables, cache)
- | (m, s, size, don, (D (gno,depth,_ as g))::todo, fl)::orlist as status ->
- (* attack g *)
- debug_print (lazy "attack goal");
- match calculate_goal_ty g s m with
- | None ->
- (* closed by side effect *)
- debug_print (lazy ("SUCCESS: SIDE EFFECT: " ^ string_of_int gno));
- aux tables flags cache ((m,s,size,don,todo, fl)::orlist)
- | Some (canonical_ctx, gty) ->
- let gsize, _ =
- Utils.weight_of_term ~consider_metas:false ~count_metas_occurrences:true gty
- in
- if gsize > flags.maxgoalsizefactor then
- (debug_print (lazy ("FAIL: SIZE: goal: "^string_of_int gsize));
- aux tables flags cache orlist)
- else if prunable_for_size flags s m todo then
- (debug_print (lazy ("POTO at depth: "^(string_of_int depth)));
- aux tables flags cache orlist)
- else
- (* still to be proved *)
- (debug_print (lazy ("EXAMINE: "^CicPp.ppterm gty));
- match cache_examine cache gty with
- | Failed_in d when d >= depth ->
- (* fail depth *)
- debug_print (lazy ("FAIL: DEPTH (cache): "^string_of_int gno));
- let cache = close_failures fl cache in
- aux tables flags cache orlist
- | UnderInspection ->
- (* fail loop *)
- debug_print (lazy ("FAIL: LOOP: " ^ string_of_int gno));
- let cache = close_failures fl cache in
- aux tables flags cache orlist
- | Succeded t ->
- debug_print (lazy ("SUCCESS: CACHE HIT: " ^ string_of_int gno));
- let s, m = put_in_subst s m g canonical_ctx t gty in
- aux tables flags cache ((m, s, size, don,todo, fl)::orlist)
- | Notfound
- | Failed_in _ when depth > 0 ->
- ( (* more depth or is the first time we see the goal *)
- if prunable m s gty todo then
- (debug_print (lazy(
- "FAIL: LOOP: one father is equal"));
- aux tables flags cache orlist)
- else
- let cache = cache_add_underinspection cache gty depth in
- auto_status := status;
- check_pause ();
- debug_print
- (lazy ("INSPECTING: " ^
- string_of_int gno ^ "("^ string_of_int size ^ "): "^
- CicPp.ppterm gty));
- (* elems are possible computations for proving gty *)
- let elems, tables, cache, flags =
- equational_and_applicative_case dbd
- signature universe flags m s g gty tables cache context
- in
- if elems = [] then
- (* this goal has failed *)
- let cache = close_failures ((g,gty)::fl) cache in
- aux tables flags cache orlist
- else
- (* elems = (cand,m,s,gl) *)
- let size_gl l = List.length
- (List.filter (function (_,_,P) -> true | _ -> false) l)
- in
- let elems =
- let inj_gl gl = List.map (fun g -> D g) gl in
- let rec map = function
- | [] -> assert false
- | (cand,m,s,gl)::[] ->
- (* in the last one we add the failure *)
- let todo =
- inj_gl gl @ (S(g,gty,cand,size+1))::todo
- in
- (* we are the last in OR, we fail on g and
- * also on all failures implied by g *)
- (m,s, size + size_gl gl, don, todo, (g,gty)::fl)
- :: orlist
- | (cand,m,s,gl)::tl ->
- (* we add the S step after gl and before todo *)
- let todo =
- inj_gl gl @ (S(g,gty,cand,size+1))::todo
- in
- (* since we are not the last in OR, we do not
- * imply failures *)
- (m,s, size + size_gl gl, don, todo, []) :: map tl
- in
- map elems
- in
- aux tables flags cache elems)
- | _ ->
- (* no more depth *)
- debug_print (lazy ("FAIL: DEPTH: " ^ string_of_int gno));
- let cache = close_failures fl cache in
- aux tables flags cache orlist)
- in
- (aux tables flags cache elems : auto_result)
-;;
-
-
-let
- auto_all_solutions dbd tables universe cache context metasenv gl flags
-=
- let signature =
- List.fold_left
- (fun set g ->
- MetadataConstraints.UriManagerSet.union set
- (MetadataQuery.signature_of metasenv g)
- )
- MetadataConstraints.UriManagerSet.empty gl
- in
- let goals = order_new_goals metasenv [] gl CicPp.ppterm in
- let goals =
- List.map
- (fun (x,s) -> D (x,flags.maxdepth,s)) goals
- in
- let elems = [metasenv,[],1,[],goals,[]] in
- let rec aux tables solutions cache elems flags =
- match auto_main dbd tables context flags signature universe cache elems with
- | Gaveup (tables,cache) ->
- solutions,cache, tables
- | Proved (metasenv,subst,others,tables,cache) ->
- if Unix.gettimeofday () > flags.timeout then
- ((subst,metasenv)::solutions), cache, tables
- else
- aux tables ((subst,metasenv)::solutions) cache others flags
- in
- let rc = aux tables [] cache elems flags in
- match rc with
- | [],cache,tables -> [],cache,tables
- | solutions, cache,tables ->
- let solutions =
- HExtlib.filter_map
- (fun (subst,newmetasenv) ->
- let opened =
- ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv ~newmetasenv
- in
- if opened = [] then Some subst else None)
- solutions
- in
- solutions,cache,tables
-;;
-
-(******************* AUTO ***************)
-
-
-let auto dbd flags metasenv tables universe cache context metasenv gl =
- let initial_time = Unix.gettimeofday() in
- let signature =
- List.fold_left
- (fun set g ->
- MetadataConstraints.UriManagerSet.union set
- (MetadataQuery.signature_of metasenv g)
- )
- MetadataConstraints.UriManagerSet.empty gl
- in
- let goals = order_new_goals metasenv [] gl CicPp.ppterm in
- let goals = List.map (fun (x,s) -> D(x,flags.maxdepth,s)) goals in
- let elems = [metasenv,[],1,[],goals,[]] in
- match auto_main dbd tables context flags signature universe cache elems with
- | Proved (metasenv,subst,_, tables,cache) ->
- debug_print(lazy
- ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time)));
- Some (subst,metasenv), cache
- | Gaveup (tables,cache) ->
- debug_print(lazy
- ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time)));
- None,cache
-;;
-
-let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~automation_cache (proof, goal) =
- let flags = flags_of_params params () in
- let use_library = flags.use_library in
- let universe, tables, cache =
- init_cache_and_tables
- ~dbd ~use_library ~use_context:(not flags.skip_context)
- automation_cache univ (proof, goal)
- in
- let _,metasenv,subst,_,_, _ = proof in
- let _,context,goalty = CicUtil.lookup_meta goal metasenv in
- let signature = MetadataQuery.signature_of metasenv goal in
- let signature =
- match univ with
- | None -> signature
- | Some l ->
- List.fold_left
- (fun set t ->
- let ty, _ =
- CicTypeChecker.type_of_aux' metasenv context t
- CicUniv.oblivion_ugraph
- in
- MetadataConstraints.UriManagerSet.union set
- (MetadataConstraints.constants_of ty)
- )
- signature l
- in
- let tables,cache =
- if flags.close_more then
- close_more
- tables context (proof, goal)
- (auto_all_solutions dbd) signature universe cache
- else tables,cache in
- let initial_time = Unix.gettimeofday() in
- let (_,oldmetasenv,_,_,_, _) = proof in
- hint := None;
- let elem =
- metasenv,subst,1,[],[D (goal,flags.maxdepth,P)],[]
- in
- match auto_main dbd tables context flags signature universe cache [elem] with
- | Proved (metasenv,subst,_, tables,cache) ->
- debug_print (lazy
- ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time)));
- let proof,metasenv =
- ProofEngineHelpers.subst_meta_and_metasenv_in_proof
- proof goal subst metasenv
- in
- let opened =
- ProofEngineHelpers.compare_metasenvs ~oldmetasenv
- ~newmetasenv:metasenv
- in
- proof,opened
- | Gaveup (tables,cache) ->
- debug_print
- (lazy ("TIME:"^
- string_of_float(Unix.gettimeofday()-.initial_time)));
- raise (ProofEngineTypes.Fail (lazy "Auto gave up"))
-;;
-
-let auto_tac ~dbd ~params ~automation_cache =
- ProofEngineTypes.mk_tactic (auto_tac ~params ~dbd ~automation_cache);;
-
-let pp_proofterm = Equality.pp_proofterm;;
-
-let revision = "$Revision$";;
-let size_and_depth context metasenv t = 100, 100
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type auto_params = Cic.term list option * (string * string) list
-
-val auto_tac:
- dbd:HSql.dbd ->
- params:auto_params ->
- automation_cache:AutomationCache.cache ->
- ProofEngineTypes.tactic
-
-val applyS_tac:
- dbd:HSql.dbd ->
- term: Cic.term ->
- params:auto_params ->
- automation_cache:AutomationCache.cache ->
- ProofEngineTypes.tactic
-
-val demodulate_tac :
- dbd:HSql.dbd ->
- params:auto_params ->
- automation_cache:AutomationCache.cache ->
- ProofEngineTypes.tactic
-
-val demodulate_theorem :
- automation_cache:AutomationCache.cache ->
- UriManager.uri ->
- Cic.term * Cic.term
-
-type auto_status =
- Cic.context *
- (* or list: goalno, goaltype, grey, depth, candidates: (goalno, c) *)
- (int * Cic.term * bool * int * (int * Cic.term Lazy.t) list) list *
- (* and list *)
- (int * Cic.term * int) list *
- (* last moves *)
- Cic.term Lazy.t list
-
-val get_auto_status : unit -> auto_status
-val pause: bool -> unit
-val step : unit -> unit
-val give_hint : int -> unit
-val give_prune_hint : int -> unit
-
-val lambda_close :
- ?prefix_name:string -> Cic.term -> Cic.metasenv -> Cic.context -> Cic.term *
- int
-
-val pp_proofterm: Cic.term -> string
-val revision : string (* svn revision *)
-val size_and_depth : Cic.context -> Cic.metasenv -> Cic.term -> int * int
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type cache_key = Cic.term
-type cache_elem =
- | Failed_in of int
- | Succeded of Cic.term
- | UnderInspection
- | Notfound
-type cache = (Universe.universe * ((cache_key * cache_elem) list));;
-
-let debug = false;;
-let prerr_endline s =
- if debug then prerr_endline s else ()
-;;
-
-let cache_empty = (Universe.empty,[]);;
-
-let get_candidates (univ,_) ty =
-(* if Universe.key ty = ty then *)
- Universe.get_candidates univ ty
-(*
- else
- (prerr_endline ("skip: " ^ CicPp.ppterm (Universe.key ty)); [])
- *)
-;;
-
-let index (univ,cache) key term =
- Universe.index univ key term,cache
-;;
-
-let index_term_and_unfolded_term (univ,cache) context t ty =
- Universe.index_local_term univ context t ty, cache
-;;
-
-let cache_add_list (univ,cache) context terms_and_types =
- let univ =
- List.fold_left
- (fun univ (t,ty) ->
- prerr_endline ("indexing: " ^ CicPp.ppterm ty);
- Universe.index_local_term univ context t ty)
- univ terms_and_types
- in
- univ, cache
-
-let cache_examine (_,oldcache) cache_key =
- prerr_endline ("examine : " ^ CicPp.ppterm cache_key);
- try snd (List.find (fun (x,_) -> CicUtil.alpha_equivalence x cache_key)
- oldcache) with Not_found ->
- prerr_endline "notfound";
- Notfound
-;;
-let cache_replace (univ,oldcache) key v =
- let oldcache = List.filter (fun (i,_) -> i <> key) oldcache in
- univ, (key,v)::oldcache
-;;
-let cache_remove (univ,oldcache) key =
- let oldcache = List.filter (fun (i,_) -> i <> key) oldcache in
- univ,oldcache
-;;
-let cache_add_failure cache cache_key depth =
- prerr_endline
- ("CACHE: ADD FAIL " ^ CicPp.ppterm cache_key ^
- " depth: " ^ string_of_int depth);
- match cache_examine cache cache_key with
- | Failed_in i when i > depth -> cache
- | Notfound
- | Failed_in _
- | UnderInspection -> cache_replace cache cache_key (Failed_in depth)
- | Succeded t -> cache
- (*
- prerr_endline (CicPp.ppterm t);
- assert false (* if succed it can't fail *) *)
-;;
-let cache_add_success ((univ,_) as cache) cache_key proof =
- let u_key = Universe.key cache_key in
- if u_key <> cache_key then
- Universe.index univ u_key proof, snd cache
- else
- univ,
- snd
- (match cache_examine cache cache_key with
- | Failed_in _ -> cache_replace cache cache_key (Succeded proof)
- | UnderInspection -> cache_replace cache cache_key (Succeded proof)
- | Succeded t -> (* we may decide to keep the smallest proof *) cache
- | Notfound -> cache_replace cache cache_key (Succeded proof))
-(*
- (if Universe.key cache_key = cache_key then
- Universe.index univ cache_key proof
- else
- univ),snd
- (prerr_endline ("CACHE: ADD SUCCESS" ^ CicPp.ppterm cache_key);
- match cache_examine cache cache_key with
- | Failed_in _ -> cache_replace cache cache_key (Succeded proof)
- | UnderInspection -> cache_replace cache cache_key (Succeded proof)
- | Succeded t -> (* we may decide to keep the smallest proof *) cache
- | Notfound -> cache_replace cache cache_key (Succeded proof))
-;;
-*)
-let cache_add_underinspection ((univ,oldcache) as cache) cache_key depth =
- prerr_endline ("CACHE: ADD INSPECTING" ^ CicPp.ppterm cache_key);
- match cache_examine cache cache_key with
- | Failed_in i when i < depth -> cache_replace cache cache_key UnderInspection
- | Notfound -> univ,(cache_key,UnderInspection)::oldcache
- | Failed_in _
- | UnderInspection
- | Succeded _ -> assert false (* it must be a new goal *)
-;;
-let cache_print context (_,oldcache) =
- let names = List.map (function None -> None | Some (x,_) -> Some x) context in
- String.concat "\n"
- (HExtlib.filter_map
- (function
- | (k,Succeded _) -> Some ("CACHE SUCCESS: " ^ CicPp.pp k names)
- | _ -> None)
- oldcache)
-;;
-let cache_remove_underinspection ((univ,oldcache) as cache) cache_key =
- prerr_endline ("CACHE: REMOVE INSPECTING" ^ CicPp.ppterm cache_key);
- match cache_examine cache cache_key with
- | Notfound
- | Failed_in _ (* -> assert false *)
- | UnderInspection -> cache_remove cache cache_key
- | Succeded _ -> cache (*
- prerr_endline (CicPp.ppterm cache_key);
- assert false (* it must be a new goal *) *)
-;;
-let cache_size (_,oldcache) =
- List.length (List.filter (function (_,Succeded _) -> true | _ -> false) oldcache)
-;;
-let cache_clean (univ,oldcache) =
- univ,List.filter (function (_,Succeded _) -> true | _ -> false) oldcache
-;;
-let cache_reset_underinspection (u,c) =
- u,List.filter (function (_,UnderInspection) -> false | _ -> true) c
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type cache
-type cache_key = Cic.term
-type cache_elem =
- | Failed_in of int
- | Succeded of Cic.term
- | UnderInspection
- | Notfound
-val get_candidates: cache -> Cic.term -> Cic.term list
-val cache_add_list:
- cache -> Cic.context -> (Cic.term*Cic.term) list -> cache
-val cache_examine: cache -> cache_key -> cache_elem
-val cache_add_failure: cache -> cache_key -> int -> cache
-val cache_add_success: cache -> cache_key -> Cic.term -> cache
-val cache_add_underinspection: cache -> cache_key -> int -> cache
-val cache_remove_underinspection: cache -> cache_key -> cache
-val cache_reset_underinspection: cache -> cache
-val cache_empty: cache
-val cache_print: Cic.context -> cache -> string
-val cache_size: cache -> int
-val cache_clean: cache -> cache
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type flags = {
- maxwidth: int;
- maxsize: int;
- maxdepth: int;
- maxgoalsizefactor : int;
- timeout: float;
- use_library: bool;
- use_paramod: bool;
- use_only_paramod : bool;
- close_more : bool;
- dont_cache_failures: bool;
- do_types: bool;
- skip_trie_filtering: bool;
- skip_context: bool;
-}
-
-let default_flags _ =
- {maxwidth=3;
- maxdepth=3;
- maxsize = 6;
- maxgoalsizefactor = max_int;
- timeout=Unix.gettimeofday() +.3.0;
- use_library=false;
- use_paramod=true;
- use_only_paramod=false;
- close_more=false;
- dont_cache_failures=false;
- do_types=false;
- skip_trie_filtering=false;
- skip_context=false;
-}
-;;
-
-(* (metasenv, subst, (metano,depth)list *)
-type sort = P | T;;
-type and_elem = (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * (int * int * sort) list
-type auto_result =
- | Fail of string
- | Success of (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * and_elem list
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type flags = {
- maxwidth: int;
- maxsize: int;
- maxdepth: int;
- maxgoalsizefactor : int;
- timeout: float;
- use_library: bool;
- use_paramod: bool;
- use_only_paramod : bool;
- close_more : bool;
- dont_cache_failures: bool;
- do_types: bool;
- skip_trie_filtering: bool;
- skip_context : bool;
-}
-
-val default_flags : unit -> flags
-
-(* (metasenv, subst, (metano,depth)list *)
-type sort = P | T;;
-type and_elem =
- (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * (ProofEngineTypes.goal * int * sort) list
-type auto_result =
- | Fail of string
- | Success of (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * and_elem list
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type tables =
- Saturation.active_table * Saturation.passive_table * Equality.equality_bag
-
-type cache = {
- univ : Universe.universe;
- tables : Saturation.active_table *
- Saturation.passive_table *
- Equality.equality_bag;
-}
-
-let empty_tables () =
- Saturation.make_active [],
- Saturation.make_passive [],
- Equality.mk_equality_bag ()
-;;
-
-let empty () = {
- univ = Universe.empty;
- tables = empty_tables ();
-}
-
-let pump cache steps =
- let active, passive, bag = cache.tables in
- let active, passive, bag =
- Saturation.pump_actives
- [] bag active passive steps infinity
- in
- let tables = active, passive, bag in
- { cache with tables = tables }
-;;
-
-let add_term_to_active cache metasenv subst context t ty_opt =
- let actives, passives, bag = cache.tables in
- let bag, metasenv, head, t, args, mes, ugraph =
- match ty_opt with
- | Some ty ->
- bag, metasenv, ty, t, [], (CicUtil.metas_of_term (Cic.Appl [t;ty])),
- CicUniv.oblivion_ugraph
- | None ->
- let ty, ugraph =
- CicTypeChecker.type_of_aux'
- ~subst metasenv context t CicUniv.oblivion_ugraph
- in
- let bag, head, metasenv, args =
- Equality.saturate_term bag metasenv subst context ty
- in
- let mes = CicUtil.metas_of_term (Cic.Appl (head::t::args)) in
- let t = if args = [] then t else Cic.Appl (t:: args) in
- bag, metasenv, head, t, args, mes, ugraph
- in
- if List.exists
- (function
- | Cic.Meta(i,_) ->
- (try
- let _,mc, mt = CicUtil.lookup_meta i metasenv in
- let sort, u =
- CicTypeChecker.type_of_aux' metasenv mc mt ugraph
- in
- fst (CicReduction.are_convertible mc sort (Cic.Sort Cic.Prop) u)
- with
- | CicUtil.Meta_not_found _ -> false)
- | _ -> assert false)
- args
- then
- cache
- else
- let env = metasenv, context, CicUniv.oblivion_ugraph in
- let newmetas =
- List.filter (fun (i,_,_) -> List.mem_assoc i mes) metasenv
- in
- let tables =
- Saturation.add_to_active bag actives passives env head t newmetas
- in
- { cache with tables = tables }
-;;
-
-let pp_cache cache =
- prerr_endline "Automation cache";
- prerr_endline "----------------------------------------------";
- prerr_endline "universe:";
- Universe.iter cache.univ (fun _ ts ->
- prerr_endline (" "^
- String.concat "\n " (List.map CicPp.ppterm ts)));
- prerr_endline "tables/actives:";
- let active, passive, _ = cache.tables in
- List.iter
- (fun e -> prerr_endline (" " ^ Equality.string_of_equality e))
- (Saturation.list_of_active active);
- prerr_endline "tables/passives:";
- List.iter
- (fun e -> prerr_endline (" " ^ Equality.string_of_equality e))
- (Saturation.list_of_passive passive);
- prerr_endline "----------------------------------------------";
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type tables =
- Saturation.active_table * Saturation.passive_table * Equality.equality_bag
-
-type cache = {
- univ : Universe.universe;
- tables : tables;
-}
-
-
-val empty_tables : unit -> tables
-val empty : unit -> cache
-
-val add_term_to_active:
- cache -> Cic.metasenv -> Cic.substitution -> Cic.context ->
- Cic.term -> Cic.term option -> cache
-val pump: cache -> int -> cache
-val pp_cache: cache -> unit
-
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id: cicCoercion.ml 7077 2006-12-05 15:44:54Z fguidi $ *)
-
-let debug = false
-let debug_print s = if debug then prerr_endline (Lazy.force s) else ()
-
-(* given the new coercion uri from src to tgt returns the list
- * of new coercions to create. the list elements are
- * (source, list of coercions to follow, target)
- *)
-let get_closure_coercions src tgt uri coercions =
- let enrich (uri,sat,_) tgt =
- let arity = match tgt with CoercDb.Fun n -> n | _ -> 0 in
- uri,sat,arity
- in
- let uri = enrich uri tgt in
- let eq_carr ?exact s t =
- debug_print(lazy(CoercDb.string_of_carr s^" VS "^CoercDb.string_of_carr t));
- let rc = CoercDb.eq_carr ?exact s t in
- debug_print(lazy(string_of_bool rc));
- rc
- in
- match src,tgt with
- | CoercDb.Uri _, CoercDb.Uri _ ->
- debug_print (lazy ("Uri, Uri4"));
- let c_from_tgt =
- List.filter
- (fun (f,t,_) ->
- debug_print (lazy ("Uri, Uri3"));
- eq_carr f tgt)
- coercions
- in
- let c_to_src =
- List.filter
- (fun (f,t,_) ->
- debug_print (lazy ("Uri, Uri2"));
- eq_carr t src)
- coercions
- in
- (HExtlib.flatten_map
- (fun (_,t,ul) ->
- if eq_carr ~exact:true src t then [] else
- List.map (fun u -> src,[uri; enrich u t],t) ul) c_from_tgt) @
- (HExtlib.flatten_map
- (fun (s,t,ul) ->
- if eq_carr ~exact:true s tgt then [] else
- List.map (fun u -> s,[enrich u t; uri],tgt) ul) c_to_src) @
- (HExtlib.flatten_map
- (fun (s,t1,u1l) ->
- HExtlib.flatten_map
- (fun (_,t,u2l) ->
- HExtlib.flatten_map
- (fun u1 ->
- debug_print (lazy ("Uri, Uri1"));
- if eq_carr ~exact:true s t
- || eq_carr ~exact:true s tgt
- || eq_carr ~exact:true src t
- then [] else
- List.map
- (fun u2 -> (s,[enrich u1 t1;uri;enrich u2 t],t))
- u2l)
- u1l)
- c_from_tgt)
- c_to_src)
- | _ -> [] (* do not close in case source or target is not an indty ?? *)
-;;
-
-exception UnableToCompose
-
-(* generate_composite (c2 (c1 s)) in the universe graph univ
- both living in the same context and metasenv
-
- c2 ?p2 (c1 ?p1 ?x ?s1) ?s2
-
- where:
- ?pn + 1 + ?sn = count_pi n - arity n
-*)
-let generate_composite' (c1,sat1,arity1) (c2,sat2,arity2) context metasenv univ=
- let original_metasenv = metasenv in
- let c1_ty,univ = CicTypeChecker.type_of_aux' metasenv context c1 univ in
- let c2_ty,univ = CicTypeChecker.type_of_aux' metasenv context c2 univ in
- let rec mk_implicits = function
- | 0 -> [] | n -> (Cic.Implicit None) :: mk_implicits (n-1)
- in
- let rec mk_lambda_spine c namer = function
- | 0 -> c
- | n ->
- Cic.Lambda
- (namer n,
- (Cic.Implicit None),
- mk_lambda_spine (CicSubstitution.lift 1 c) namer (n-1))
- in
- let count_pis t arity =
- let rec aux acc n = function
- | Cic.Prod (name,src,tgt) -> aux (acc@[name]) (n+1) tgt
- | _ -> n,acc
- in
- let len,names = aux [] 0 t in
- let len = len - arity in
- List.fold_left
- (fun (n,l) x -> if n < len then n+1,l@[x] else n,l) (0,[])
- names
- in
- let compose c1 nc1 c2 nc2 =
- Cic.Appl ((*CicSubstitution.lift 1*) c2 :: mk_implicits (nc2 - sat2 - 1) @
- Cic.Appl ((*CicSubstitution.lift 1*) c1 :: mk_implicits nc1 ) ::
- mk_implicits sat2)
- in
- let rec create_subst_from_metas_to_rels n = function
- | [] -> []
- | (metano, ctx, ty)::tl ->
- (metano,(ctx,Cic.Rel n,ty)) ::
- create_subst_from_metas_to_rels (n-1) tl
- in
- let split_metasenv metasenv n =
- List.partition (fun (_,ctx,_) -> List.length ctx >= n) metasenv
- in
- let purge_unused_lambdas metasenv t =
- let rec aux = function
- | Cic.Lambda (_, Cic.Meta (i,_), t) when
- List.exists (fun (j,_,_) -> j = i) metasenv ->
- aux (CicSubstitution.subst (Cic.Rel ~-100) t)
- | Cic.Lambda (name, s, t) ->
- Cic.Lambda (name, s, aux t)
- | t -> t
- in
- aux t
- in
- let order_body_menv term body_metasenv c1_pis c2_pis =
- let rec purge_lambdas = function
- | Cic.Lambda (_,_,t) -> purge_lambdas t
- | t -> t
- in
- let skip_appl = function | Cic.Appl l -> List.tl l | _ -> assert false in
- let rec metas_of_term_and_types t =
- let metas = CicUtil.metas_of_term t in
- let types =
- List.flatten
- (List.map
- (fun (i,_) -> try
- let _,_,ty = CicUtil.lookup_meta i body_metasenv in metas_of_term_and_types ty
- with CicUtil.Meta_not_found _ -> [])
- metas)
- in
- metas @ types
- in
- let sorted_metas_of_term world t =
- let metas = metas_of_term_and_types t in
- (* this check should be useless *)
- let metas = List.filter (fun (i,_)->List.exists (fun (j,_,_) -> j=i) world) metas in
- let order_metas metasenv metas =
- let module OT = struct type t = int let compare = Pervasives.compare end in
- let module S = HTopoSort.Make (OT) in
- let dep i =
- try
- let _,_,ty = List.find (fun (j,_,_) -> j=i) metasenv in
- let metas = List.map fst (CicUtil.metas_of_term ty) in
- HExtlib.list_uniq (List.sort Pervasives.compare metas)
- with Not_found -> []
- in
- S.topological_sort (List.map (fun (i,_) -> i) metas) dep
- in
- order_metas world metas
- in
- let metas_that_saturate l =
- List.fold_left
- (fun (acc,n) t ->
- let metas = sorted_metas_of_term body_metasenv t in
- let metas =
- List.filter (fun i -> List.for_all (fun (j,_) -> j<>i) acc) metas in
- let metas = List.map (fun i -> i,n) metas in
- metas @ acc, n+1)
- ([],0) l
- in
- let l_c2 = skip_appl (purge_lambdas term) in
- let l_c2_b,l_c2_a =
- try
- HExtlib.split_nth (c2_pis - sat2 - 1) l_c2
- with
- Failure _ -> assert false in
- let l_c1,l_c2_a =
- match l_c2_a with
- Cic.Appl (_::l_c1)::tl -> l_c1,tl
- | _ -> assert false in
- let meta_to_be_coerced =
- try
- match List.nth l_c1 (c1_pis - sat1 - 1) with
- | Cic.Meta (i,_) -> Some i
- | t ->
- debug_print
- (lazy("meta_to_be_coerced: " ^ CicPp.ppterm t));
- debug_print
- (lazy("c1_pis: " ^ string_of_int c1_pis ^
- " sat1:" ^ string_of_int sat1));
- None
- with
- Failure _ -> assert false
- in
- (* BIG HACK ORRIBLE:
- * it should be (l_c2_b @ l_c1 @ l_c2_a), but in this case sym (eq_f) gets
- * \A,B,f,x,y,Exy and not \B,A,f,x,y,Exy
- * as an orrible side effect, the other composites get a type lyke
- * \A,x,y,Exy,B,f with 2 saturations
- *)
- let meta2no = fst (metas_that_saturate (l_c1 @ l_c2_b @ l_c2_a)) in
- let sorted =
- List.sort
- (fun (i,ctx1,ty1) (j,ctx1,ty1) ->
- try List.assoc i meta2no - List.assoc j meta2no
- with Not_found -> assert false)
- body_metasenv
- in
- let rec position_of n acc =
- function
- [] -> assert false
- | (i,_,_)::_ when i = n -> acc
- | _::tl -> position_of n (acc + 1) tl
- in
- let saturations_res, position_of_meta_to_be_coerced =
- match meta_to_be_coerced with
- | None -> 0,0
- | Some meta_to_be_coerced ->
- debug_print
- (lazy ("META_TO_BE_COERCED: " ^ string_of_int meta_to_be_coerced));
- let position_of_meta_to_be_coerced =
- position_of meta_to_be_coerced 0 sorted in
- debug_print (lazy ("POSITION_OF_META_TO_BE_COERCED: " ^
- string_of_int position_of_meta_to_be_coerced));
- List.length sorted - position_of_meta_to_be_coerced - 1,
- position_of_meta_to_be_coerced
- in
- debug_print (lazy ("SATURATIONS: " ^ string_of_int saturations_res));
- sorted, saturations_res, position_of_meta_to_be_coerced
- in
- let namer l n =
- let l = List.map (function Cic.Name s -> s | _ -> "A") l in
- let l = List.fold_left
- (fun acc s ->
- let rec add' s =
- if List.exists ((=) s) acc then add' (s^"'") else s
- in
- acc@[add' s])
- [] l
- in
- let l = List.rev l in
- Cic.Name (List.nth l (n-1))
- in
- debug_print (lazy ("\nCOMPOSING"));
- debug_print (lazy (" c1= "^CicPp.ppterm c1 ^" : "^ CicPp.ppterm c1_ty));
- debug_print (lazy (" c2= "^CicPp.ppterm c2 ^" : "^ CicPp.ppterm c2_ty));
- let c1_pis, names_c1 = count_pis c1_ty arity1 in
- let c2_pis, names_c2 = count_pis c2_ty arity2 in
- let c = compose c1 c1_pis c2 c2_pis in
- let spine_len = c1_pis + c2_pis in
- let c = mk_lambda_spine c (namer (names_c1 @ names_c2)) spine_len in
- debug_print (lazy ("COMPOSTA: " ^ CicPp.ppterm c));
- let old_insert_coercions = !CicRefine.insert_coercions in
- let old_pack_coercions = !CicRefine.pack_coercions in
- let c, metasenv, univ, saturationsres, cpos =
- try
- CicRefine.insert_coercions := false;
- CicRefine.pack_coercions := false;
- let term, ty, metasenv, ugraph =
- CicRefine.type_of_aux' metasenv context c univ
- in
- debug_print(lazy("COMPOSED REFINED: "^CicPp.ppterm term));
- debug_print(lazy("COMPOSED REFINED (pretty): "^
- CicMetaSubst.ppterm_in_context [] ~metasenv term context));
-(* let metasenv = order_metasenv metasenv in *)
-(* debug_print(lazy("ORDERED MENV: "^CicMetaSubst.ppmetasenv [] metasenv)); *)
- let body_metasenv, lambdas_metasenv =
- split_metasenv metasenv (spine_len + List.length context)
- in
- debug_print(lazy("B_MENV: "^CicMetaSubst.ppmetasenv [] body_metasenv));
- debug_print(lazy("L_MENV: "^CicMetaSubst.ppmetasenv [] lambdas_metasenv));
- let body_metasenv, saturationsres, cpos =
- order_body_menv term body_metasenv c1_pis c2_pis
- in
- debug_print(lazy("ORDERED_B_MENV: "^CicMetaSubst.ppmetasenv [] body_metasenv));
- let subst = create_subst_from_metas_to_rels spine_len body_metasenv in
- debug_print (lazy("SUBST: "^CicMetaSubst.ppsubst body_metasenv subst));
- let term = CicMetaSubst.apply_subst subst term in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- debug_print (lazy ("COMPOSED SUBSTITUTED: " ^ CicPp.ppterm term));
- let term, ty, metasenv, ugraph =
- CicRefine.type_of_aux' metasenv context term ugraph
- in
- let body_metasenv, lambdas_metasenv =
- split_metasenv metasenv (spine_len + List.length context)
- in
- let lambdas_metasenv =
- List.filter
- (fun (i,_,_) ->
- List.for_all (fun (j,_,_) -> i <> j) original_metasenv)
- lambdas_metasenv
- in
- let term = purge_unused_lambdas lambdas_metasenv term in
- let metasenv =
- List.filter
- (fun (i,_,_) ->
- List.for_all
- (fun (j,_,_) ->
- i <> j || List.exists (fun (j,_,_) -> j=i) original_metasenv)
- lambdas_metasenv)
- metasenv
- in
- debug_print (lazy ("####################"));
- debug_print (lazy ("COMPOSED: " ^ CicPp.ppterm term));
- debug_print (lazy ("SATURATIONS: " ^ string_of_int saturationsres));
- debug_print (lazy ("MENV: "^CicMetaSubst.ppmetasenv [] metasenv));
- debug_print (lazy ("####################"));
- CicRefine.insert_coercions := old_insert_coercions;
- CicRefine.pack_coercions := old_pack_coercions;
- term, metasenv, ugraph, saturationsres, cpos
- with
- | CicRefine.RefineFailure s
- | CicRefine.Uncertain s -> debug_print s;
- CicRefine.insert_coercions := old_insert_coercions;
- CicRefine.pack_coercions := old_pack_coercions;
- raise UnableToCompose
- | exn ->
- CicRefine.insert_coercions := old_insert_coercions;
- CicRefine.pack_coercions := old_pack_coercions;
- raise exn
- in
- let c_ty, univ =
- CicTypeChecker.type_of_aux' ~subst:[] [] [] c univ
- in
- let real_composed = ref true in
- let c =
- let rec is_id = function
- | Cic.Lambda(_,_,t) -> is_id t
- | Cic.Rel 1 -> true
- | _ -> false
- in
- let is_id = function
- | Cic.Const (u,_) ->
- (match CicEnvironment.get_obj CicUniv.empty_ugraph u with
- | Cic.Constant (_,Some bo,_,_,_), _ -> is_id bo
- | _ -> false)
- | _ -> false
- in
- let unvariant u =
- match CicEnvironment.get_obj CicUniv.empty_ugraph u with
- | Cic.Constant (_,Some (Cic.Const (u',_)),_,_,attrs), _
- when List.exists ((=) (`Flavour `Variant)) attrs ->
- u'
- | _ -> u
- in
- let is_variant u =
- match CicEnvironment.get_obj CicUniv.empty_ugraph u with
- | Cic.Constant (_,Some (Cic.Const (u',_)),_,_,attrs), _
- when List.exists ((=) (`Flavour `Variant)) attrs -> true
- | _ -> false
- in
- let rec aux = function
- | Cic.Lambda(n,s,t) -> Cic.Lambda(n,s,aux t)
- | Cic.Appl (c::_) as t ->
- let t =
- if is_id c then
- (real_composed := false ;
- CicReduction.head_beta_reduce ~delta:true t)
- else t
- in
- (match t with
- | Cic.Appl l -> Cic.Appl (List.map aux l)
- | Cic.Const (u,[]) when is_variant u -> Cic.Const (unvariant u,[])
- | t -> t)
- | Cic.Const (u,[]) when is_variant u -> Cic.Const (unvariant u,[])
- | t -> t
- in
- let simple_eta_c t =
- let incr =
- List.map (function Cic.Rel n -> Cic.Rel (n+1) | _ -> assert false)
- in
- let rec aux acc ctx = function
- | Cic.Lambda (n,s,tgt) ->
- aux (incr acc @ [Cic.Rel 1]) (Some (n,Cic.Decl s) ::ctx) tgt
- | Cic.Appl (t::tl) when tl = acc &&
- CicTypeChecker.does_not_occur ctx 0 (List.length acc) t -> true, t
- | t -> false, t
- in
- let b, newt = aux [] [] t in
- if b then newt else t
- in
- simple_eta_c (aux c)
- in
- debug_print (lazy ("COMPOSED COMPRESSED: " ^ string_of_bool !real_composed ^" : " ^ CicPp.ppterm c));
- c, c_ty, metasenv, univ, saturationsres, arity2, cpos, !real_composed
-;;
-
-let build_obj c c_ty univ arity is_var =
- let cleaned_ty =
- FreshNamesGenerator.clean_dummy_dependent_types c_ty
- in
- let obj = Cic.Constant ("xxxx",Some c,cleaned_ty,[],
- [`Generated] @ if not is_var then [`Flavour `Variant] else [] ) in
-
- obj,univ
-;;
-
-(* removes from l the coercions that are in !coercions *)
-let filter_duplicates l coercions =
- List.filter (
- fun (src,l1,tgt) ->
- not (List.exists (fun (s,t,l2) ->
- CoercDb.eq_carr s src &&
- CoercDb.eq_carr t tgt &&
- try
- List.for_all2 (fun (u1,_,_) (u2,_,_) -> UriManager.eq u1 u2) l1 l2
- with
- | Invalid_argument "List.for_all2" ->
- debug_print (lazy("XXX")); false)
- coercions))
- l
-;;
-
-let mangle s t l =
- (*List.fold_left
- (fun s x -> s ^ "_" ^ x)
- (s ^ "_OF_" ^ t ^ "_BY" ^ string_of_int (List.length l)) l*)
- s ^ "_OF_" ^ t
-;;
-
-exception ManglingFailed of string
-
-let number_if_already_defined buri name l =
- let err () =
- raise
- (ManglingFailed
- ("Unable to give an altenative name to " ^ buri ^ "/" ^ name ^ ".con"))
- in
- let rec aux n =
- let suffix = if n > 0 then ("__" ^ string_of_int n) else "" in
- let suri = buri ^ "/" ^ name ^ suffix ^ ".con" in
- let uri = UriManager.uri_of_string suri in
- let retry () = if n < max_int then aux (n+1) else err () in
- if List.exists (UriManager.eq uri) l then retry ()
- else
- try
- let _ = Http_getter.resolve' ~local:true ~writable:true uri in
- if Http_getter.exists' ~local:true uri then retry () else uri
- with
- | Http_getter_types.Key_not_found _ -> uri
- | Http_getter_types.Unresolvable_URI _ -> assert false
- in
- aux 0
-;;
-
-(* given a new coercion uri from src to tgt returns
- * a list of (new coercion uri, coercion obj, universe graph)
- *)
-let close_coercion_graph src tgt uri saturations baseuri =
- (* check if the coercion already exists *)
- let coercions = CoercDb.to_list (CoercDb.dump ()) in
- let todo_list = get_closure_coercions src tgt (uri,saturations,0) coercions in
- debug_print (lazy("composed " ^ string_of_int (List.length todo_list)));
- let todo_list = filter_duplicates todo_list coercions in
- try
- let new_coercions =
- List.fold_left
- (fun acc (src, l , tgt) ->
- try
- match l with
- | [] -> assert false
- | (he,saturations1,arity1) :: tl ->
- let first_step =
- Cic.Constant ("", Some (CicUtil.term_of_uri he),
- Cic.Sort Cic.Prop, [], [`Generated]),
- saturations1,
- arity1,0
- in
- let o,_ =
- List.fold_left (fun (o,univ) (coer,saturations2,arity2) ->
- match o with
- | Cic.Constant (_,Some u,_,[],_),saturations1,arity1,_ ->
- let t, t_ty, menv, univ, saturationsres,
- arityres, cposres, is_var
- =
- generate_composite' (u,saturations1,arity1)
- (CicUtil.term_of_uri coer,
- saturations2, arity2) [] [] univ
- in
- if (menv <> []) then
- HLog.warn "MENV non empty after composing coercions";
- let o,univ = build_obj t t_ty univ arityres is_var in
- (o,saturationsres,arityres,cposres),univ
- | _ -> assert false
- ) (first_step, CicUniv.oblivion_ugraph) tl
- in
- let name_src = CoercDb.string_of_carr src in
- let name_tgt = CoercDb.string_of_carr tgt in
- let by = List.map (fun u,_,_ -> UriManager.name_of_uri u) l in
- let name = mangle name_tgt name_src by in
- let c_uri =
- number_if_already_defined baseuri name
- (List.map (fun (_,_,u,_,_,_,_) -> u) acc)
- in
- let named_obj,saturations,arity,cpos =
- match o with
- | Cic.Constant (_,bo,ty,vl,attrs),saturations,arity,cpos ->
- Cic.Constant (name,bo,ty,vl,attrs),saturations,arity,cpos
- | _ -> assert false
- in
- (src,tgt,c_uri,saturations,named_obj,arity,cpos)::acc
- with UnableToCompose -> acc
- ) [] todo_list
- in
- new_coercions
- with ManglingFailed s -> HLog.error s; []
-;;
-
-CicCoercion.set_close_coercion_graph close_coercion_graph;;
-
-(* generate_composite (c2 (c1 s)) in the universe graph univ
- * both living in the same context and metasenv *)
-let generate_composite c1 c2 context metasenv univ sat1 sat2 =
- let a,_,b,c,_,_,_,_ =
- generate_composite' (c1,sat1,0) (c2,sat2,0) context metasenv univ
- in
- a,b,c
-;;
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* This module implements the Coercions transitive closure *)
-
-val close_coercion_graph:
- CoercDb.coerc_carr -> CoercDb.coerc_carr -> UriManager.uri -> int ->
- string (* baseuri *) ->
- (CoercDb.coerc_carr * CoercDb.coerc_carr * UriManager.uri *
- int (* saturations *) * Cic.obj * int (* arity *) * int (* cpos *)) list
-
-exception UnableToCompose
-
-val generate_composite:
- Cic.term -> Cic.term (* t2 *) -> Cic.context ->
- Cic.metasenv -> CicUniv.universe_graph ->
- int -> int (* saturations of t1/t2 *) ->
- Cic.term * Cic.metasenv * CicUniv.universe_graph
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-let debug = false;;
-let debug_print =
- if not debug then (fun _ -> ()) else (fun s -> prerr_endline (Lazy.force s))
-;;
-
-let rec count_pi = function Cic.Prod (_,_,t) -> count_pi t + 1 | _ -> 0 ;;
-
-let compose_core t2 t1 (proof, goal) =
- let _,metasenv,_subst,_,_,_ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let ty1,_ =
- CicTypeChecker.type_of_aux' metasenv context t1 CicUniv.oblivion_ugraph
- in
- let ty2,_ =
- CicTypeChecker.type_of_aux' metasenv context t2 CicUniv.oblivion_ugraph
- in
- let saturated_ty2, menv_for_saturated_ty2, args_t2 =
- let maxm = CicMkImplicit.new_meta metasenv [] in
- let ty2, menv, args, _ =
- TermUtil.saturate_term ~delta:false maxm metasenv context ty2 0 in
- ty2, menv, args
- in
- let saturations_t2 =
- let rec aux n = function
- | Cic.Meta (i,_)::tl ->
- let _,c,ty = CicUtil.lookup_meta i menv_for_saturated_ty2 in
- if fst (CicReduction.are_convertible c ty (Cic.Sort Cic.Prop)
- CicUniv.oblivion_ugraph)
- then n else aux (n+1) tl
- | _::tl -> aux (n+1) tl
- | [] -> n+1
- in
- List.length args_t2 - aux 0 args_t2 +1
- in
- debug_print (lazy("saturated_ty2: "^CicMetaSubst.ppterm_in_context
- [] ~metasenv:menv_for_saturated_ty2 saturated_ty2 context ^
- " saturations_t2:" ^ string_of_int saturations_t2));
- (* unifies t with saturated_ty2 and gives back a fresh meta of type t *)
- let unif menv t =
- let m, menv2 =
- let n = CicMkImplicit.new_meta menv [] in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- Cic.Meta (n,irl), ((n,context,t)::menv)
- in
- try
- let _ =
- CicUnification.fo_unif menv context t saturated_ty2
- CicUniv.oblivion_ugraph
- in
- true, menv2, m
- with
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ -> false, menv2, m
- in
- (* check which "positions" in the input arrow unifies with saturated_ty2 *)
- let rec positions menv cur saturations = function
- | Cic.Prod (n,s,t) ->
- let b, newmenv, sb = unif menv s in
- if b then
- (saturations - cur - 1) ::
- (positions newmenv (cur + 1) saturations
- (CicSubstitution.subst sb t))
- else
- positions newmenv (cur + 1) saturations (CicSubstitution.subst sb t)
- | _ -> []
- in
- (* position is a list of arities, that is if t1 : a -> b -> c and saturations
- * is 0 then the computed term will be (t1 ? t2) of type a -> c if saturations
- * is 1 then (t1 t2 ?) of type b -> c *)
- let rec generate positions menv acc =
- match positions with
- | [] -> acc, menv
- | saturations_t1::tl ->
- try
- let t, menv1, _ =
- CloseCoercionGraph.generate_composite t2 t1 context menv
- CicUniv.oblivion_ugraph saturations_t2 saturations_t1
- in
- assert (List.length menv1 = List.length menv);
- generate tl menv (t::acc)
- with
- | CloseCoercionGraph.UnableToCompose -> generate tl menv acc
- in
- let terms, metasenv =
- generate (positions menv_for_saturated_ty2 0 (count_pi ty1) ty1) metasenv []
- in
- (* the new proof has the resulting metasenv (shouldn't it be the same?) *)
- let proof =
- let uri, _, _subst, bo, ty, attrs = proof in
- uri, metasenv, _subst, bo, ty, attrs
- in
- (* now we have the terms, we generalize them and intros them *)
- let proof, goal =
- List.fold_left
- (fun (proof,goal) t ->
- let lazy_of t =
- ProofEngineTypes.const_lazy_term t
- in
- let proof, gl =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.generalize_tac (Some (lazy_of t), [], None))
- (proof,goal)
- in
- assert(List.length gl = 1);
- proof,List.hd gl)
- (proof,goal) terms
- in
- (proof, goal), List.length terms
-;;
-
-let compose_tac ?howmany ?mk_fresh_name_callback n t1 t2 proofstatus =
- let ((proof, goal), k), n =
- match t2 with
- | Some t2 -> compose_core t1 t2 proofstatus, n-1
- | None ->
- let k =
- let proof, goal = proofstatus in
- let _,metasenv,subst,_,_,_ = proof in
- let _,_,ty = CicUtil.lookup_meta goal metasenv in
- count_pi (CicMetaSubst.apply_subst subst ty)
- in
- (proofstatus, k), n
- in
- let (proof, goal), k =
- (* fix iterates n times the composition *)
- let rec fix proofstatus k t = function
- | 0 -> proofstatus, k
- | n ->
- let t = CicSubstitution.lift k t in
- let proof, gl =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.intros_tac
- ~howmany:k ?mk_fresh_name_callback ()) proofstatus
- in
- assert (List.length gl = 1);
- let goal = List.hd gl in
- let k, proofstatus =
- (* aux compose t with every previous result *)
- let rec aux k proofstatus = function
- | 0 -> k, proofstatus
- | n ->
- let (proof, goal), k1 =
- compose_core t (Cic.Rel n) proofstatus
- in
- aux (k+k1) (proof, goal) (n-1)
- in
- aux 0 (proof, goal) k
- in
- fix proofstatus k t (n-1)
- in
- fix (proof, goal) k t1 n
- in
- let howmany =
- match howmany with
- | None -> None
- | Some i ->
- if i - k < 0 then (* we should generalize back and clear *) Some 0
- else Some (i - k)
- in
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.intros_tac ?howmany ?mk_fresh_name_callback ())
- (proof,goal)
-;;
-
-let compose_tac ?howmany ?mk_fresh_name_callback times t1 t2 =
- ProofEngineTypes.mk_tactic
- (compose_tac ?howmany ?mk_fresh_name_callback times t1 t2)
-;;
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val compose_tac:
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- int (* times *) ->
- Cic.term -> Cic.term option -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-let debug = false
-let debug_print s = if debug then prerr_endline (Lazy.force s) else ()
-
-exception Error of string lazy_t
-let fail msg = raise (Error msg)
-
-type goal = ProofEngineTypes.goal
-
-module Stack =
-struct
- type switch = Open of goal | Closed of goal
- type locator = int * switch
- type tag = [ `BranchTag | `FocusTag | `NoTag ]
- type entry = locator list * locator list * locator list * tag
- type t = entry list
-
- let empty = [ [], [], [], `NoTag ]
-
- let fold ~env ~cont ~todo init stack =
- let rec aux acc depth =
- function
- | [] -> acc
- | (locs, todos, conts, tag) :: tl ->
- let acc = List.fold_left (fun acc -> env acc depth tag) acc locs in
- let acc = List.fold_left (fun acc -> cont acc depth tag) acc conts in
- let acc = List.fold_left (fun acc -> todo acc depth tag) acc todos in
- aux acc (depth + 1) tl
- in
- assert (stack <> []);
- aux init 0 stack
-
- let iter ~env ~cont ~todo =
- fold ~env:(fun _ -> env) ~cont:(fun _ -> cont) ~todo:(fun _ -> todo) ()
-
- let map ~env ~cont ~todo =
- let depth = ref ~-1 in
- List.map
- (fun (s, t, c, tag) ->
- incr depth;
- let d = !depth in
- env d tag s, todo d tag t, cont d tag c, tag)
-
- let is_open = function _, Open _ -> true | _ -> false
- let close = function n, Open g -> n, Closed g | l -> l
- let filter_open = List.filter is_open
- let is_fresh =
- function n, Open _ when n > 0 -> true | _,Closed _ -> true | _ -> false
- let goal_of_loc = function _, Open g | _, Closed g -> g
- let goal_of_switch = function Open g | Closed g -> g
- let switch_of_loc = snd
-
- let zero_pos = List.map (fun g -> 0, Open g)
-
- let init_pos locs =
- let pos = ref 0 in (* positions are 1-based *)
- List.map (function _, sw -> incr pos; !pos, sw) locs
-
- let extract_pos i =
- let rec aux acc =
- function
- | [] -> fail (lazy (sprintf "relative position %d not found" i))
- | (i', _) as loc :: tl when i = i' -> loc, (List.rev acc) @ tl
- | hd :: tl -> aux (hd :: acc) tl
- in
- aux []
-
- let deep_close gs =
- let close _ _ =
- List.map (fun l -> if List.mem (goal_of_loc l) gs then close l else l)
- in
- let rm _ _ = List.filter (fun l -> not (List.mem (goal_of_loc l) gs)) in
- map ~env:close ~cont:rm ~todo:rm
-
- let rec find_goal =
- function
- | [] -> raise (Failure "Continuationals.find_goal")
- | (l :: _, _ , _ , _) :: _ -> goal_of_loc l
- | ( _ , _ , l :: _, _) :: _ -> goal_of_loc l
- | ( _ , l :: _, _ , _) :: _ -> goal_of_loc l
- | _ :: tl -> find_goal tl
-
- let is_empty =
- function
- | [] -> assert false
- | [ [], [], [], `NoTag ] -> true
- | _ -> false
-
- let of_metasenv metasenv =
- let goals = List.map (fun (g, _, _) -> g) metasenv in
- [ zero_pos goals, [], [], `NoTag ]
-
- let of_nmetasenv metasenv =
- let goals = List.map (fun (g, _) -> g) metasenv in
- [ zero_pos goals, [], [], `NoTag ]
-
- let head_switches =
- function
- | (locs, _, _, _) :: _ -> List.map switch_of_loc locs
- | [] -> assert false
-
- let head_goals =
- function
- | (locs, _, _, _) :: _ -> List.map goal_of_loc locs
- | [] -> assert false
-
- let head_tag =
- function
- | (_, _, _, tag) :: _ -> tag
- | [] -> assert false
-
- let shift_goals =
- function
- | _ :: (locs, _, _, _) :: _ -> List.map goal_of_loc locs
- | [] -> assert false
- | _ -> []
-
- let open_goals stack =
- let add_open acc _ _ l = if is_open l then goal_of_loc l :: acc else acc in
- List.rev (fold ~env:add_open ~cont:add_open ~todo:add_open [] stack)
-
- let (@+) = (@) (* union *)
-
- let (@-) s1 s2 = (* difference *)
- List.fold_right
- (fun e acc -> if List.mem e s2 then acc else e :: acc)
- s1 []
-
- let (@~-) locs gs = (* remove some goals from a locators list *)
- List.fold_right
- (fun loc acc -> if List.mem (goal_of_loc loc) gs then acc else loc :: acc)
- locs []
-
- let pp stack =
- let pp_goal = string_of_int in
- let pp_switch =
- function Open g -> "o" ^ pp_goal g | Closed g -> "c" ^ pp_goal g
- in
- let pp_loc (i, s) = string_of_int i ^ pp_switch s in
- let pp_env env = sprintf "[%s]" (String.concat ";" (List.map pp_loc env)) in
- let pp_tag = function `BranchTag -> "B" | `FocusTag -> "F" | `NoTag -> "N" in
- let pp_stack_entry (env, todo, cont, tag) =
- sprintf "(%s, %s, %s, %s)" (pp_env env) (pp_env todo) (pp_env cont)
- (pp_tag tag)
- in
- String.concat " :: " (List.map pp_stack_entry stack)
-end
-
-module type Status =
-sig
- type input_status
- type output_status
-
- type tactic
- val mk_tactic : (input_status -> output_status) -> tactic
- val apply_tactic : tactic -> input_status -> output_status
-
- val goals : output_status -> goal list * goal list (** opened, closed goals *)
- val get_stack : input_status -> Stack.t
- val set_stack : Stack.t -> output_status -> output_status
-
- val inject : input_status -> output_status
- val focus : goal -> output_status -> input_status
-end
-
-module type C =
-sig
- type input_status
- type output_status
- type tactic
-
- type tactical =
- | Tactic of tactic
- | Skip
-
- type t =
- | Dot
- | Semicolon
-
- | Branch
- | Shift
- | Pos of int list
- | Wildcard
- | Merge
-
- | Focus of goal list
- | Unfocus
-
- | Tactical of tactical
-
- val eval: t -> input_status -> output_status
-end
-
-module Make (S: Status) =
-struct
- open Stack
-
- type input_status = S.input_status
- type output_status = S.output_status
- type tactic = S.tactic
-
- type tactical =
- | Tactic of tactic
- | Skip
-
- type t =
- | Dot
- | Semicolon
- | Branch
- | Shift
- | Pos of int list
- | Wildcard
- | Merge
- | Focus of goal list
- | Unfocus
- | Tactical of tactical
-
- let pp_t =
- function
- | Dot -> "Dot"
- | Semicolon -> "Semicolon"
- | Branch -> "Branch"
- | Shift -> "Shift"
- | Pos i -> "Pos " ^ (String.concat "," (List.map string_of_int i))
- | Wildcard -> "Wildcard"
- | Merge -> "Merge"
- | Focus gs ->
- sprintf "Focus [%s]" (String.concat "; " (List.map string_of_int gs))
- | Unfocus -> "Unfocus"
- | Tactical _ -> "Tactical <abs>"
-
- let eval_tactical tactical ostatus switch =
- match tactical, switch with
- | Tactic tac, Open n ->
- let ostatus = S.apply_tactic tac (S.focus n ostatus) in
- let opened, closed = S.goals ostatus in
- ostatus, opened, closed
- | Skip, Closed n -> ostatus, [], [n]
- | Tactic _, Closed _ -> fail (lazy "can't apply tactic to a closed goal")
- | Skip, Open _ -> fail (lazy "can't skip an open goal")
-
- let eval cmd istatus =
- let stack = S.get_stack istatus in
- debug_print (lazy (sprintf "EVAL CONT %s <- %s" (pp_t cmd) (pp stack)));
- let new_stack stack = S.inject istatus, stack in
- let ostatus, stack =
- match cmd, stack with
- | _, [] -> assert false
- | Tactical tac, (g, t, k, tag) :: s ->
-(* COMMENTED OUT TO ALLOW PARAMODULATION TO DO A
- * auto paramodulation.try assumption.
- * EVEN IF NO GOALS ARE LEFT OPEN BY AUTO.
-
- if g = [] then fail (lazy "can't apply a tactic to zero goals");
-
-*)
- debug_print (lazy ("context length " ^string_of_int (List.length g)));
- let rec aux s go gc =
- function
- | [] -> s, go, gc
- | loc :: loc_tl ->
- debug_print (lazy "inner eval tactical");
- let s, go, gc =
- if List.exists ((=) (goal_of_loc loc)) gc then
- s, go, gc
- else
- let s, go', gc' = eval_tactical tac s (switch_of_loc loc) in
- s, (go @- gc') @+ go', gc @+ gc'
- in
- aux s go gc loc_tl
- in
- let s0, go0, gc0 = S.inject istatus, [], [] in
- let sn, gon, gcn = aux s0 go0 gc0 g in
- debug_print (lazy ("opened: "
- ^ String.concat " " (List.map string_of_int gon)));
- debug_print (lazy ("closed: "
- ^ String.concat " " (List.map string_of_int gcn)));
- let stack =
- (zero_pos gon, t @~- gcn, k @~- gcn, tag) :: deep_close gcn s
- in
- sn, stack
- | Dot, ([], _, [], _) :: _ ->
- (* backward compatibility: do-nothing-dot *)
- new_stack stack
- | Dot, (g, t, k, tag) :: s ->
- (match filter_open g, k with
- | loc :: loc_tl, _ -> new_stack (([ loc ], t, loc_tl @+ k, tag) :: s)
- | [], loc :: k ->
- assert (is_open loc);
- new_stack (([ loc ], t, k, tag) :: s)
- | _ -> fail (lazy "can't use \".\" here"))
- | Semicolon, _ -> new_stack stack
- | Branch, (g, t, k, tag) :: s ->
- (match init_pos g with
- | [] | [ _ ] -> fail (lazy "too few goals to branch");
- | loc :: loc_tl ->
- new_stack
- (([ loc ], [], [], `BranchTag) :: (loc_tl, t, k, tag) :: s))
- | Shift, (g, t, k, `BranchTag) :: (g', t', k', tag) :: s ->
- (match g' with
- | [] -> fail (lazy "no more goals to shift")
- | loc :: loc_tl ->
- new_stack
- (([ loc ], t @+ filter_open g @+ k, [],`BranchTag)
- :: (loc_tl, t', k', tag) :: s))
- | Shift, _ -> fail (lazy "can't shift goals here")
- | Pos i_s, ([ loc ], t, [],`BranchTag) :: (g', t', k', tag) :: s
- when is_fresh loc ->
- let l_js = List.filter (fun (i, _) -> List.mem i i_s) ([loc] @+ g') in
- new_stack
- ((l_js, t , [],`BranchTag)
- :: (([ loc ] @+ g') @- l_js, t', k', tag) :: s)
- | Pos _, _ -> fail (lazy "can't use relative positioning here")
- | Wildcard, ([ loc ] , t, [], `BranchTag) :: (g', t', k', tag) :: s
- when is_fresh loc ->
- new_stack
- (([loc] @+ g', t, [], `BranchTag)
- :: ([], t', k', tag) :: s)
- | Wildcard, _ -> fail (lazy "can't use wildcard here")
- | Merge, (g, t, k,`BranchTag) :: (g', t', k', tag) :: s ->
- new_stack ((t @+ filter_open g @+ g' @+ k, t', k', tag) :: s)
- | Merge, _ -> fail (lazy "can't merge goals here")
- | Focus [], _ -> assert false
- | Focus gs, s ->
- let stack_locs =
- let add_l acc _ _ l = if is_open l then l :: acc else acc in
- Stack.fold ~env:add_l ~cont:add_l ~todo:add_l [] s
- in
- List.iter
- (fun g ->
- if not (List.exists (fun l -> goal_of_loc l = g) stack_locs) then
- fail (lazy (sprintf "goal %d not found (or closed)" g)))
- gs;
- new_stack ((zero_pos gs, [], [], `FocusTag) :: deep_close gs s)
- | Unfocus, ([], [], [], `FocusTag) :: s -> new_stack s
- | Unfocus, _ -> fail (lazy "can't unfocus, some goals are still open")
- in
- debug_print (lazy (sprintf "EVAL CONT %s -> %s" (pp_t cmd) (pp stack)));
- S.set_stack stack ostatus
-end
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-exception Error of string Lazy.t
-
-type goal = ProofEngineTypes.goal
-
-(** {2 Goal stack} *)
-
-module Stack:
-sig
- type switch = Open of goal | Closed of goal
- type locator = int * switch
- type tag = [ `BranchTag | `FocusTag | `NoTag ]
- type entry = locator list * locator list * locator list * tag
- type t = entry list
-
- val empty: t
-
- val find_goal: t -> goal (** find "next" goal *)
- val is_empty: t -> bool (** a singleton empty level *)
- val of_metasenv: Cic.metasenv -> t
- val of_nmetasenv: (goal * 'a) list -> t
- val head_switches: t -> switch list (** top level switches *)
- val head_goals: t -> goal list (** top level goals *)
- val head_tag: t -> tag (** top level tag *)
- val shift_goals: t -> goal list (** second level goals *)
- val open_goals: t -> goal list (** all (Open) goals *)
- val goal_of_switch: switch -> goal
- val filter_open : (goal * switch) list -> (goal * switch) list
- val is_open: goal * switch -> bool
- val is_fresh: goal * switch -> bool
- val init_pos: (goal * switch) list -> (goal * switch) list
- val goal_of_loc: goal * switch -> goal
- val switch_of_loc: goal * switch -> switch
- val zero_pos : goal list -> (goal * switch) list
- val deep_close: goal list -> t -> t
-
-
- val ( @+ ) : 'a list -> 'a list -> 'a list
- val ( @- ) : 'a list -> 'a list -> 'a list
- val ( @~- ) : ('a * switch) list -> goal list -> ('a * switch) list
-
-
-
- (** @param int depth, depth 0 is the top of the stack *)
- val fold:
- env: ('a -> int -> tag -> locator -> 'a) ->
- cont:('a -> int -> tag -> locator -> 'a) ->
- todo:('a -> int -> tag -> locator -> 'a) ->
- 'a -> t -> 'a
-
- val iter: (** @param depth as above *)
- env: (int -> tag -> locator -> unit) ->
- cont:(int -> tag -> locator -> unit) ->
- todo:(int -> tag -> locator -> unit) ->
- t -> unit
-
- val map: (** @param depth as above *)
- env: (int -> tag -> locator list -> locator list) ->
- cont:(int -> tag -> locator list -> locator list) ->
- todo:(int -> tag -> locator list -> locator list) ->
- t -> t
-
- val pp: t -> string
-end
-
-(** {2 Functorial interface} *)
-
-module type Status =
-sig
- type input_status
- type output_status
-
- type tactic
- val mk_tactic : (input_status -> output_status) -> tactic
- val apply_tactic : tactic -> input_status -> output_status
-
- val goals : output_status -> goal list * goal list (** opened, closed goals *)
- val get_stack : input_status -> Stack.t
- val set_stack : Stack.t -> output_status -> output_status
-
- val inject : input_status -> output_status
- val focus : goal -> output_status -> input_status
-end
-
-module type C =
-sig
- type input_status
- type output_status
- type tactic
-
- type tactical =
- | Tactic of tactic
- | Skip
-
- type t =
- | Dot
- | Semicolon
-
- | Branch
- | Shift
- | Pos of int list
- | Wildcard
- | Merge
-
- | Focus of goal list
- | Unfocus
-
- | Tactical of tactical
-
- val eval: t -> input_status -> output_status
-end
-
-module Make (S: Status) : C
- with type tactic = S.tactic
- and type input_status = S.input_status
- and type output_status = S.output_status
-
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type just = [ `Term of Cic.term | `Auto of Auto.auto_params ]
-
-let mk_just ~dbd ~automation_cache =
- function
- `Auto (l,params) ->
- Tactics.auto ~dbd
- ~params:(l,("skip_trie_filtering","1")::(*("skip_context","1")::*)params) ~automation_cache
- | `Term t -> Tactics.apply t
-;;
-
-let assume id t =
- Tacticals.then_
- ~start:
- (Tactics.intros ~howmany:1
- ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id) ())
- ~continuation:
- (Tactics.change ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None)
- (fun _ metasenv ugraph -> t,metasenv,ugraph))
-;;
-
-let suppose t id ty =
-(*BUG: check on t missing *)
- let ty = match ty with None -> t | Some ty -> ty in
- Tacticals.then_
- ~start:
- (Tactics.intros ~howmany:1
- ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id) ())
- ~continuation:
- (Tactics.change ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None)
- (fun _ metasenv ugraph -> ty,metasenv,ugraph))
-;;
-
-let by_just_we_proved ~dbd ~automation_cache just ty id ty' =
- let just = mk_just ~dbd ~automation_cache just in
- match id with
- None ->
- (match ty' with
- None -> assert false
- | Some ty' ->
- Tacticals.then_
- ~start:(Tactics.change
- ~pattern:(ProofEngineTypes.conclusion_pattern None)
- (fun _ metasenv ugraph -> ty,metasenv,ugraph))
- ~continuation:just
- )
- | Some id ->
- let ty',continuation =
- match ty' with
- None -> ty,just
- | Some ty' ->
- ty',
- Tacticals.then_
- ~start:
- (Tactics.change
- ~with_cast:true
- ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None)
- (fun _ metasenv ugraph -> ty,metasenv,ugraph))
- ~continuation:just
- in
- Tacticals.thens
- ~start:
- (Tactics.cut ty'
- ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id))
- ~continuations:[ Tacticals.id_tac ; continuation ]
-;;
-
-let bydone ~dbd ~automation_cache just =
- mk_just ~dbd ~automation_cache just
-;;
-
-let we_need_to_prove t id ty =
- match id with
- None ->
- (match ty with
- None -> Tacticals.id_tac (*BUG: check missing here *)
- | Some ty ->
- Tactics.change ~pattern:(ProofEngineTypes.conclusion_pattern None)
- (fun _ metasenv ugraph -> ty,metasenv,ugraph))
- | Some id ->
- let aux status =
- let cont,cutted =
- match ty with
- None -> Tacticals.id_tac,t
- | Some ty ->
- Tactics.change ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None)
- (fun _ metasenv ugraph -> t,metasenv,ugraph), ty in
- let proof,goals =
- ProofEngineTypes.apply_tactic
- (Tacticals.thens
- ~start:
- (Tactics.cut cutted
- ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id))
- ~continuations:[cont])
- status
- in
- let goals' =
- match goals with
- [fst; snd] -> [snd; fst]
- | _ -> assert false
- in
- proof,goals'
- in
- ProofEngineTypes.mk_tactic aux
-;;
-
-let existselim ~dbd ~automation_cache just id1 t1 id2 t2 =
- let aux (proof, goal) =
- let (n,metasenv,_subst,bo,ty,attrs) = proof in
- let metano,context,_ = CicUtil.lookup_meta goal metasenv in
- let t2, metasenv, _ = t2 (Some (Cic.Name id1, Cic.Decl t1) :: context) metasenv CicUniv.oblivion_ugraph in
- let proof' = (n,metasenv,_subst,bo,ty,attrs) in
- ProofEngineTypes.apply_tactic (
- Tacticals.thens
- ~start:(Tactics.cut (Cic.Appl [Cic.MutInd (UriManager.uri_of_string "cic:/matita/logic/connectives/ex.ind", 0, []); t1 ; Cic.Lambda (Cic.Name id1, t1, t2)]))
- ~continuations:
- [ Tactics.elim_intros (Cic.Rel 1)
- ~mk_fresh_name_callback:
- (let i = ref 0 in
- fun _ _ _ ~typ ->
- incr i;
- if !i = 1 then Cic.Name id1 else Cic.Name id2) ;
- (mk_just ~dbd ~automation_cache just)
- ]) (proof', goal)
- in
- ProofEngineTypes.mk_tactic aux
-;;
-
-let andelim ~dbd ~automation_cache just id1 t1 id2 t2 =
- Tacticals.thens
- ~start:(Tactics.cut (Cic.Appl [Cic.MutInd (UriManager.uri_of_string "cic:/matita/logic/connectives/And.ind", 0, []); t1 ; t2]))
- ~continuations:
- [ Tactics.elim_intros (Cic.Rel 1)
- ~mk_fresh_name_callback:
- (let i = ref 0 in
- fun _ _ _ ~typ ->
- incr i;
- if !i = 1 then Cic.Name id1 else Cic.Name id2) ;
- (mk_just ~dbd ~automation_cache just) ]
-;;
-
-let rewritingstep ~dbd ~automation_cache lhs rhs just last_step =
- let aux ((proof,goal) as status) =
- let (curi,metasenv,_subst,proofbo,proofty, attrs) = proof in
- let _,context,gty = CicUtil.lookup_meta goal metasenv in
- let eq,trans =
- match LibraryObjects.eq_URI () with
- None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default equality first. Please use the \"default\" command"))
- | Some uri ->
- Cic.MutInd (uri,0,[]), Cic.Const (LibraryObjects.trans_eq_URI ~eq:uri,[])
- in
- let ty,_ =
- CicTypeChecker.type_of_aux' metasenv context rhs CicUniv.oblivion_ugraph in
- let just' =
- match just with
- `Auto (univ, params) ->
- let params =
- if not (List.exists (fun (k,_) -> k = "timeout") params) then
- ("timeout","3")::params
- else params
- in
- let params' =
- if not (List.exists (fun (k,_) -> k = "paramodulation") params) then
- ("paramodulation","1")::params
- else params
- in
- if params = params' then
- Tactics.auto ~dbd ~params:(univ, params) ~automation_cache
- else
- Tacticals.first
- [Tactics.auto ~dbd ~params:(univ, params) ~automation_cache ;
- Tactics.auto ~dbd ~params:(univ, params') ~automation_cache]
- | `Term just -> Tactics.apply just
- | `SolveWith term ->
- Tactics.demodulate ~automation_cache ~dbd
- ~params:(Some [term],
- ["all","1";"steps","1"; "use_context","false"])
- | `Proof ->
- Tacticals.id_tac
- in
- let plhs,prhs,prepare =
- match lhs with
- None ->
- let plhs,prhs =
- match gty with
- Cic.Appl [_;_;plhs;prhs] -> plhs,prhs
- | _ -> assert false
- in
- plhs,prhs,
- (fun continuation ->
- ProofEngineTypes.apply_tactic continuation status)
- | Some (None,lhs) ->
- let plhs,prhs =
- match gty with
- Cic.Appl [_;_;plhs;prhs] -> plhs,prhs
- | _ -> assert false
- in
- (*CSC: manca check plhs convertibile con lhs *)
- plhs,prhs,
- (fun continuation ->
- ProofEngineTypes.apply_tactic continuation status)
- | Some (Some name,lhs) ->
- let newmeta = CicMkImplicit.new_meta metasenv [] in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let plhs = lhs in
- let prhs = Cic.Meta(newmeta,irl) in
- plhs,prhs,
- (fun continuation ->
- let metasenv = (newmeta, context, ty)::metasenv in
- let mk_fresh_name_callback =
- fun metasenv context _ ~typ ->
- FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context
- (Cic.Name name) ~typ
- in
- let proof = curi,metasenv,_subst,proofbo,proofty, attrs in
- let proof,goals =
- ProofEngineTypes.apply_tactic
- (Tacticals.thens
- ~start:(Tactics.cut ~mk_fresh_name_callback
- (Cic.Appl [eq ; ty ; lhs ; prhs]))
- ~continuations:[Tacticals.id_tac ; continuation]) (proof,goal)
- in
- let goals =
- match just,goals with
- `Proof, [g1;g2;g3] -> [g2;g3;newmeta;g1]
- | _, [g1;g2] -> [g2;newmeta;g1]
- | _, l ->
- prerr_endline (String.concat "," (List.map string_of_int l));
- prerr_endline (CicMetaSubst.ppmetasenv [] metasenv);
- assert false
- in
- proof,goals)
- in
- let continuation =
- if last_step then
- (*CSC:manca controllo sul fatto che rhs sia convertibile con prhs*)
- just'
- else
- Tacticals.thens
- ~start:(Tactics.apply ~term:(Cic.Appl [trans;ty;plhs;rhs;prhs]))
- ~continuations:[just' ; Tacticals.id_tac]
- in
- prepare continuation
- in
- ProofEngineTypes.mk_tactic aux
-;;
-
-let we_proceed_by_cases_on t pat =
- (*BUG here: pat unused *)
- Tactics.cases_intros t
-;;
-
-let we_proceed_by_induction_on t pat =
-(* let pattern = None, [], Some pat in *)
- Tactics.elim_intros ~depth:0 (*~pattern*) t
-;;
-
-let case id ~params =
- (*BUG here: id unused*)
- (*BUG here: it does not verify that the previous branch is closed *)
- (*BUG here: the params should be parsed telescopically*)
- (*BUG here: the tactic_terms should be terms*)
- let rec aux ~params ((proof,goal) as status) =
- match params with
- [] -> proof,[goal]
- | (id,t)::tl ->
- match ProofEngineTypes.apply_tactic (assume id t) status with
- proof,[goal] -> aux tl (proof,goal)
- | _ -> assert false
- in
- ProofEngineTypes.mk_tactic (aux ~params)
-;;
-
-let thesisbecomes t =
-let ty = None in
- match ty with
- None ->
- Tactics.change ~pattern:(None,[],Some (Cic.Implicit (Some `Hole)))
- (fun _ metasenv ugraph -> t,metasenv,ugraph)
- | Some ty ->
- (*BUG here: missing check on t *)
- Tactics.change ~pattern:(None,[],Some (Cic.Implicit (Some `Hole)))
- (fun _ metasenv ugraph -> ty,metasenv,ugraph)
-;;
-
-let byinduction t id = suppose t id None;;
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type just = [ `Term of Cic.term | `Auto of Auto.auto_params ]
-
-val assume : string -> Cic.term -> ProofEngineTypes.tactic
-
-val suppose : Cic.term -> string -> Cic.term option -> ProofEngineTypes.tactic
-
-val by_just_we_proved :
- dbd:HSql.dbd -> automation_cache:AutomationCache.cache ->
- just -> Cic.term -> string option -> Cic.term option ->
- ProofEngineTypes.tactic
-
-val bydone : dbd:HSql.dbd -> automation_cache:AutomationCache.cache ->
- just -> ProofEngineTypes.tactic
-
-val we_need_to_prove :
- Cic.term -> string option -> Cic.term option -> ProofEngineTypes.tactic
-
-val we_proceed_by_cases_on : Cic.term -> Cic.term -> ProofEngineTypes.tactic
-
-val we_proceed_by_induction_on : Cic.term -> Cic.term -> ProofEngineTypes.tactic
-
-val byinduction : Cic.term -> string -> ProofEngineTypes.tactic
-
-val thesisbecomes : Cic.term -> ProofEngineTypes.tactic
-
-val case : string -> params:(string * Cic.term) list -> ProofEngineTypes.tactic
-
-val existselim :
- dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> just ->
- string -> Cic.term -> string -> Cic.lazy_term -> ProofEngineTypes.tactic
-
-val andelim :
- dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> just ->
- string -> Cic.term -> string -> Cic.term -> ProofEngineTypes.tactic
-
-val rewritingstep :
- dbd:HSql.dbd -> automation_cache:AutomationCache.cache ->
- (string option * Cic.term) option -> Cic.term ->
- [ `Term of Cic.term | `Auto of Auto.auto_params
- | `Proof | `SolveWith of Cic.term] ->
- bool (* last step *) -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module C = Cic
-module U = UriManager
-module P = PrimitiveTactics
-module T = Tacticals
-module CR = CicReduction
-module PST = ProofEngineStructuralRules
-module PET = ProofEngineTypes
-module CTC = CicTypeChecker
-module CU = CicUniv
-module S = CicSubstitution
-module RT = ReductionTactics
-module PEH = ProofEngineHelpers
-module ET = EqualityTactics
-module DTI = DoubleTypeInference
-
-let debug = false
-let debug_print =
- if debug then (fun x -> prerr_endline (Lazy.force x)) else (fun _ -> ())
-
-(* term ha tipo t1=t2; funziona solo se t1 e t2 hanno in testa costruttori
-diversi *)
-
-let discriminate_tac ~term =
- let true_URI =
- match LibraryObjects.true_URI () with
- Some uri -> uri
- | None -> raise (PET.Fail (lazy "You need to register the default \"true\" definition first. Please use the \"default\" command")) in
- let false_URI =
- match LibraryObjects.false_URI () with
- Some uri -> uri
- | None -> raise (PET.Fail (lazy "You need to register the default \"false\" definition first. Please use the \"default\" command")) in
- let fail msg = raise (PET.Fail (lazy ("Discriminate: " ^ msg))) in
- let find_discriminating_consno t1 t2 =
- let rec aux t1 t2 =
- match t1, t2 with
- | C.MutConstruct _, C.MutConstruct _ when t1 = t2 -> None
- | C.Appl ((C.MutConstruct _ as constr1) :: args1),
- C.Appl ((C.MutConstruct _ as constr2) :: args2)
- when constr1 = constr2 ->
- let rec aux_list l1 l2 =
- match l1, l2 with
- | [], [] -> None
- | hd1 :: tl1, hd2 :: tl2 ->
- (match aux hd1 hd2 with
- | None -> aux_list tl1 tl2
- | Some _ as res -> res)
- | _ -> (* same constructor applied to a different number of args *)
- assert false
- in
- aux_list args1 args2
- | ((C.MutConstruct (_,_,consno1,subst1)),
- (C.MutConstruct (_,_,consno2,subst2)))
- | ((C.MutConstruct (_,_,consno1,subst1)),
- (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _)))
- | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)),
- (C.MutConstruct (_,_,consno2,subst2)))
- | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)),
- (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _)))
- when (consno1 <> consno2) || (subst1 <> subst2) ->
- Some consno2
- | _ -> fail "not a discriminable equality"
- in
- aux t1 t2
- in
- let mk_branches_and_outtype turi typeno consno context args =
- (* a list of "True" except for the element in position consno which
- * is "False" *)
- match fst (CicEnvironment.get_obj CU.oblivion_ugraph turi) with
- | C.InductiveDefinition (ind_type_list,_,paramsno,_) ->
- let _,_,rty,constructor_list = List.nth ind_type_list typeno in
- let false_constr_id,_ = List.nth constructor_list (consno - 1) in
- let branches =
- List.map
- (fun (id,cty) ->
- (* dubbio: e' corretto ridurre in questo context ??? *)
- let red_ty = CR.whd context cty in
- let rec aux t k =
- match t with
- | C.Prod (_,_,target) when (k <= paramsno) ->
- S.subst (List.nth args (k-1))
- (aux target (k+1))
- | C.Prod (binder,source,target) when (k > paramsno) ->
- C.Lambda (binder, source, (aux target (k+1)))
- | _ ->
- if (id = false_constr_id)
- then (C.MutInd(false_URI,0,[]))
- else (C.MutInd(true_URI,0,[]))
- in
- (S.lift 1 (aux red_ty 1)))
- constructor_list in
- let outtype =
- let seed = ref 0 in
- let rec mk_lambdas rev_left_args =
- function
- 0, args, C.Prod (_,so,ta) ->
- C.Lambda
- (C.Name (incr seed; "x" ^ string_of_int !seed),
- so,
- mk_lambdas rev_left_args (0,args,ta))
- | 0, args, C.Sort _ ->
- let rec mk_rels =
- function
- 0 -> []
- | n -> C.Rel n :: mk_rels (n - 1) in
- let argsno = List.length args in
- C.Lambda
- (C.Name "x",
- (if argsno + List.length rev_left_args > 0 then
- C.Appl
- (C.MutInd (turi, typeno, []) ::
- (List.map
- (S.lift (argsno + 1))
- (List.rev rev_left_args)) @
- mk_rels argsno)
- else
- C.MutInd (turi,typeno,[])),
- C.Sort C.Prop)
- | 0, _, _ -> assert false (* seriously screwed up *)
- | n, he::tl, C.Prod (_,_,ta) ->
- mk_lambdas (he::rev_left_args)(n-1,tl,S.subst he ta)
- | n,_,_ ->
- assert false (* we should probably reduce in some context *)
- in
- mk_lambdas [] (paramsno, args, rty)
- in
- branches, outtype
- | _ -> assert false
- in
- let discriminate'_tac ~term status =
- let (proof, goal) = status in
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let termty,_ =
- CTC.type_of_aux' metasenv context term CU.oblivion_ugraph
- in
- match termty with
- | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
- when LibraryObjects.is_eq_URI equri ->
- let turi,typeno,exp_named_subst,args =
- match tty with
- | (C.MutInd (turi,typeno,exp_named_subst)) ->
- turi,typeno,exp_named_subst,[]
- | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::args)) ->
- turi,typeno,exp_named_subst,args
- | _ -> fail "not a discriminable equality"
- in
- let consno =
- match find_discriminating_consno t1 t2 with
- | Some consno -> consno
- | None -> fail "discriminating terms are structurally equal"
- in
- let branches,outtype =
- mk_branches_and_outtype turi typeno consno context args
- in
- PET.apply_tactic
- (T.then_
- ~start:(EliminationTactics.elim_type_tac (C.MutInd (false_URI, 0, [])))
- ~continuation:
- (T.then_
- ~start:
- (RT.change_tac
- ~pattern:(PET.conclusion_pattern None)
- (fun _ m u ->
- C.Appl [
- C.Lambda ( C.Name "x", tty,
- C.MutCase (turi, typeno, outtype, (C.Rel 1), branches));
- t2 ],
- m, u))
- ~continuation:
- (T.then_
- ~start:
- (ET.rewrite_simpl_tac
- ~direction:`RightToLeft
- ~pattern:(PET.conclusion_pattern None)
- term [])
- ~continuation:
- (IntroductionTactics.constructor_tac ~n:1)))) status
- | _ -> fail "not an equality"
- in
- PET.mk_tactic (discriminate'_tac ~term)
-
-let exn_noneq =
- PET.Fail (lazy "Injection: not an equality")
-let exn_nothingtodo =
- PET.Fail (lazy "Nothing to do")
-let exn_discrnonind =
- PET.Fail (lazy "Discriminate: object is not an Inductive Definition: it's imposible")
-let exn_injwronggoal =
- PET.Fail (lazy "Injection: goal after cut is not correct")
-let exn_noneqind =
- PET.Fail (lazy "Injection: not an equality over elements of an inductive type")
-
-let pp ctx t =
- let names = List.map (function Some (n,_) -> Some n | None -> None) ctx in
- CicPp.pp t names
-
-let clear_term first_time lterm =
- let clear_term status =
- let (proof, goal) = status in
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in
- debug_print (lazy ("\nclear di: " ^ pp context term));
- debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
- let g () = if first_time then raise exn_nothingtodo else T.id_tac in
- let tactic = match term with
- | C.Rel n ->
- begin match List.nth context (pred n) with
- | Some (C.Name id, _) ->
- T.if_ ~fail:(g ()) ~start:(PST.clear ~hyps:[id]) ~continuation:T.id_tac
- | _ -> assert false
- end
- | _ -> g ()
- in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic clear_term
-
-let exists context = function
- | C.Rel i -> List.nth context (pred i) <> None
- | _ -> true
-
-let recur_on_child_tac ~before ~after =
- let recur_on_child status =
- let (proof, goal) = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- debug_print (lazy ("\nrecur_on_child"));
- debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
- let mk_lterm term c m ug =
- let distance = List.length c - List.length context in
- S.lift distance term, m, ug
- in
- let lterm = mk_lterm (Cic.Rel 1) in
- let tactic = T.then_ ~start:before ~continuation:(after lterm) in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic recur_on_child
-
-let injection_tac ~lterm ~i ~continuation ~recur =
- let give_name seed = function
- | C.Name _ as name -> name
- | C.Anonymous -> C.Name (incr seed; "y" ^ string_of_int !seed)
- in
- let rec mk_rels = function | 0 -> [] | n -> C.Rel n :: (mk_rels (n - 1)) in
- let injection_tac status =
- let (proof, goal) = status in
- (* precondizione: t1 e t2 hanno in testa lo stesso costruttore ma
- * differiscono (o potrebbero differire?) nell'i-esimo parametro
- * del costruttore *)
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in
- let termty,_ =
- CTC.type_of_aux' metasenv context term CU.oblivion_ugraph
- in
- debug_print (lazy ("\ninjection su : " ^ pp context termty));
- match termty with (* an equality *)
- | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
- when LibraryObjects.is_eq_URI equri ->
- let turi,typeno,ens,params =
- match tty with (* some inductive type *)
- | C.MutInd (turi,typeno,ens) -> turi,typeno,ens,[]
- | C.Appl (C.MutInd (turi,typeno,ens)::params) -> turi,typeno,ens,params
- | _ -> raise exn_noneqind
- in
- let t1',t2',consno = (* sono i due sottotermini che differiscono *)
- match t1,t2 with
- | C.Appl ((C.MutConstruct (uri1,typeno1,consno1,ens1))::applist1),
- C.Appl ((C.MutConstruct (uri2,typeno2,consno2,ens2))::applist2)
- when (uri1 = uri2) && (typeno1 = typeno2) &&
- (consno1 = consno2) && (ens1 = ens2) ->
- (* controllo ridondante *)
- List.nth applist1 (pred i),List.nth applist2 (pred i),consno2
- | _ -> assert false
- in
- let tty',_ = CTC.type_of_aux' metasenv context t1' CU.oblivion_ugraph in
- let patterns,outtype =
- match fst (CicEnvironment.get_obj CU.oblivion_ugraph turi) with
- | C.InductiveDefinition (ind_type_list,_,paramsno,_)->
- let left_params, right_params = HExtlib.split_nth paramsno params in
- let _,_,_,constructor_list = List.nth ind_type_list typeno in
- let i_constr_id,_ = List.nth constructor_list (consno - 1) in
- let patterns =
- let seed = ref 0 in
- List.map
- (function (id,cty) ->
- let reduced_cty = CR.whd context cty in
- let rec aux k = function
- | C.Prod (_,_,tgt) when k <= paramsno ->
- let left = List.nth left_params (k-1) in
- aux (k+1) (S.subst left tgt)
- | C.Prod (binder,source,target) when k > paramsno ->
- let binder' = give_name seed binder in
- C.Lambda (binder',source,(aux (k+1) target))
- | _ ->
- let nr_param_constr = k - paramsno - 1 in
- if id = i_constr_id then C.Rel (k - i)
- else S.lift nr_param_constr t1'
- (* + 1 per liftare anche il lambda aggiunto
- * esternamente al case *)
- in S.lift 1 (aux 1 reduced_cty))
- constructor_list
- in
- (* this code should be taken from cases_tac *)
- let outtype =
- let seed = ref 0 in
- let rec to_lambdas te head =
- match CR.whd context te with
- | C.Prod (binder,so,ta) ->
- let binder' = give_name seed binder in
- C.Lambda (binder',so,to_lambdas ta head)
- | _ -> head
- in
- let rec skip_prods params te =
- match params, CR.whd context te with
- | [], _ -> te
- | left::tl, C.Prod (_,_,ta) ->
- skip_prods tl (S.subst left ta)
- | _, _ -> assert false
- in
- let abstracted_tty =
- let tty =
- List.fold_left (fun x y -> S.subst y x) tty left_params
- in
- (* non lift, ma subst coi left! *)
- match S.lift 1 tty with
- | C.MutInd _ as tty' -> tty'
- | C.Appl l ->
- let keep,abstract = HExtlib.split_nth (paramsno +1) l in
- let keep = List.map (S.lift paramsno) keep in
- C.Appl (keep@mk_rels (List.length abstract))
- | _ -> assert false
- in
- match ind_type_list with
- | [] -> assert false
- | (_,_,ty,_)::_ ->
- (* this is in general wrong, do as in cases_tac *)
- to_lambdas (skip_prods left_params ty)
- (C.Lambda
- (C.Name "cased", abstracted_tty,
- (* here we should capture right parameters *)
- (* 1 for his Lambda, one for the Lambda outside the match
- * and then one for each to_lambda *)
- S.lift (2+List.length right_params) tty'))
- in
- patterns,outtype
- | _ -> raise exn_discrnonind
- in
- let cutted = C.Appl [C.MutInd (equri,0,[]) ; tty' ; t1' ; t2'] in
- let changed =
- C.Appl [ C.Lambda (C.Name "x", tty,
- C.MutCase (turi,typeno,outtype,C.Rel 1,patterns)) ; t1]
- in
- (* check if cutted and changed are well typed and if t1' ~ changed *)
- let go_on =
- try
- let _,g = CTC.type_of_aux' metasenv context cutted
- CU.oblivion_ugraph
- in
- let _,g = CTC.type_of_aux' metasenv context changed g in
- fst (CR.are_convertible ~metasenv context t1' changed g)
- with
- | CTC.TypeCheckerFailure _ -> false
- in
- if not go_on then begin
- HLog.warn "destruct: injection failed";
- PET.apply_tactic continuation status
- end else
- let fill_cut_tac term =
- let fill_cut status =
- debug_print (lazy "riempio il cut");
- let (proof, goal) = status in
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,gty = CicUtil.lookup_meta goal metasenv in
- let gty = Unshare.unshare gty in
- let new_t1' = match gty with
- | (C.Appl (C.MutInd (_,_,_)::_::t::_)) -> t
- | _ -> raise exn_injwronggoal
- in
- debug_print (lazy ("metto: " ^ pp context changed));
- debug_print (lazy ("al posto di: " ^ pp context new_t1'));
- debug_print (lazy ("nel goal: " ^ pp context gty));
- debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
- debug_print (lazy ("e poi rewrite con: "^pp context term));
- let tac = T.seq ~tactics:[
- RT.change_tac
- ~pattern:(None, [], Some (PEH.pattern_of ~term:gty [new_t1']))
- (fun _ m u -> changed,m,u);
- ET.rewrite_simpl_tac
- ~direction:`LeftToRight
- ~pattern:(PET.conclusion_pattern None)
- term [];
- ET.reflexivity_tac
- ] in
- PET.apply_tactic tac status
- in
- PET.mk_tactic fill_cut
- in
- debug_print (lazy ("CUT: " ^ pp context cutted));
- let tactic =
- T.thens ~start: (P.cut_tac cutted)
- ~continuations:[
- recur_on_child_tac continuation recur;
- fill_cut_tac term
- ]
- in
- PET.apply_tactic tactic status
- | _ -> raise exn_noneq
- in
- PET.mk_tactic injection_tac
-
-let subst_tac ~lterm ~direction ~where ~continuation ~recur =
- let subst_tac status =
- let (proof, goal) = status in
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in
- debug_print (lazy ("\nsubst " ^ (match direction with `LeftToRight -> "->" | `RightToLeft -> "<-") ^ " di: " ^ pp context term));
- let tactic = match where with
- | None ->
- debug_print (lazy ("nella conclusione"));
- let pattern = PET.conclusion_pattern None in
- let tactic = ET.rewrite_tac ~direction ~pattern term [] in
- T.then_ ~start:(T.try_tactic ~tactic) ~continuation
- | Some name ->
- debug_print (lazy ("nella premessa: " ^ name));
- let pattern = None, [name, PET.hole], None in
- let start = ET.rewrite_tac ~direction ~pattern term [] in
- let ok_tactic = recur_on_child_tac continuation recur in
- T.if_ ~start ~continuation:ok_tactic ~fail:continuation
- in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic subst_tac
-
-let rec destruct ~first_time lterm =
- let are_convertible hd1 hd2 metasenv context =
- fst (CR.are_convertible ~metasenv context hd1 hd2 CU.oblivion_ugraph)
- in
- let recur = destruct ~first_time:false in
- let destruct status =
- let (proof, goal) = status in
- let _,metasenv,_subst, _,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in
- let tactic = if not (first_time || exists context term) then T.id_tac else begin
- debug_print (lazy ("\ndestruct di: " ^ pp context term));
- debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
- let termty,_ = CTC.type_of_aux' metasenv context term CU.oblivion_ugraph in
- debug_print (lazy ("\ndestruct su: " ^ pp context termty));
- let mk_lterm term c m ug =
- let distance = List.length c - List.length context in
- S.lift distance term, m, ug
- in
- let lterm = mk_lterm term in
- let mk_subst_chain direction index with_what what =
- let k = match term with C.Rel i -> i | _ -> -1 in
- let rec traverse_context first_time j = function
- | [] ->
- let continuation =
- T.seq ~tactics:[
- clear_term first_time lterm;
- clear_term false (mk_lterm what);
- clear_term false (mk_lterm with_what)
- ]
- in
- subst_tac ~direction ~lterm ~where:None ~continuation ~recur
- | Some (C.Name name, _) :: tl when j < index && j <> k ->
- debug_print (lazy ("\nsubst programmata: cosa: " ^ string_of_int index ^ ", dove: " ^ string_of_int j));
- subst_tac ~direction ~lterm ~where:(Some name) ~recur
- ~continuation:(traverse_context false (succ j) tl)
- | _ :: tl -> traverse_context first_time (succ j) tl
- in
- traverse_context first_time 1 context
- in
- match termty with
- | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
- when LibraryObjects.is_eq_URI equri ->
- begin match t1,t2 with
-(* injection part *)
- | C.MutConstruct _,
- C.MutConstruct _
- when t1 = t2 -> clear_term first_time lterm
- | C.Appl (C.MutConstruct _ as mc1 :: applist1),
- C.Appl (C.MutConstruct _ as mc2 :: applist2)
- when mc1 = mc2 ->
- let rec traverse_list first_time i l1 l2 =
- match l1, l2 with
- | [], [] -> clear_term first_time lterm
- | hd1 :: tl1, hd2 :: tl2 ->
- if are_convertible hd1 hd2 metasenv context then
- traverse_list first_time (succ i) tl1 tl2
- else
- injection_tac ~i ~lterm ~recur ~continuation:
- (traverse_list false (succ i) tl1 tl2)
- | _ -> assert false
- (* i 2 termini hanno in testa lo stesso costruttore,
- * ma applicato a un numero diverso di termini *)
- in
- traverse_list first_time 1 applist1 applist2
-(* discriminate part *)
- | C.MutConstruct (_,_,consno1,ens1),
- C.MutConstruct (_,_,consno2,ens2)
- | C.MutConstruct (_,_,consno1,ens1),
- C.Appl ((C.MutConstruct (_,_,consno2,ens2))::_)
- | C.Appl ((C.MutConstruct (_,_,consno1,ens1))::_),
- C.MutConstruct (_,_,consno2,ens2)
- | C.Appl ((C.MutConstruct (_,_,consno1,ens1))::_),
- C.Appl ((C.MutConstruct (_,_,consno2,ens2))::_)
- when (consno1 <> consno2) || (ens1 <> ens2) ->
- discriminate_tac ~term
-(* subst part *)
- | C.Rel _, C.Rel _ when t1 = t2 ->
- T.seq ~tactics:[
- clear_term first_time lterm;
- clear_term false (mk_lterm t1)
- ]
- | C.Rel i1, C.Rel i2 when i1 < i2 ->
- mk_subst_chain `LeftToRight i1 t2 t1
- | C.Rel i1, C.Rel i2 when i1 > i2 ->
- mk_subst_chain `RightToLeft i2 t1 t2
- | C.Rel i1, _ when DTI.does_not_occur i1 t2 ->
- mk_subst_chain `LeftToRight i1 t2 t1
- | _, C.Rel i2 when DTI.does_not_occur i2 t1 ->
- mk_subst_chain `RightToLeft i2 t1 t2
-(* else part *)
- | _ when first_time -> raise exn_nothingtodo
- | _ (* when not first time *) -> T.id_tac
- end
- | _ when first_time -> raise exn_nothingtodo
- | _ (* when not first time *) -> T.id_tac
- end in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic destruct
-
-(* destruct performs either injection or discriminate or subst *)
-let destruct_tac xterms =
- let destruct status =
- let (proof, goal) = status in
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let mk_lterm term c m ug =
- let distance = List.length c - List.length context in
- S.lift distance term, m, ug
- in
- let tactics = match xterms with
- | Some terms ->
- let map term = destruct ~first_time:false (mk_lterm term) in
- List.map map terms
- | None ->
- let rec mk_tactics first_time i tacs = function
- | [] -> List.rev tacs
- | Some _ :: tl ->
- let lterm = mk_lterm (C.Rel i) in
- let tacs = destruct ~first_time lterm :: tacs in
- mk_tactics false (succ i) tacs tl
- | _ :: tl -> mk_tactics first_time (succ i) tacs tl
- in
- mk_tactics false 1 [] context
- in
- PET.apply_tactic (T.seq ~tactics) status
- in
- PET.mk_tactic destruct
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* Performs a recursive comparisons of the two sides of an equation
- looking for constructors. If the two sides differ on two constructors,
- it closes the current goal. If they differ by other two terms it introduces
- an equality. *)
-val destruct_tac: Cic.term list option -> ProofEngineTypes.tactic
+++ /dev/null
-
-#
-# Generic makefile for latex
-#
-# Author: Stefano Zacchiroli <zack@bononia.it>
-#
-# Created: Sun, 29 Jun 2003 12:00:55 +0200 zack
-# Last-Modified: Mon, 10 Oct 2005 15:37:12 +0200 zack
-#
-
-########################################################################
-
-# list of .tex _main_ files
-TEXS = main.tex
-
-# number of runs of latex (for table of contents, list of figures, ...)
-RUNS = 1
-
-# do you need bibtex?
-BIBTEX = no
-
-# would you like to use pdflatex?
-PDF_VIA_PDFLATEX = yes
-
-# which formats generated by default ("all" target)?
-# (others will be generated by "world" target)
-# see AVAILABLE_FORMATS below
-BUILD_FORMATS = dvi
-
-# which format to be shown on "make show"
-SHOW_FORMAT = dvi
-
-########################################################################
-
-AVAILABLE_FORMATS = dvi ps ps.gz pdf html
-
-ADVI = advi
-BIBTEX = bibtex
-BROWSER = galeon
-DVIPDF = dvipdf
-DVIPS = dvips
-GV = gv
-GZIP = gzip
-HEVEA = hevea
-ISPELL = ispell
-LATEX = latex
-PDFLATEX = pdflatex
-PRINT = lpr
-XDVI = xdvi
-XPDF = xpdf
-
-ALL_FORMATS = $(BUILD_FORMATS)
-WORLD_FORMATS = $(AVAILABLE_FORMATS)
-
-all: $(ALL_FORMATS)
-world: $(WORLD_FORMATS)
-
-DVIS = $(TEXS:.tex=.dvi)
-PSS = $(TEXS:.tex=.ps)
-PSGZS = $(TEXS:.tex=.ps.gz)
-PDFS = $(TEXS:.tex=.pdf)
-HTMLS = $(TEXS:.tex=.html)
-
-dvi: $(DVIS)
-ps: $(PSS)
-ps.gz: $(PSGZS)
-pdf: $(PDFS)
-html: $(HTMLS)
-
-show: show$(SHOW_FORMAT)
-showdvi: $(DVIS)
- $(XDVI) $<
-showps: $(PSS)
- $(GV) $<
-showpdf: $(PDFS)
- $(XPDF) $<
-showpsgz: $(PSGZS)
- $(GV) $<
-showps.gz: showpsgz
-showhtml: $(HTMLS)
- $(BROWSER) $<
-
-print: $(PSS)
- $(PRINT) $^
-
-clean:
- rm -f \
- $(TEXS:.tex=.dvi) $(TEXS:.tex=.ps) $(TEXS:.tex=.ps.gz) \
- $(TEXS:.tex=.pdf) $(TEXS:.tex=.aux) $(TEXS:.tex=.log) \
- $(TEXS:.tex=.html) $(TEXS:.tex=.out) $(TEXS:.tex=.haux) \
- $(TEXS:.tex=.htoc) $(TEXS:.tex=.tmp)
-
-%.dvi: %.tex
- $(LATEX) $<
- if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi
- if [ "$(RUNS)" -gt 1 ]; then \
- for i in seq 1 `expr $(RUNS) - 1`; do \
- $(LATEX) $<; \
- done; \
- fi
-ifeq ($(PDF_VIA_PDFLATEX),yes)
-%.pdf: %.tex
- $(PDFLATEX) $<
- if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi
- if [ "$(RUNS)" -gt 1 ]; then \
- for i in seq 1 `expr $(RUNS) - 1`; do \
- $(PDFLATEX) $<; \
- done; \
- fi
-else
-%.pdf: %.dvi
- $(DVIPDF) $< $@
-endif
-%.ps: %.dvi
- $(DVIPS) $<
-%.ps.gz: %.ps
- $(GZIP) -c $< > $@
-%.html: %.tex
- $(HEVEA) -fix $<
-
-.PHONY: all ps pdf html clean
-
-########################################################################
-
+++ /dev/null
-
-\section{Tinycals: \MATITA{} tacticals}
-
-\subsection{Introduction}
-
-% outline:
-% - script
-
-Most of modern mainstream proof assistants enable input of proofs of
-propositions using a textual language. Compilation units written in such
-languages are sequence of textual \emph{statements} and are usually called
-\emph{scripts} as a whole. Scripts are so entangled with proof assistants that
-they drived the design of state of the art of their Graphical User Interfaces
-(GUIs). Fig.~\ref{fig:proofgeneral} is a screenshot of Proof General, a generic
-proof assistant interface based on Emacs widely used and compatible with systems
-like Coq, Isabelle, PhoX, LEGO, and many more. Other system specific GUIs exist
-but share the same design, understanding it and they way such GUIs are operated
-is relevant to our discussion.
-
-%\begin{figure}[ht]
-% \begin{center}
-% \includegraphic{pics/pg-coq-screenshot}
-% \caption{Proof General: a generic interface for proof assistants}
-% \label{fig:proofgeneral}
-% \end{center}
-%\end{figure}
-
-% - modo di lavorare
-
-The paradigm behind such GUIs is quite simple. The window on the left is an
-editable text area containing the script and split in two by an \emph{execution
-point} (the point where background color changes). The part starting at the
-beginning of the script and ending at the marker (distinguishable for having a
-light blue background in the picture) contains the sequence of statements which
-have already been fed into the system. We will call this former part
-\emph{locked area} since the user is not free to change it as her willing. The
-remaining part, which extends until the end of the script, is named
-\emph{scratch area} and can be freely modified. The window on the right is
-read-only for the user and includes at the top the current proof status, when
-some proof is ongoing, and at the bottom a message area used for error messages
-or other feedback from the system to the user. The user usually proceed
-alternating editing of the scratch area and execution point movements (forward
-to evaluate statements and backward to retract statements if she need to change
-something in the locked area).
-
-Execution point movements are not free, but constrained by the structure of the
-script language used. The granularity is that of statements. In systems like Coq
-or \MATITA{} examples of statements are: inductive definitions, theorems, and
-tactics. \emph{Tactics} are the building blocks of proofs. For example, the
-following script snippet contains a theorem about a relationship of natural
-minus with natural plus, along with its proof (line numbers have been added for
-the sake of presentation) as it can be found in the standard library of the
-\MATITA{} proof assistant:
-
-%\begin{example}
-%\begin{Verbatim}
-%theorem eq_minus_minus_minus_plus: \forall n,m,p:nat. (n-m)-p = n-(m+p).
-% intros.
-% cut (m+p \le n \or m+p \nleq n).
-% elim Hcut.
-% symmetry.
-% apply plus_to_minus.
-% rewrite > assoc_plus.
-% rewrite > (sym_plus p).
-% rewrite < plus_minus_m_m.
-% rewrite > sym_plus.
-% rewrite < plus_minus_m_m.
-% reflexivity.
-% apply (trans_le ? (m+p)).
-% rewrite < sym_plus.
-% apply le_plus_n.
-% assumption.
-% apply le_plus_to_minus_r.
-% rewrite > sym_plus.
-% assumption.
-% rewrite > (eq_minus_n_m_O n (m+p)).
-% rewrite > (eq_minus_n_m_O (n-m) p).
-% reflexivity.
-% apply le_plus_to_minus.
-% apply lt_to_le.
-% rewrite < sym_plus.
-% apply not_le_to_lt.
-% assumption.
-% apply lt_to_le.
-% apply not_le_to_lt.
-% assumption.
-% apply (decidable_le (m+p) n).
-%qed.
-%\end{Verbatim}
-%\end{example}
-
-The script snippet is made of 32 statements, one per line (but this is not a
-requirement of the \MATITA{} script language, namely \emph{Grafite}). The first
-statement is the assertion that the user want to prove a proposition with a
-given type, specified after the ``\texttt{:}'', its execution will cause
-\MATITA{} to enter the proof state showing to the user the list of goals that
-still need to be proved to conclude the proof. The last statement (\texttt{Qed})
-is an assertion that the proof is completed. All intertwining statements are
-tactic applications.
-
-Given the constraint we mentioned about execution point, while inserting (or
-replaying) the above script, the user may position it at the end of any line,
-having feedback about the status of the proof in that point. See for example
-Fig.~\ref{fig:matita} where an intermediate proof status is shown.
-
-%\begin{figure}[ht]
-% \begin{center}
-% \includegraphic{matita_screenshot}
-% \caption{Matita: ongoing proof}
-% \label{fig:matita}
-% \end{center}
-%\end{figure}
-
-% - script: sorgenti di un linguaggio imperativo, oggetti la loro semantica
-% - script = sequenza di comandi
-
-You can create an analogy among scripts and sources written in an imperative
-programming language, seeing proofs as the denotational semantics of that
-language. In such analogy the language used in the script of
-Fig.~\ref{fig:matita} is rather poor offering as the only programming construct
-the sequential composition of tactic application. What enables step by step
-execution is the operational semantics of each tactic application (i.e. how it
-changes the current proof status).
-
-% - pro: concisi
-
-This kind of scripts have both advantages and drawbacks. Among advantages we can
-for sure list the effectiveness of the language. In spite of being longer than
-the corresponding informal text version of the proof (a gap hardly fillable with
-proof assistants~\cite{debrujinfactor}), the script is fast to write in
-interactive use, enable cut and paste approaches, and gives a lot of flexibility
-(once the syntax is known of course) in tactic application via additional flags
-that can be easily passed to them.
-
-% - cons: non strutturati, hanno senso solo via reply
-
-Unfortunately, drawbacks are non negligible. Scripts like those of
-Fig.~\ref{fig:matita} are completely unstructured and hardly can be assigned a
-meaning simply looking at them. Even experienced users, that knows the details
-of all involved tactics, can hardly figure what a script mean without replaying
-the proof in their heads. This indeed is a key aspect of scripts: they are
-meaningful via \emph{reply}. People interested in understanding a formal proof
-written as a script usually start the preferred tool and execute it step by
-step. A contrasting approach compared to what happens with high level
-programming languages where looking at the code is usually enough to understand
-its details.
-
-% - cons: poco robusti (wrt cambiamenti nelle tattiche, nello statement, ...)
-
-Additionally, scripts are usually not robust against changes, intending with
-that term both changes in the statement that need to be proved (e.g.
-strenghtening of an inductive hypothesis) and changes in the implementation of
-involved tactics. This drawback can force backward compatibility and slow down
-systems development. A real-life example in the history of \MATITA{} was the
-reordering of goals after tactic application; the total time needed to port the
-(tiny at the time) standard library of no more that 30 scripts was 2 days work.
-Having the scripts being structured the task could have been done in much less
-time and even automated.
-
-Tacticals are an attempt at solving this drawbacks.
-
-\subsection{Tacticals}
-
-% - script = sequenza di comandi + tatticali
-
-\ldots descrizione dei tatticali \ldots
-
-% - pro: fattorizzazione
-
-Tacticals as described above have several advantages with respect to plain
-sequential application of tactics. First of all they enable a great amount of
-factorization of proofs using the sequential composition ``;'' operator. Think
-for example at proofs by induction on inductive types with several constructors,
-which are so frequent when formalizing properties from the computer science
-field. It is often the case that several, or even all, cases can be dealt with
-uniform strategies, which can in turn by coded in a single script snipped which
-can appear only once, at the right hand side of a ``;''.
-
-% - pro: robustezza
-
-Scripts properly written using the tacticals above are even more robust with
-respect to changes. The additional amount of flexibility is given by
-``conditional'' constructs like \texttt{try}, \texttt{solve}, and
-\texttt{first}. Using them the scripts no longer contain a single way of
-proceeding from one status of the proof to another, they can list more. The wise
-proof coder may exploit this mechanism providing fallbacks in order to be more
-robust to future changes in tactics implementation. Of course she is not
-required to!
-
-% - pro: strutturazione delle prove (via branching)
-
-Finally, the branching constructs \texttt{[}, \texttt{|}, and \texttt{]} enable
-proof structuring. Consider for example an alternative, branching based, version
-of the example above:
-
-%\begin{example}
-%\begin{Verbatim}
-%...
-%\end{Verbatim}
-%\end{example}
-
-Tactic applications are the same of the previous version of the script, but
-branching tacticals are used. The above version is highly more readable and
-without executing it key points of the proofs like induction cases can be
-observed.
-
-% - tradeoff: utilizzo dei tatticali vs granularita' dell'esecuzione
-% (impossibile eseguire passo passo)
-
-One can now wonder why thus all scripts are not written in a robust, concise and
-structured fashion. The reason is the existence of an unfortunate tradeoff
-between the need of using tacticals and the impossibility of executing step by
-step \emph{inside} them. Indeed, trying to mimic the structured version of the
-proof above in GUIs like Proof General or CoqIDE will result in a single macro
-step that will bring you from the beginning of the proof directly at the end of
-it!
-
-Tinycals as implemented in \MATITA{} are a solution to this problem, preserving
-the usual tacticals semantics, giving meaning to intermediate execution point
-inside complex tacticals.
-
-\subsection{Tinycals}
-
-\subsection{Tinycals semantics}
-
-\subsubsection{Language}
-
-\[
-\begin{array}{rcll}
- S & ::= & & \mbox{(\textbf{continuationals})}\\
- & & \TACTIC{T} & \mbox{(tactic)}\\[2ex]
- & | & \DOT & \mbox{(dot)} \\
- & | & \SEMICOLON & \mbox{(semicolon)} \\
- & | & \BRANCH & \mbox{(branch)} \\
- & | & \SHIFT & \mbox{(shift)} \\
- & | & \POS{i} & \mbox{(relative positioning)} \\
- & | & \MERGE & \mbox{(merge)} \\[2ex]
- & | & \FOCUS{g_1,\dots,g_n} & \mbox{(absolute positioning)} \\
- & | & \UNFOCUS & \mbox{(unfocus)} \\[2ex]
- & | & S ~ S & \mbox{(sequential composition)} \\[2ex]
- T & : := & & \mbox{(\textbf{tactics})}\\
- & & \SKIP & \mbox{(skip)} \\
- & | & \mathtt{reflexivity} & \\
- & | & \mathtt{apply}~t & \\
- & | & \dots &
-\end{array}
-\]
-
-\subsubsection{Status}
-
-\[
-\begin{array}{rcll}
- \xi & & & \mbox{(proof status)} \\
- \mathit{goal} & & & \mbox{(proof goal)} \\[2ex]
-
- \SWITCH & = & \OPEN~\mathit{goal} ~ | ~ \CLOSED~\mathit{goal} & \\
- \mathit{locator} & = & \INT\times\SWITCH & \\
- \mathit{tag} & = & \BRANCHTAG ~ | ~ \FOCUSTAG \\[2ex]
-
- \Gamma & = & \mathit{locator}~\LIST & \mbox{(context)} \\
- \tau & = & \mathit{locator}~\LIST & \mbox{(todo)} \\
- \kappa & = & \mathit{locator}~\LIST & \mbox{(dot's future)} \\[2ex]
-
- \mathit{stack} & = & (\Gamma\times\tau\times\kappa\times\mathit{tag})~\LIST
- \\[2ex]
-
- \mathit{status} & = & \xi\times\mathit{stack} \\
-\end{array}
-\]
-
-\paragraph{Utilities}
-\begin{itemize}
- \item $\ZEROPOS([g_1;\cdots;g_n]) =
- [\langle 0,\OPEN~g_1\rangle;\cdots;\langle 0,\OPEN~g_n\rangle]$
- \item $\INITPOS([\langle i_1,s_1\rangle;\cdots;\langle i_n,s_n\rangle]) =
- [\langle 1,s_1\rangle;\cdots;\langle n,s_n\rangle]$
- \item $\ISFRESH(s) =
- \left\{
- \begin{array}{ll}
- \mathit{true} & \mathrm{if} ~ s = \langle n, \OPEN~g\rangle\land n > 0 \\
- \mathit{false} & \mathrm{otherwise} \\
- \end{array}
- \right.$
- \item $\FILTEROPEN(\mathit{locs})=
- \left\{
- \begin{array}{ll}
- [] & \mathrm{if}~\mathit{locs} = [] \\
- \langle i,\OPEN~g\rangle :: \FILTEROPEN(\mathit{tl})
- & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} \\
- \FILTEROPEN(\mathit{tl})
- & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\
- \end{array}
- \right.$
- \item $\REMOVEGOALS(G,\mathit{locs}) =
- \left\{
- \begin{array}{ll}
- [] & \mathrm{if}~\mathit{locs} = [] \\
- \REMOVEGOALS(G,\mathit{tl})
- & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl}
- \land g\in G\\
- hd :: \REMOVEGOALS(G,\mathit{tl})
- & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\
- \end{array}
- \right.$
- \item $\DEEPCLOSE(G,S)$: (intuition) given a set of goals $G$ and a stack $S$
- it returns a new stack $S'$ identical to the given one with the exceptions
- that each locator whose goal is in $G$ is marked as closed in $\Gamma$ stack
- components and removed from $\tau$ and $\kappa$ components.
- \item $\GOALS(S)$: (inutition) return all goals appearing in whatever position
- on a given stack $S$, appearing in an \OPEN{} switch.
-\end{itemize}
-
-\paragraph{Invariants}
-\begin{itemize}
- \item $\forall~\mathrm{entry}~\ENTRY{\Gamma}{\tau}{\kappa}{t}, \forall s
- \in\tau\cup\kappa, \exists g, s = \OPEN~g$ (each locator on the stack in
- $\tau$ and $\kappa$ components has an \OPEN~switch).
- \item Unless \FOCUS{} is used the stack contains no duplicate goals.
- \item $\forall~\mathrm{locator}~l\in\Gamma \mbox{(with the exception of the
- top-level $\Gamma$)}, \ISFRESH(l)$.
-\end{itemize}
-
-\subsubsection{Semantics}
-
-\[
-\begin{array}{rcll}
- \SEMOP{\cdot} & : & C -> \mathit{status} -> \mathit{status} &
- \mbox{(continuationals semantics)} \\
- \TSEMOP{\cdot} & : & T -> \xi -> \SWITCH ->
- \xi\times\GOAL~\LIST\times\GOAL~\LIST & \mbox{(tactics semantics)} \\
-\end{array}
-\]
-
-\[
-\begin{array}{rcl}
- \mathit{apply\_tac} & : & T -> \xi -> \GOAL ->
- \xi\times\GOAL~\LIST\times\GOAL~\LIST
-\end{array}
-\]
-
-\[
-\begin{array}{rlcc}
- \TSEM{T}{\xi}{\OPEN~g} & = & \mathit{apply\_tac}(T,\xi,n) & T\neq\SKIP\\
- \TSEM{\SKIP}{\xi}{\CLOSED~g} & = & \langle \xi, [], [g]\rangle &
-\end{array}
-\]
-
-\[
-\begin{array}{rcl}
-
- \SEM{\TACTIC{T}}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S}
- & =
- & \langle
- \xi_n,
- \ENTRY{\Gamma'}{\tau'}{\kappa'}{t}
-% \ENTRY{\ZEROPOS(G^o_n)}{\tau\setminus G^c_n}{\kappa\setminus G^o_n}{t}
- :: \DEEPCLOSE(G^c_n,S)
- \rangle
- \\[1ex]
- \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{where} ~ n\geq 1}
- \\[1ex]
- \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~
- \Gamma' = \ZEROPOS(G^o_n)
- \land \tau' = \REMOVEGOALS(G^c_n,\tau)
- \land \kappa' = \REMOVEGOALS(G^o_n,\kappa)
- }
- \\[1ex]
- \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~
- \left\{
- \begin{array}{rcll}
- \langle\xi_0, G^o_0, G^c_0\rangle & = & \langle\xi, [], []\rangle \\
- \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle
- & =
- & \langle\xi_i, G^o_i, G^c_i\rangle
- & l_{i+1}\in G^c_i \\
- \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle
- & =
- & \langle\xi, (G^o_i\setminus G^c)\cup G^o, G^c_i\cup G^c\rangle
- & l_{i+1}\not\in G^c_i \\[1ex]
- & & \mathit{where} ~ \langle\xi,G^o,G^c\rangle=\TSEM{T}{\xi_i}{l_{i+1}} \\
- \end{array}
- \right.
- }
- \\[6ex]
-
- \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{\kappa}{t}::S}
- & =
- & \langle \xi, \ENTRY{l_1}{\tau}{\GIN[2]\cup\kappa}{t}::S \rangle
- \\[1ex]
- & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=\GIN \land n\geq 1
- \\[2ex]
-
- \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{l::\kappa}{t}::S}
- & =
- & \langle \xi, \ENTRY{[l]}{\tau}{\kappa}{t}::S \rangle
- \\[1ex]
- & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=[]
- \\[2ex]
-
- \SEM{~\SEMICOLON~}{S} & = & \langle \xi, S \rangle \\[1ex]
-
- \SEM{~\BRANCH~}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S}
- \quad
- & =
- & \langle\xi, \ENTRY{[l_1']}{[]}{[]}{\BRANCHTAG}
- ::\ENTRY{[l_2';\cdots;l_n']}{\tau}{\kappa}{t}::S
- \\[1ex]
- & & \mathrm{where} ~ n\geq 2 ~ \land ~ \INITPOS(\GIN)=[l_1';\cdots;l_n']
- \\[2ex]
-
- \SEM{~\SHIFT~}
- {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\GIN}{\tau'}{\kappa'}{t'}
- ::S}
- & =
- & \langle
- \xi, \ENTRY{[l_1]}{\tau\cup\FILTEROPEN(\Gamma)}{[]}{\BRANCHTAG}
- ::\ENTRY{\GIN[2]}{\tau'}{\kappa'}{t'}::S
- \rangle
- \\[1ex]
- & & \mathrm{where} ~ n\geq 1
- \\[2ex]
-
- \SEM{~\POS{i}~}
- {\ENTRY{[l]}{[]}{[]}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S}
- & =
- & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG}
- ::\ENTRY{l :: (\Gamma'\setminus [l_i])}{\tau'}{\kappa'}{t'}::S \rangle
- \\[1ex]
- & & \mathrm{where} ~ \langle i,l'\rangle = l_i\in \Gamma'~\land~\ISFRESH(l)
- \\[2ex]
-
- \SEM{~\POS{i}~}
- {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}
- ::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S}
- & =
- & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG}
- ::\ENTRY{\Gamma'\setminus [l_i]}{\tau'\cup\FILTEROPEN(\Gamma)}{\kappa'}{t'}::S
- \rangle
- \\[1ex]
- & & \mathrm{where} ~ \langle i, l'\rangle = l_i\in \Gamma'
- \\[2ex]
-
- \SEM{~\MERGE~}
- {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}
- ::S}
- & =
- & \langle \xi,
- \ENTRY{\tau\cup\FILTEROPEN(\Gamma)\cup\Gamma'\cup\kappa}{\tau'}{\kappa'}{t'}
- :: S
- \rangle
- \\[2ex]
-
- \SEM{\FOCUS{g_1,\dots,g_n}}{S}
- & =
- & \langle \xi, \ENTRY{\ZEROPOS([g_1;\cdots;g_n])}{[]}{[]}{\FOCUSTAG}
- ::\DEEPCLOSE(S)
- \rangle
- \\[1ex]
- & & \mathrm{where} ~
- \forall i=1,\dots,n,~g_i\in\GOALS(S)
- \\[2ex]
-
- \SEM{\UNFOCUS}{\ENTRY{[]}{[]}{[]}{\FOCUSTAG}::S}
- & =
- & \langle \xi, S\rangle \\[2ex]
-
-\end{array}
-\]
-
-\subsection{Related works}
-
-In~\cite{fk:strata2003}, Kirchner described a small step semantics for Coq
-tacticals and PVS strategies.
-
+++ /dev/null
-%%
-%% This is file `infernce.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,inference')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from infernce.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\@@tempa,\@@tempb,\@adjustPremises,\@inference}
-\TestForConflict{\@inferenceBack,\@inferenceFront,\@inferenceOrPremis}
-\TestForConflict{\@premises,\@processInference,\@processPremiseLine}
-\TestForConflict{\@setLengths,\inference,\predicate,\predicatebegin}
-\TestForConflict{\predicateend,\setnamespace,\setpremisesend}
-\TestForConflict{\setpremisesspace,\@makeLength,\@@space}
-\TestForConflict{\@@aLineBox,\if@@shortDivider}
-\newtoks\@@tempa
-\newtoks\@@tempb
-\newcommand{\@makeLength}[4]{
- \@@tempa=\expandafter{\csname @@#2\endcsname}
- \@@tempb=\expandafter{\csname @set#2\endcsname} %
- \expandafter \newlength \the\@@tempa
- \expandafter \newcommand \the\@@tempb {}
- \expandafter \newcommand \csname set#1\endcsname[1]{}
- \expandafter \xdef \csname set#1\endcsname##1%
- {{\dimen0=##1}%
- \noexpand\renewcommand{\the\@@tempb}{%
- \noexpand\setlength{\the \@@tempa}{##1 #4}}%
- }%
- \csname set#1\endcsname{#3}
- \@@tempa=\expandafter{\@setLengths} %
- \edef\@setLengths{\the\@@tempa \the\@@tempb} %
- }
-
-\newcommand{\@setLengths}{%
- \setlength{\baselineskip}{1.166em}%
- \setlength{\lineskip}{1pt}%
- \setlength{\lineskiplimit}{1pt}}
-\@makeLength{premisesspace}{pSpace}{1.5em}{plus 1fil}
-\@makeLength{premisesend}{pEnd}{.75em}{plus 0.5fil}
-\@makeLength{namespace}{nSpace}{.5em}{}
-\newbox\@@aLineBox
-\newif\if@@shortDivider
-\newcommand{\@@space}{ }
-\newcommand{\predicate}[1]{\predicatebegin #1\predicateend}
-\newcommand{\predicatebegin}{$}
-\newcommand{\predicateend}{$}
-\def\inference{%
- \@@shortDividerfalse
- \expandafter\hbox\bgroup
- \@ifstar{\@@shortDividertrue\@inferenceFront}%
- \@inferenceFront
-}
-\def\@inferenceFront{%
- \@ifnextchar[%
- {\@inferenceFrontName}%
- {\@inferenceMiddle}%
-}
-\def\@inferenceFrontName[#1]{%
- \setbox3=\hbox{\footnotesize #1}%
- \ifdim \wd3 > \z@
- \unhbox3%
- \hskip\@@nSpace
- \fi
- \@inferenceMiddle
-}
-\long\def\@inferenceMiddle#1{%
- \@setLengths%
- \setbox\@@pBox=
- \vbox{%
- \@premises{#1}%
- \unvbox\@@pBox
- }%
- \@inferenceBack
-}
-\long\def\@inferenceBack#1{%
- \setbox\@@cBox=%
- \hbox{\hskip\@@pEnd \predicate{\ignorespaces#1}\unskip\hskip\@@pEnd}%
- \setbox1=\hbox{$ $}%
- \setbox\@@pBox=\vtop{\unvbox\@@pBox
- \vskip 4\fontdimen8\textfont3}%
- \setbox\@@cBox=\vbox{\vskip 4\fontdimen8\textfont3%
- \box\@@cBox}%
- \if@@shortDivider
- \ifdim\wd\@@pBox >\wd\@@cBox%
- \dimen1=\wd\@@pBox%
- \else%
- \dimen1=\wd\@@cBox%
- \fi%
- \dimen0=\wd\@@cBox%
- \hbox to \dimen1{%
- \hss
- $\frac{\hbox to \dimen0{\hss\box\@@pBox\hss}}%
- {\box\@@cBox}$%
- \hss
- }%
- \else
- $\frac{\box\@@pBox}%
- {\box\@@cBox}$%
- \fi
- \@ifnextchar[%
- {\@inferenceBackName}%{}%
- {\egroup}
-}
-\def\@inferenceBackName[#1]{%
- \setbox3=\hbox{\footnotesize #1}%
- \ifdim \wd3 > \z@
- \hskip\@@nSpace
- \unhbox3%
- \fi
- \egroup
-}
-\newcommand{\@premises}[1]{%
- \setbox\@@pBox=\vbox{}%
- \dimen\@@maxwidth=\wd\@@cBox%
- \@processPremises #1\\\end%
- \@adjustPremises%
-}
-\newcommand{\@adjustPremises}{%
- \setbox\@@pBox=\vbox{%
- \@@moreLinestrue %
- \loop %
- \setbox\@@pBox=\vbox{%
- \unvbox\@@pBox %
- \global\setbox\@@aLineBox=\lastbox %
- }%
- \ifvoid\@@aLineBox %
- \@@moreLinesfalse %
- \else %
- \hbox to \dimen\@@maxwidth{\unhbox\@@aLineBox}%
- \fi %
- \if@@moreLines\repeat%
- }%
-}
-\def\@processPremises#1\\#2\end{%
- \setbox\@@pLineBox=\hbox{}%
- \@processPremiseLine #1&\end%
- \setbox\@@pLineBox=\hbox{\unhbox\@@pLineBox \unskip}%
- \ifdim \wd\@@pLineBox > \z@ %
- \setbox\@@pLineBox=%
- \hbox{\hskip\@@pEnd \unhbox\@@pLineBox \hskip\@@pEnd}%
- \ifdim \wd\@@pLineBox > \dimen\@@maxwidth %
- \dimen\@@maxwidth=\wd\@@pLineBox %
- \fi %
- \setbox\@@pBox=\vbox{\box\@@pLineBox\unvbox\@@pBox}%
- \fi %
- \def\sem@tmp{#2}%
- \ifx \sem@tmp\empty \else %
- \@ReturnAfterFi{%
- \@processPremises #2\end %
- }%
- \fi%
-}
-\def\@processPremiseLine#1\end{%
- \def\sem@tmp{#1}%
- \ifx \sem@tmp\empty \else%
- \ifx \sem@tmp\@@space \else%
- \setbox\@@pLineBox=%
- \hbox{\unhbox\@@pLineBox%
- \@inferenceOrPremis #1\inference\end%
- \hskip\@@pSpace}%
- \fi%
- \fi%
- \def\sem@tmp{#2}%
- \ifx \sem@tmp\empty \else%
- \@ReturnAfterFi{%
- \@processPremiseLine#2\end%
- }%
- \fi%
-}
-\def\@inferenceOrPremis#1\inference{%
- \@ifnext \end
- {\@dropnext{\predicate{\ignorespaces #1}\unskip}}%
- {\@processInference #1\inference}%
-}
-\def\@processInference#1\inference\end{%
- \ignorespaces #1%
- \setbox3=\lastbox
- \dimen3=\dp3
- \advance\dimen3 by -\fontdimen22\textfont2
- \advance\dimen3 by \fontdimen8\textfont3
- \expandafter\raise\dimen3\box3%
-}
-\long\def\@ReturnAfterFi#1\fi{\fi#1}
-\fi
-\endinput
-%%
-%% End of file `infernce.sty'.
+++ /dev/null
-%%
-%% This is file `ligature.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,ligature')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from ligature.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\@addligto,\@addligtofollowlist,\@def@ligstep}
-\TestForConflict{\@@trymathlig,\@defactive,\@defligstep}
-\TestForConflict{\@definemathlig,\@domathligfirsts,\@domathligfollows}
-\TestForConflict{\@exitmathlig,\@firstmathligs,\@ifactive,\@ifcharacter}
-\TestForConflict{\@ifinlist,\@lastvalidmathlig,\@mathliglink}
-\TestForConflict{\@mathligredefactive,\@mathligsoff,\@mathligson}
-\TestForConflict{\@seentoks,\@setupfirstligchar,\@try@mathlig}
-\TestForConflict{\@trymathlig,\if@mathligon,\mathlig,\mathligprotect}
-\TestForConflict{\mathligsoff,\mathligson,\@startmathlig,\@pushedtoks}
-\newif\if@mathligon
-\DeclareRobustCommand\mathlig[1]{\@addligtolists#1\@@
- \if@mathligon\mathligson\fi
- \@setupfirstligchar#1\@@
- \@defligstep{}#1\@@}
-\def\@mathligson{\if@mathligon\mathligson\fi}
-\def\@mathligsoff{\if@mathligon\mathligsoff\@mathligontrue\fi}
-\DeclareRobustCommand\mathligprotect[1]{\expandafter
- \def\expandafter#1\expandafter{%
- \expandafter\@mathligsoff#1\@mathligson}}
-\DeclareRobustCommand\mathligson{\def\do##1##2##3{\mathcode`##1="8000}%
- \@domathligfirsts\@mathligontrue}
-\AtBeginDocument{\mathligson}
-\DeclareRobustCommand\mathligsoff{\def\do##1##2##3{\mathcode`##1=##2}%
- \@domathligfirsts\@mathligonfalse}
-\edef\@mathliglink{Error: \noexpand\verb|\string\@mathliglink| expanded}
-{\catcode`\A=11\catcode`\1=12\catcode`\~=13 % Letter, Other and Active
-\gdef\@ifcharacter#1{\ifcat A\noexpand#1\let\next\@firstoftwo
- \else\ifcat 1\noexpand#1\let\next\@firstoftwo
- \else\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo
- \else\let\next\@secondoftwo\fi\fi\fi\next}%
-\gdef\@ifactive#1{\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo
- \else\let\next\@secondoftwo\fi\next}}
-\def\@domathligfollows{}\def\@domathligfirsts{}
-\def\@makemathligsactive{\mathligson
- \def\do##1##2##3{\catcode`##1=12}\@domathligfollows}
-\def\@makemathligsnormal{\mathligsoff
- \def\do##1##2##3{\catcode`##1=##3}\@domathligfollows}
-\def\@ifinlist#1#2{\@tempswafalse
- \def\do##1##2##3{\ifnum`##1=`#2\relax\@tempswatrue\fi}#1%
- \if@tempswa\let\next\@firstoftwo\else\let\next\@secondoftwo\fi\next}
-\def\@addligto#1#2{%
- \@ifinlist#1#2{\def\do##1##2##3{\noexpand\do\noexpand##1%
- \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}%
- \else{##2}{##3}\fi}%
- \edef#1{#1}}%
- {\def\do##1##2##3{\noexpand\do\noexpand##1%
- \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}%
- \else{##2}{##3}\fi}%
- \edef#1{#1\do#2{\the\mathcode`#2}{\the\catcode`#2}}}}
-\def\@addligtolists#1{\expandafter\@addligto
- \expandafter\@domathligfirsts
- \csname\string#1\endcsname\@addligtofollowlist}
-\def\@addligtofollowlist#1{\ifx#1\@@\let\next\relax\else
- \def\next{\expandafter\@addligto
- \expandafter\@domathligfollows
- \csname\string#1\endcsname
- \@addligtofollowlist}\fi\next}
-\def\@defligstep#1#2{\def\@tempa##1{\ifx##1\endcsname
- \expandafter\endcsname\else
- \string##1\expandafter\@tempa\fi}%
- \expandafter\@def@ligstep\csname @mathlig\@tempa#1#2\endcsname{#1#2}}
-\def\@def@ligstep#1#2#3{%
- \ifx#3\@@
- \def\next{\def#1}%
- \else
- \ifx#1\relax
- \def\next{\let#1\@mathliglink\@defligstep{#2}#3}%
- \else
- \def\next{\@defligstep{#2}#3}%
- \fi
- \fi\next}
-\def\@setupfirstligchar#1#2\@@{%
- \@ifactive{#1}{%
- \expandafter\expandafter\expandafter\@mathligredefactive
- \expandafter\string\expandafter#1\expandafter{#1}{#1}}%
- {\@defactive#1{\@startmathlig #1}\@namedef{@mathlig#1}{#1}}}
-\def\@mathligredefactive#1#2#3{%
- \def#3{{}\ifmmode\def\next{\@startmathlig#1}\else
- \def\next{#2}\fi\next}%
- \@namedef{@mathlig#1}{#2}}
-\def\@defactive#1{\@ifundefined{@definemathlig\string#1}%
- {\@latex@error{Illegal first character in math ligature}
- {You can only use \@firstmathligs\space as the first^^J
- character of a math ligature}}%
- {\csname @definemathlig\string#1\endcsname}}
-
-{\def\@firstmathligs{}\def\do#1{\catcode`#1=\active
- \expandafter\gdef\expandafter\@firstmathligs
- \expandafter{\@firstmathligs\space\string#1}\next}
- \def\next#1{\expandafter\gdef\csname
- @definemathlig\string#1\endcsname{\def#1}}
- \do{"}"\do{@}@\do{/}/\do{(}(\do{)})\do{[}[\do{]}]\do{=}=
- \do{?}?\do{!}!\do{`}`\do{'}'\do{|}|\do{~}~\do{<}<\do{>}>
- \do{+}+\do{-}-\do{*}*\do{.}.\do{,},\do{:}:\do{;};}
-\newtoks\@pushedtoks
-\newtoks\@seentoks
-\def\@startmathlig{\def\@lastvalidmathlig{}\@pushedtoks{}%
- \@seentoks{}\@trymathlig}
-\def\@trymathlig{\futurelet\next\@@trymathlig}
-\def\@@trymathlig{\@ifcharacter\next{\@try@mathlig}{\@exitmathlig{}}}
-\def\@exitmathlig#1{%
- \expandafter\@makemathligsnormal\@lastvalidmathlig\mathligson
- \the\@pushedtoks#1}
-\def\@try@mathlig#1{%\typeout{char: #1 catcode: \the\catcode`#1
- \@ifundefined{@mathlig\the\@seentoks#1}{\@exitmathlig{#1}}%
- {\expandafter\ifx
- \csname @mathlig\the\@seentoks#1\endcsname
- \@mathliglink
- \expandafter\@pushedtoks
- \expandafter=\expandafter{\the\@pushedtoks#1}%
- \else
- \expandafter\let\expandafter\@lastvalidmathlig
- \csname @mathlig\the\@seentoks#1\endcsname
- \@pushedtoks={}%
- \fi
- \expandafter\@seentoks\expandafter=\expandafter%
- {\the\@seentoks#1}\@makemathligsactive\obeyspaces\@trymathlig}}
-\edef\patch@newmcodes@{%
- \mathcode\number`\'=39
- \mathcode\number`\*=42
- \mathcode\number`\.=\string "613A
- \mathchardef\noexpand\std@minus=\the\mathcode`\-\relax
- \mathcode\number`\-=45
- \mathcode\number`\/=47
- \mathcode\number`\:=\string "603A\relax
-}
-\AtBeginDocument{\let\newmcodes@=\patch@newmcodes@}
-\fi
-\endinput
-%%
-%% End of file `ligature.sty'.
+++ /dev/null
-\documentclass[a4paper]{article}
-
-\usepackage{a4wide}
-\usepackage{pifont}
-\usepackage{semantic}
-\usepackage{stmaryrd}
-\usepackage{graphicx}
-
-\newcommand{\MATITA}{\ding{46}\textsf{\textbf{Matita}}}
-
-\title{Continuationals semantics for \MATITA}
-\author{Claudio Sacerdoti Coen \quad Enrico Tassi \quad Stefano Zacchiroli \\
-\small Department of Computer Science, University of Bologna \\
-\small Mura Anteo Zamboni, 7 -- 40127 Bologna, ITALY \\
-\small \{\texttt{sacerdot}, \texttt{tassi}, \texttt{zacchiro}\}\texttt{@cs.unibo.it}}
-
-\newcommand{\MATHIT}[1]{\ensuremath{\mathit{#1}}}
-\newcommand{\MATHTT}[1]{\ensuremath{\mathtt{#1}}}
-
-\newcommand{\DOT}{\ensuremath{\mbox{\textbf{.}}}}
-\newcommand{\SEMICOLON}{\ensuremath{\mbox{\textbf{;}}}}
-\newcommand{\BRANCH}{\ensuremath{\mbox{\textbf{[}}}}
-\newcommand{\SHIFT}{\ensuremath{\mbox{\textbf{\textbar}}}}
-\newcommand{\POS}[1]{\ensuremath{#1\mbox{\textbf{:}}}}
-\newcommand{\MERGE}{\ensuremath{\mbox{\textbf{]}}}}
-\newcommand{\FOCUS}[1]{\ensuremath{\mathtt{focus}~#1}}
-\newcommand{\UNFOCUS}{\ensuremath{\mathtt{unfocus}}}
-\newcommand{\SKIP}{\MATHTT{skip}}
-\newcommand{\TACTIC}[1]{\ensuremath{\mathtt{tactic}~#1}}
-
-\newcommand{\APPLY}[1]{\ensuremath{\mathtt{apply}~\mathit{#1}}}
-
-\newcommand{\GOAL}{\MATHIT{goal}}
-\newcommand{\SWITCH}{\MATHIT{switch}}
-\newcommand{\LIST}{\MATHTT{list}}
-\newcommand{\INT}{\MATHTT{int}}
-\newcommand{\OPEN}{\MATHTT{Open}}
-\newcommand{\CLOSED}{\MATHTT{Closed}}
-
-\newcommand{\SEMOP}[1]{|[#1|]}
-\newcommand{\TSEMOP}[1]{{}_t|[#1|]}
-\newcommand{\SEM}[3][\xi]{\SEMOP{#2}_{{#1},{#3}}}
-\newcommand{\ENTRY}[4]{\langle#1,#2,#3,#4\rangle}
-\newcommand{\TSEM}[3]{\TSEMOP{#1}_{#2,#3}}
-
-\newcommand{\GIN}[1][1]{\ensuremath{[l_{#1};\cdots;l_n]}}
-
-\newcommand{\ZEROPOS}{\MATHIT{zero\_pos}}
-\newcommand{\INITPOS}{\MATHIT{init\_pos}}
-\newcommand{\ISFRESH}{\MATHIT{is\_fresh}}
-\newcommand{\FILTER}{\MATHIT{filter}}
-\newcommand{\FILTEROPEN}{\MATHIT{filter\_open}}
-\newcommand{\ISOPEN}{\MATHIT{is\_open}}
-\newcommand{\DEEPCLOSE}{\MATHIT{deep\_close}}
-\newcommand{\REMOVEGOALS}{\MATHIT{remove\_goals}}
-\newcommand{\GOALS}{\MATHIT{open\_goals}}
-
-\newcommand{\BRANCHTAG}{\ensuremath{\mathtt{B}}}
-\newcommand{\FOCUSTAG}{\ensuremath{\mathtt{F}}}
-
-\newlength{\sidecondlen}
-\setlength{\sidecondlen}{2cm}
-
-\begin{document}
-\maketitle
-
-\input{body.tex}
-
-\end{document}
-
+++ /dev/null
-%%
-%% This is file `reserved.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,reservedWords')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from reserved.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\reservestyle,\@reservestyle,\setreserved,\<}
-\TestForConflict{\@parseDefineReserved,\@xparseDefineReserved}
-\TestForConflict{\@defineReserved,\@xdefineReserved}
-\newcommand{\reservestyle}[3][]{
- \newcommand{#2}{\@parseDefineReserved{#1}{#3}}
- \expandafter\expandafter\expandafter\def
- \expandafter\csname set\expandafter\@gobble\string#2\endcsname##1%
- {#1{#3{##1}}}}
-\newtoks\@@spacing
-\newtoks\@@formating
-\def\@parseDefineReserved#1#2{%
- \@ifnextchar[{\@xparseDefineReserved{#2}}%
- {\@xparseDefineReserved{#2}[#1]}}
-\def\@xparseDefineReserved#1[#2]#3{%
- \@@formating{#1}%
- \@@spacing{#2}%
- \expandafter\@defineReserved#3,\end
-}
-\def\@defineReserved#1,{%
- \@ifnextchar\end
- {\@xdefineReserved #1[]\END\@gobble}%
- {\@xdefineReserved#1[]\END\@defineReserved}}
-\def\@xdefineReserved#1[#2]#3\END{%
- \def\reserved@a{#2}%
- \ifx \reserved@a\empty \toks0{#1}\else \toks0{#2} \fi
- \expandafter\edef\csname\expandafter<#1>\endcsname
- {\the\@@formating{\the\@@spacing{\the\toks0}}}}
-\def\setreserved#1>{%
- \expandafter\let\expandafter\reserved@a\csname<#1>\endcsname
- \@ifundefined{reserved@a}{\PackageError{Semantic}
- {``#1'' is not defined as a reserved word}%
- {Before referring to a name as a reserved word, it %
- should be defined\MessageBreak using an appropriate style
- definer. A style definer is defined \MessageBreak
- using \protect\reservestyle.\MessageBreak%
- Type <return> to proceed --- nothing will be set.}}%
- {\reserved@a}}
-\let\<=\setreserved
-\fi
-\endinput
-%%
-%% End of file `reserved.sty'.
+++ /dev/null
-%%
-%% This is file `semantic.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `general')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from semantic.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\NeedsTeXFormat{LaTeX2e}
-\newcommand{\semanticVersion}{2.0(epsilon)}
-\newcommand{\semanticDate}{2003/10/28}
-\ProvidesPackage{semantic}
- [\semanticDate\space v\semanticVersion\space]
-\typeout{Semantic Package v\semanticVersion\space [\semanticDate]}
-\typeout{CVSId: $Id$}
-\newcounter{@@conflict}
-\newcommand{\@semanticNotDefinable}{%
- \typeout{Command \@backslashchar\reserved@a\space already defined}
- \stepcounter{@@conflict}}
-\newcommand{\@oldNotDefinable}{}
-\let\@oldNotDefinable=\@notdefinable
-\let\@notdefinable=\@semanticNotDefinable
-\newcommand{\TestForConflict}{}
-\def\TestForConflict#1{\sem@test #1,,}
-\newcommand{\sem@test}{}
-\newcommand{\sem@tmp}{}
-\newcommand{\@@next}{}
-\def\sem@test#1,{%
- \def\sem@tmp{#1}%
- \ifx \sem@tmp\empty \let\@@next=\relax \else
- \@ifdefinable{#1}{} \let\@@next=\sem@test \fi
- \@@next}
-\TestForConflict{\@inputLigature,\@inputInference,\@inputTdiagram}
-\TestForConflict{\@inputReservedWords,\@inputShorthand}
-\TestForConflict{\@ddInput,\sem@nticsLoader,\lo@d}
-\def\@inputLigature{\input{ligature.sty}\message{ math mode ligatures,}%
- \let\@inputLigature\relax}
-\def\@inputInference{\input{infernce.sty}\message{ inference rules,}%
- \let\@inputInference\relax}
-\def\@inputTdiagram{\input{tdiagram.sty}\message{ T diagrams,}%
- \let\@inputTdiagram\relax}
-\def\@inputReservedWords{\input{reserved.sty}\message{ reserved words,}%
- \let\@inputReservedWords\relax}
-\def\@inputShorthand{\input{shrthand.sty}\message{ short hands,}%
- \let\@inputShorthand\relax}
-\toks1={}
-\newcommand{\@ddInput}[1]{%
- \toks1=\expandafter{\the\toks1\noexpand#1}}
-\DeclareOption{ligature}{\@ddInput\@inputLigature}
-\DeclareOption{inference}{\@ddInput\@inputInference}
-\DeclareOption{tdiagram}{\@ddInput\@inputTdiagram}
-\DeclareOption{reserved}{\@ddInput\@inputReservedWords}
-\DeclareOption{shorthand}{\@ddInput\@inputLigature
- \@ddInput\@inputShorthand}
-\ProcessOptions*
-\typeout{Loading features: }
-\def\sem@nticsLoader{}
-\edef\lo@d{\the\toks1}
-\ifx\lo@d\empty
- \@inputLigature
- \@inputInference
- \@inputTdiagram
- \@inputReservedWords
- \@inputShorthand
-\else
- \lo@d
-\fi
-\typeout{and general definitions.^^J}
-\let\@ddInput\relax
-\let\@inputInference\relax
-\let\@inputLigature\relax
-\let\@inputTdiagram\relax
-\let\@inputReservedWords\relax
-\let\@inputShorthand\relax
-\let\sem@nticsLoader\realx
-\let\lo@d\relax
-\TestForConflict{\@dropnext,\@ifnext,\@ifn,\@ifNextMacro,\@ifnMacro}
-\TestForConflict{\@@maxwidth,\@@pLineBox,\if@@Nested,\@@cBox}
-\TestForConflict{\if@@moreLines,\@@pBox}
-\def\@ifnext#1#2#3{%
- \let\reserved@e=#1\def\reserved@a{#2}\def\reserved@b{#3}\futurelet%
- \reserved@c\@ifn}
-\def\@ifn{%
- \ifx \reserved@c \reserved@e\let\reserved@d\reserved@a\else%
- \let\reserved@d\reserved@b\fi \reserved@d}
-\def\@ifNextMacro#1#2{%
- \def\reserved@a{#1}\def\reserved@b{#2}%
- \futurelet\reserved@c\@ifnMacro}
-\def\@ifnMacro{%
- \ifcat\noexpand\reserved@c\noexpand\@ifnMacro
- \let\reserved@d\reserved@a
- \else \let\reserved@d\reserved@b\fi \reserved@d}
-\newcommand{\@dropnext}[2]{#1}
-\ifnum \value{@@conflict} > 0
- \PackageError{Semantic}
- {The \the@@conflict\space command(s) listed above have been
- redefined.\MessageBreak
- Please report this to turtle@bu.edu}
- {Some of the commands defined in semantic was already defined %
- and has\MessageBreak now be redefined. There is a risk that %
- these commands will be used\MessageBreak by other packages %
- leading to spurious errors.\MessageBreak
- \space\space Type <return> and cross your fingers%
-}\fi
-\let\@notdefinable=\@oldNotDefinable
-\let\@semanticNotDefinable=\relax
-\let\@oldNotDefinable=\relax
-\let\TestForConflict=\relax
-\let\@endmark=\relax
-\let\sem@test=\relax
-\newdimen\@@maxwidth
-\newbox\@@pLineBox
-\newbox\@@cBox
-\newbox\@@pBox
-\newif\if@@moreLines
-\newif\if@@Nested \@@Nestedfalse
-\endinput
-%%
-%% End of file `semantic.sty'.
+++ /dev/null
-%%
-%% This is file `shrthand.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,shorthand')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from shrthand.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\IfFileExists{DONOTUSEmathbbol.sty}{%
- \RequirePackage{mathbbol}
- \newcommand{\@bblb}{\textbb{[}}
- \newcommand{\@bbrb}{\textbb{]}}
- \newcommand{\@mbblb}{\mathopen{\mbox{\textbb{[}}}}
- \newcommand{\@mbbrb}{\mathclose{\mbox{\textbb{]}}}}
-}
-{ \newcommand{\@bblb}{\textnormal{[\kern-.15em[}}
- \newcommand{\@bbrb}{\textnormal{]\kern-.15em]}}
- \newcommand{\@mbblb}{\mathopen{[\mkern-2.67mu[}}
- \newcommand{\@mbbrb}{\mathclose{]\mkern-2.67mu]}}
-}
-\mathlig{|-}{\vdash}
-\mathlig{|=}{\models}
-\mathlig{->}{\rightarrow}
-\mathlig{->*}{\mathrel{\rightarrow^*}}
-\mathlig{->+}{\mathrel{\rightarrow^+}}
-\mathlig{-->}{\longrightarrow}
-\mathlig{-->*}{\mathrel{\longrightarrow^*}}
-\mathlig{-->+}{\mathrel{\longrightarrow^+}}
-\mathlig{=>}{\Rightarrow}
-\mathlig{=>*}{\mathrel{\Rightarrow^*}}
-\mathlig{=>+}{\mathrel{\Rightarrow^+}}
-\mathlig{==>}{\Longrightarrow}
-\mathlig{==>*}{\mathrel{\Longrightarrow^*}}
-\mathlig{==>+}{\mathrel{\Longrightarrow^+}}
-\mathlig{<-}{\leftarrow}
-\mathlig{*<-}{\mathrel{{}^*\mkern-1mu\mathord\leftarrow}}
-\mathlig{+<-}{\mathrel{{}^+\mkern-1mu\mathord\leftarrow}}
-\mathlig{<--}{\longleftarrow}
-\mathlig{*<--}{\mathrel{{}^*\mkern-1mu\mathord{\longleftarrow}}}
-\mathlig{+<--}{\mathrel{{}^+\mkern-1mu\mathord{\longleftarrow}}}
-\mathlig{<=}{\Leftarrow}
-\mathlig{*<=}{\mathrel{{}^*\mkern-1mu\mathord\Leftarrow}}
-\mathlig{+<=}{\mathrel{{}^+\mkern-1mu\mathord\Leftarrow}}
-\mathlig{<==}{\Longleftarrow}
-\mathlig{*<==}{\mathrel{{}^*\mkern-1mu\mathord{\Longleftarrow}}}
-\mathlig{+<==}{\mathrel{{}^+\mkern-1mu\mathord{\Longleftarrow}}}
-\mathlig{<->}{\longleftrightarrow}
-\mathlig{<=>}{\Longleftrightarrow}
-\mathlig{|[}{\@mbblb}
-\mathlig{|]}{\@mbbrb}
-\newcommand{\evalsymbol}[1][]{\ensuremath{\mathcal{E}^{#1}}}
-\newcommand{\compsymbol}[1][]{\ensuremath{\mathcal{C}^{#1}}}
-\newcommand{\eval}[3][]%
- {\mbox{$\mathcal{E}^{#1}$\@bblb \texttt{#2}\@bbrb}%
- \ensuremath{\mathtt{#3}}}
-\newcommand{\comp}[3][]%
- {\mbox{$\mathcal{C}^{#1}$\@bblb \texttt{#2}\@bbrb}%
- \ensuremath{\mathtt{#3}}}
-\newcommand{\@exe}[3]{}
-\newcommand{\exe}[1]{\@ifnextchar[{\@exe{#1}}{\@exe{#1}[]}}
-\def\@exe#1[#2]#3{%
- \mbox{\@bblb\texttt{#1}\@bbrb$^\mathtt{#2}\mathtt{(#3)}$}}
-\fi
-\endinput
-%%
-%% End of file `shrthand.sty'.
+++ /dev/null
-%%
-%% This is file `tdiagram.sty',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% semantic.dtx (with options: `allOptions,Tdiagram')
-%%
-%% IMPORTANT NOTICE:
-%%
-%% For the copyright see the source file.
-%%
-%% Any modified versions of this file must be renamed
-%% with new filenames distinct from tdiagram.sty.
-%%
-%% For distribution of the original source see the terms
-%% for copying and modification in the file semantic.dtx.
-%%
-%% This generated file may be distributed as long as the
-%% original source files, as listed above, are part of the
-%% same distribution. (The sources need not necessarily be
-%% in the same archive or directory.)
-%%
-%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and
-%% Arne John Glenstrup
-%%
-\expandafter\ifx\csname sem@nticsLoader\endcsname\relax
- \PackageError{semantic}{%
- This file should not be loaded directly}
- {%
- This file is an option of the semantic package. It should not be
- loaded directly\MessageBreak
- but by using \protect\usepackage{semantic} in your document
- preamble.\MessageBreak
- No commands are defined.\MessageBreak
- Type <return> to proceed.
- }%
-\else
-\TestForConflict{\@getSymbol,\@interpreter,\@parseArg,\@program}
-\TestForConflict{\@putSymbol,\@saveBeforeSymbolMacro,\compiler}
-\TestForConflict{\interpreter,\machine,\program,\@compiler}
-\newif\if@@Left
-\newif\if@@Up
-\newcount\@@xShift
-\newcount\@@yShift
-\newtoks\@@symbol
-\newtoks\@@tempSymbol
-\newcommand{\compiler}[1]{\@compiler#1\end}
-\def\@compiler#1,#2,#3\end{%
- \if@@Nested %
- \if@@Up %
- \@@yShift=40 \if@@Left \@@xShift=-50 \else \@@xShift=-30 \fi
- \else%
- \@@yShift=20 \@@xShift =0 %
- \fi%
- \else%
- \@@yShift=40 \@@xShift=-40%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(1,0){80}}%
- \put(0,-20){\line(1,0){30}}%
- \put(50,-20){\line(1,0){30}}%
- \put(30,-40){\line(1,0){20}}%
- \put(0,0){\line(0,-1){20}}%
- \put(80,0){\line(0,-1){20}}%
- \put(30,-20){\line(0,-1){20}}%
- \put(50,-20){\line(0,-1){20}}%
- \put(30,-20){\makebox(20,20){$\rightarrow$}} %
- {\@@Uptrue \@@Lefttrue \@parseArg(0,-20)(5,-20)#1\end}%
- \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- {\@@Uptrue \@@Leftfalse \@parseArg(80,-20)(55,-20)#3\end}%
- {\@@Upfalse \@@Lefttrue \@parseArg(50,-40)(30,-40)#2\end}%
- \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi%
- }%
-}
-\newcommand{\interpreter}[1]{\@interpreter#1\end}
-\def\@interpreter#1,#2\end{%
- \if@@Nested %
- \if@@Up %
- \@@yShift=40 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi
- \else%
- \@@yShift=0 \@@xShift =0 %
- \fi%
- \else%
- \@@yShift=40 \@@xShift=10%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(-1,0){20}}%
- \put(0,-40){\line(-1,0){20}}%
- \put(0,0){\line(0,-1){40}}%
- \put(-20,0){\line(0,-1){40}}%
- {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-20)#1\end}%
- \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- {\@@Upfalse \@@Lefttrue \@parseArg(0,-40)(-20,-40)#2\end}%
- \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi
- \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi%
- }%
-}
-\newcommand{\program}[1]{\@program#1\end}
-\def\@program#1,#2\end{%
- \if@@Nested %
- \if@@Up %
- \@@yShift=0 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi
- \else%
- \PackageError{semantic}{%
- A program cannot be at the bottom}
- {%
- You have tried to use a \protect\program\space as the
- bottom\MessageBreak parameter to \protect\compiler,
- \protect\interpreter\space or \protect\program.\MessageBreak
- Type <return> to proceed --- Output can be distorted.}%
- \fi%
- \else%
- \@@yShift=0 \@@xShift=10%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(-1,0){20}}%
- \put(0,0){\line(0,1){30}}%
- \put(-20,0){\line(0,1){30}}%
- \put(-10,30){\oval(20,20)[t]}%
- \@putSymbol[#1]{-20,20}%
- {\@@Upfalse \@@Lefttrue \@parseArg(0,0)(-20,0)#2\end}%
- }%
-}
-\newcommand{\machine}[1]{%
- \if@@Nested %
- \if@@Up %
- \PackageError{semantic}{%
- A machine cannot be at the top}
- {%
- You have tried to use a \protect\machine\space as a
- top\MessageBreak parameter to \protect\compiler or
- \protect\interpreter.\MessageBreak
- Type <return> to proceed --- Output can be distorted.}%
- \else \@@yShift=0 \@@xShift=0
- \fi%
- \else%
- \@@yShift=20 \@@xShift=10%
- \fi
- \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{%
- \put(0,0){\line(-1,0){20}} \put(-20,0){\line(3,-5){10}}
- \put(0,0){\line(-3,-5){10}}%
- {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-15)#1\end}%
- }%
-}
-\def\@parseArg(#1)(#2){%
- \@ifNextMacro{\@doSymbolMacro(#1)(#2)}{\@getSymbol(#2)}}
-\def\@getSymbol(#1)#2\end{\@putSymbol[#2]{#1}}
-\def\@doSymbolMacro(#1)(#2)#3{%
- \@ifnextchar[{\@saveBeforeSymbolMacro(#1)(#2)#3}%
- {\@symbolMacro(#1)(#2)#3}}
-\def\@saveBeforeSymbolMacro(#1)(#2)#3[#4]#5\end{%
- \@@tempSymbol={#4}%
- \@@Nestedtrue\put(#1){#3#5}%
- \@putSymbol[\the\@@tempSymbol]{#2}}
-\def\@symbolMacro(#1)(#2)#3\end{%
- \@@Nestedtrue\put(#1){#3}%
- \@putSymbol{#2}}
-\newcommand{\@putSymbol}[2][\the\@@symbol]{%
- \global\@@symbol=\expandafter{#1}%
- \put(#2){\makebox(20,20){\texttt{\the\@@symbol}}}}
-\fi
-\endinput
-%%
-%% End of file `tdiagram.sty'.
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module C = Cic
-module I = CicInspect
-module S = CicSubstitution
-module TC = CicTypeChecker
-module P = PrimitiveTactics
-module T = Tacticals
-module PESR = ProofEngineStructuralRules
-module F = FreshNamesGenerator
-module PET = ProofEngineTypes
-module RT = ReductionTactics
-module E = CicEnvironment
-module R = CicReduction
-module Un = CicUniv
-module PEH = ProofEngineHelpers
-
-let premise_pattern what = None, [what, C.Implicit (Some `Hole)], None
-
-let get_inductive_def uri =
- match E.get_obj Un.oblivion_ugraph uri with
- | C.InductiveDefinition (tys, _, lpsno, _), _ ->
- lpsno, tys
- | _ -> assert false
-
-let is_not_recursive uri tyno tys =
- let map mutinds (_, ty) =
-(* FG: we can do much better here *)
- let map mutinds (_, t) = I.S.union mutinds (I.get_mutinds_of_uri uri t) in
-(**********************************)
- let premises, _ = PEH.split_with_whd ([], ty) in
- List.fold_left map mutinds (List.tl premises)
- in
- let msg = "recursiveness check non implemented for mutually inductive types" in
- if List.length tys > 1 then raise (PET.Fail (lazy msg)) else
- let _, _, _, constructors = List.nth tys tyno in
- let mutinds = List.fold_left map I.S.empty constructors in
- I.S.is_empty mutinds
-
-let rec check_type sorts metasenv context t =
- match R.whd ~delta:true context t with
- | C.MutInd (uri, tyno, _) as t ->
- let lpsno, tys = get_inductive_def uri in
- let _, inductive, arity, _ = List.nth tys tyno in
- let _, psno = PEH.split_with_whd ([], arity) in
- let not_relation = (lpsno = psno) in
- let not_recursive = is_not_recursive uri tyno tys in
- let ty_ty, _ = TC.type_of_aux' metasenv context t Un.oblivion_ugraph in
- let sort = match PEH.split_with_whd (context, ty_ty) with
- | (_, C.Sort sort) ::_ , _ -> CicPp.ppsort sort
- | (_, C.Meta _) :: _, _ -> CicPp.ppsort (C.Type (Un.fresh ()))
- | _ -> assert false
- in
- let right_sort = List.mem sort sorts in
- if not_relation && inductive && not_recursive && right_sort then
- begin
- HLog.warn (Printf.sprintf "Decomposing %s %u" (UriManager.string_of_uri uri) (succ tyno));
- true
- end
- else false
- | C.Appl (hd :: tl) -> check_type sorts metasenv context hd
- | _ -> false
-
-(* unexported tactics *******************************************************)
-
-let rec scan_tac ~old_context_length ~index ~tactic =
- let scan_tac status =
- let (proof, goal) = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- let context_length = List.length context in
- let rec aux index =
- match PEH.get_name context index with
- | _ when index <= 0 -> (proof, [goal])
- | None -> aux (pred index)
- | Some what ->
- let tac = T.then_ ~start:(tactic ~what)
- ~continuation:(scan_tac ~old_context_length:context_length ~index ~tactic)
- in
- try PET.apply_tactic tac status
- with PET.Fail _ -> aux (pred index)
- in aux (index + context_length - old_context_length)
- in
- PET.mk_tactic scan_tac
-
-let elim_clear_unfold_tac ~sorts ~mk_fresh_name_callback ~what =
- let elim_clear_unfold_tac status =
- let (proof, goal) = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- let index, ty = PEH.lookup_type metasenv context what in
- let tac =
- if check_type sorts metasenv context (S.lift index ty) then
- T.then_ ~start:(P.elim_intros_tac ~mk_fresh_name_callback (C.Rel index))
- ~continuation:(PESR.clear [what])
- else
- let msg = "unexported elim_clear: not an decomposable type" in
- raise (PET.Fail (lazy msg))
- in
- PET.apply_tactic tac status
- in
- PET.mk_tactic elim_clear_unfold_tac
-
-(* elim type ****************************************************************)
-
-let elim_type_tac ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) ?depth
- ?using what
-=
- let elim =
- P.elim_intros_simpl_tac ?using ?depth ~mk_fresh_name_callback
- in
- let elim_type_tac status =
- let tac =
- T.thens ~start: (P.cut_tac what) ~continuations:[elim (C.Rel 1); T.id_tac]
- in
- PET.apply_tactic tac status
- in
- PET.mk_tactic elim_type_tac
-
-(* decompose ****************************************************************)
-
-(* robaglia --------------------------------------------------------------- *)
-
- (** perform debugging output? *)
-let debug = false
-let debug_print = fun _ -> ()
-
- (** debugging print *)
-let warn s = debug_print (lazy ("DECOMPOSE: " ^ (Lazy.force s)))
-
-(* roba seria ------------------------------------------------------------- *)
-
-let decompose_tac ?(sorts=[CicPp.ppsort C.Prop; CicPp.ppsort (C.CProp (CicUniv.fresh ()))])
- ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) () =
- let decompose_tac status =
- let (proof, goal) = status in
- let _, metasenv, _subst, _,_, _ = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- let tactic = elim_clear_unfold_tac ~sorts ~mk_fresh_name_callback in
- let old_context_length = List.length context in
- let tac = scan_tac ~old_context_length ~index:old_context_length ~tactic
- in
- PET.apply_tactic tac status
- in
- PET.mk_tactic decompose_tac
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val elim_type_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
-
-val decompose_tac:
- ?sorts:string list ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- unit -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module C = Cic
-module U = UriManager
-module PET = ProofEngineTypes
-module PER = ProofEngineReduction
-module PEH = ProofEngineHelpers
-module PESR = ProofEngineStructuralRules
-module P = PrimitiveTactics
-module T = Tacticals
-module R = CicReduction
-module S = CicSubstitution
-module TC = CicTypeChecker
-module LO = LibraryObjects
-module DTI = DoubleTypeInference
-module HEL = HExtlib
-
-let rec rewrite ~direction ~pattern:(wanted,hyps_pat,concl_pat) equality status=
- assert (wanted = None); (* this should be checked syntactically *)
- let proof,goal = status in
- let curi, metasenv, subst, pbo, pty, attrs = proof in
- let (metano,context,gty) = CicUtil.lookup_meta goal metasenv in
- match hyps_pat with
- he::(_::_ as tl) ->
- PET.apply_tactic
- (T.then_
- (PET.mk_tactic (rewrite ~direction
- ~pattern:(None,[he],None) equality))
- (PET.mk_tactic (rewrite ~direction
- ~pattern:(None,tl,concl_pat) (S.lift 1 equality)))
- ) status
- | [_] as hyps_pat when concl_pat <> None ->
- PET.apply_tactic
- (T.then_
- (PET.mk_tactic (rewrite ~direction
- ~pattern:(None,hyps_pat,None) equality))
- (PET.mk_tactic (rewrite ~direction
- ~pattern:(None,[],concl_pat) (S.lift 1 equality)))
- ) status
- | _ ->
- let arg,dir2,tac,concl_pat,gty =
- match hyps_pat with
- [] -> None,true,(fun ~term _ -> P.exact_tac term),concl_pat,gty
- | [name,pat] ->
- let arg,gty = ProofEngineHelpers.find_hyp name context in
- let dummy = "dummy" in
- Some arg,false,
- (fun ~term typ ->
- T.seq
- ~tactics:
- [PESR.rename [name] [dummy];
- P.letin_tac
- ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name name) term;
- PESR.clearbody name;
- ReductionTactics.change_tac
- ~pattern:
- (None,[name,Cic.Implicit (Some `Hole)], None)
- (ProofEngineTypes.const_lazy_term typ);
- PESR.clear [dummy]
- ]),
- Some pat,gty
- | _::_ -> assert false
- in
- let gsort,_ =
- CicTypeChecker.type_of_aux'
- metasenv ~subst context gty CicUniv.oblivion_ugraph
- in
- let if_right_to_left do_not_change a b =
- match direction with
- | `RightToLeft -> if do_not_change then a else b
- | `LeftToRight -> if do_not_change then b else a
- in
- let ty_eq,ugraph =
- CicTypeChecker.type_of_aux' metasenv ~subst context equality
- CicUniv.oblivion_ugraph in
- let (ty_eq,metasenv',arguments,fresh_meta) =
- TermUtil.saturate_term
- (ProofEngineHelpers.new_meta_of_proof proof) metasenv context ty_eq 0 in
- let equality =
- if List.length arguments = 0 then
- equality
- else
- C.Appl (equality :: arguments) in
- (* t1x is t2 if we are rewriting in an hypothesis *)
- let eq_ind, ty, t1, t2, t1x =
- match ty_eq with
- | C.Appl [C.MutInd (uri, 0, []); ty; t1; t2]
- when LibraryObjects.is_eq_URI uri ->
- let ind_uri =
- match gsort with
- C.Sort C.Prop ->
- if_right_to_left dir2
- LibraryObjects.eq_ind_URI LibraryObjects.eq_ind_r_URI
- | C.Sort C.Set ->
- if_right_to_left dir2
- LibraryObjects.eq_rec_URI LibraryObjects.eq_rec_r_URI
- | _ ->
- if_right_to_left dir2
- LibraryObjects.eq_rect_URI LibraryObjects.eq_rect_r_URI
- in
- let eq_ind = C.Const (ind_uri uri,[]) in
- if dir2 then
- if_right_to_left true (eq_ind,ty,t2,t1,t2) (eq_ind,ty,t1,t2,t1)
- else
- if_right_to_left true (eq_ind,ty,t1,t2,t2) (eq_ind,ty,t2,t1,t1)
- | _ -> raise (PET.Fail (lazy "Rewrite: argument is not a proof of an equality")) in
- (* now we always do as if direction was `LeftToRight *)
- let fresh_name =
- FreshNamesGenerator.mk_fresh_name
- ~subst metasenv' context C.Anonymous ~typ:ty in
- let lifted_t1 = S.lift 1 t1x in
- let lifted_gty = S.lift 1 gty in
- let lifted_conjecture =
- metano,(Some (fresh_name,Cic.Decl ty))::context,lifted_gty in
- let lifted_pattern =
- let lifted_concl_pat =
- match concl_pat with
- | None -> None
- | Some term -> Some (S.lift 1 term) in
- Some (fun c m u ->
- let distance = pred (List.length c - List.length context) in
- S.lift distance lifted_t1, m, u),[],lifted_concl_pat
- in
- let subst,metasenv',ugraph,_,selected_terms_with_context =
- ProofEngineHelpers.select
- ~metasenv:metasenv' ~subst ~ugraph ~conjecture:lifted_conjecture
- ~pattern:lifted_pattern in
- let metasenv' = CicMetaSubst.apply_subst_metasenv subst metasenv' in
- let what,with_what =
- (* Note: Rel 1 does not live in the context context_of_t *)
- (* The replace_lifting_csc 0 function will take care of lifting it *)
- (* to context_of_t *)
- List.fold_right
- (fun (context_of_t,t) (l1,l2) -> t::l1, Cic.Rel 1::l2)
- selected_terms_with_context ([],[]) in
- let t1 = CicMetaSubst.apply_subst subst t1 in
- let t2 = CicMetaSubst.apply_subst subst t2 in
- let ty = CicMetaSubst.apply_subst subst ty in
- let pbo = lazy (CicMetaSubst.apply_subst subst (Lazy.force pbo)) in
- let pty = CicMetaSubst.apply_subst subst pty in
- let equality = CicMetaSubst.apply_subst subst equality in
- let abstr_gty =
- ProofEngineReduction.replace_lifting_csc 0
- ~equality:(==) ~what ~with_what:with_what ~where:lifted_gty in
- if lifted_gty = abstr_gty then
- raise (ProofEngineTypes.Fail (lazy "nothing to do"));
- let abstr_gty = CicMetaSubst.apply_subst subst abstr_gty in
- let pred = C.Lambda (fresh_name, ty, abstr_gty) in
- (* The argument is either a meta if we are rewriting in the conclusion
- or the hypothesis if we are rewriting in an hypothesis *)
- let metasenv',arg,newtyp =
- match arg with
- None ->
- let fresh_meta = CicMkImplicit.new_meta metasenv' subst in
- let gty' = S.subst t2 abstr_gty in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,gty')::metasenv' in
- metasenv', C.Meta (fresh_meta,irl), Cic.Rel (-1) (* dummy term, never used *)
- | Some arg ->
- let gty' = S.subst t1 abstr_gty in
- metasenv',arg,gty'
- in
- let exact_proof =
- C.Appl [eq_ind ; ty ; t2 ; pred ; arg ; t1 ;equality]
- in
- try
- let (proof',goals) =
- PET.apply_tactic (tac ~term:exact_proof newtyp)
- ((curi,metasenv',subst,pbo,pty, attrs),goal)
- in
- let goals =
- goals@(ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv
- ~newmetasenv:metasenv')
- in
- (proof',goals)
- with (* FG: this should be PET.Fail _ *)
- TC.TypeCheckerFailure m ->
- let msg = lazy ("rewrite: "^ Lazy.force m) in
- raise (PET.Fail msg)
-;;
-
-let rewrite_tac ~direction ~pattern equality names =
- let _, hyps_pat, _ = pattern in
- let froms = List.map fst hyps_pat in
- let start = PET.mk_tactic (rewrite ~direction ~pattern equality) in
- let continuation = PESR.rename ~froms ~tos:names in
- if names = [] then start else T.then_ ~start ~continuation
-;;
-
-let rewrite_simpl_tac ~direction ~pattern equality names =
- T.then_
- ~start:(rewrite_tac ~direction ~pattern equality names)
- ~continuation:
- (ReductionTactics.simpl_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern None))
-
-let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what =
- let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what status =
- let _wanted, hyps_pat, concl_pat = pattern in
- let (proof, goal) = status in
- let uri,metasenv,subst,pbo,pty, attrs = proof in
- let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
- assert (hyps_pat = []); (*CSC: not implemented yet *)
- let eq_URI =
- match LibraryObjects.eq_URI () with
- Some uri -> uri
- | None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default equality first. Please use the \"default\" command"))
- in
- let context_len = List.length context in
- let subst,metasenv,u,_,selected_terms_with_context =
- ProofEngineHelpers.select ~subst ~metasenv ~ugraph:CicUniv.oblivion_ugraph
- ~conjecture ~pattern in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let with_what, metasenv, u = with_what context metasenv u in
- let with_what = CicMetaSubst.apply_subst subst with_what in
- let pbo = lazy (CicMetaSubst.apply_subst subst (Lazy.force pbo)) in
- let pty = CicMetaSubst.apply_subst subst pty in
- let status = (uri,metasenv,subst,pbo,pty, attrs),goal in
- let ty_of_with_what,u =
- CicTypeChecker.type_of_aux'
- metasenv ~subst context with_what CicUniv.oblivion_ugraph in
- let whats =
- match selected_terms_with_context with
- [] -> raise (ProofEngineTypes.Fail (lazy "Replace: no term selected"))
- | l ->
- List.map
- (fun (context_of_t,t) ->
- let t_in_context =
- try
- let context_of_t_len = List.length context_of_t in
- if context_of_t_len = context_len then t
- else
- (let t_in_context,subst,metasenv' =
- CicMetaSubst.delift_rels [] metasenv
- (context_of_t_len - context_len) t
- in
- assert (subst = []);
- assert (metasenv = metasenv');
- t_in_context)
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- (*CSC: we could implement something stronger by completely changing
- the semantics of the tactic *)
- raise (ProofEngineTypes.Fail
- (lazy "Replace: one of the selected terms is not closed")) in
- let ty_of_t_in_context,u = (* TASSI: FIXME *)
- CicTypeChecker.type_of_aux' metasenv ~subst context t_in_context
- CicUniv.oblivion_ugraph in
- let b,u = CicReduction.are_convertible ~metasenv ~subst context
- ty_of_with_what ty_of_t_in_context u in
- if b then
- let concl_pat_for_t = ProofEngineHelpers.pattern_of ~term:ty [t] in
- let pattern_for_t = None,[],Some concl_pat_for_t in
- t_in_context,pattern_for_t
- else
- raise
- (ProofEngineTypes.Fail
- (lazy "Replace: one of the selected terms and the term to be replaced with have not convertible types"))
- ) l in
- let rec aux n whats (status : ProofEngineTypes.status) =
- match whats with
- [] -> ProofEngineTypes.apply_tactic T.id_tac status
- | (what,lazy_pattern)::tl ->
- let what = S.lift n what in
- let with_what = S.lift n with_what in
- let ty_of_with_what = S.lift n ty_of_with_what in
- ProofEngineTypes.apply_tactic
- (T.thens
- ~start:(
- P.cut_tac
- (C.Appl [
- (C.MutInd (eq_URI, 0, [])) ;
- ty_of_with_what ;
- what ;
- with_what]))
- ~continuations:[
- T.then_
- ~start:(
- rewrite_tac
- ~direction:`LeftToRight ~pattern:lazy_pattern (C.Rel 1) [])
- ~continuation:(
- T.then_
- ~start:(
- ProofEngineTypes.mk_tactic
- (function ((proof,goal) as status) ->
- let _,metasenv,_,_,_, _ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let hyps =
- try
- match List.hd context with
- Some (Cic.Name name,_) -> [name]
- | _ -> assert false
- with (Failure "hd") -> assert false
- in
- ProofEngineTypes.apply_tactic
- (PESR.clear ~hyps) status))
- ~continuation:(aux_tac (n + 1) tl));
- T.id_tac])
- status
- and aux_tac n tl = ProofEngineTypes.mk_tactic (aux n tl) in
- aux 0 whats (status : ProofEngineTypes.status)
- in
- ProofEngineTypes.mk_tactic (replace_tac ~pattern ~with_what)
-;;
-
-
-(* All these tacs do is applying the right constructor/theorem *)
-
-let reflexivity_tac =
- IntroductionTactics.constructor_tac ~n:1
-;;
-
-let symmetry_tac =
- let symmetry_tac (proof, goal) =
- let (_,metasenv,_,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- match (R.whd context ty) with
- (C.Appl [(C.MutInd (uri, 0, [])); _; _; _])
- when LibraryObjects.is_eq_URI uri ->
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac
- ~term:(C.Const (LibraryObjects.sym_eq_URI uri, [])))
- (proof,goal)
-
- | _ -> raise (ProofEngineTypes.Fail (lazy "Symmetry failed"))
- in
- ProofEngineTypes.mk_tactic symmetry_tac
-;;
-
-let transitivity_tac ~term =
- let transitivity_tac ~term status =
- let (proof, goal) = status in
- let (_,metasenv,_,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- match (R.whd context ty) with
- (C.Appl [(C.MutInd (uri, 0, [])); _; _; _])
- when LibraryObjects.is_eq_URI uri ->
- ProofEngineTypes.apply_tactic
- (T.thens
- ~start:(PrimitiveTactics.apply_tac
- ~term: (C.Const (LibraryObjects.trans_eq_URI uri, [])))
- ~continuations:
- [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac])
- status
-
- | _ -> raise (ProofEngineTypes.Fail (lazy "Transitivity failed"))
- in
- ProofEngineTypes.mk_tactic (transitivity_tac ~term)
-;;
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val rewrite_tac:
- direction:[`LeftToRight | `RightToLeft] ->
- pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> string list ->
- ProofEngineTypes.tactic
-
-val rewrite_simpl_tac:
- direction:[`LeftToRight | `RightToLeft] ->
- pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> string list ->
- ProofEngineTypes.tactic
-
-val replace_tac:
- pattern:ProofEngineTypes.lazy_pattern ->
- with_what:Cic.lazy_term -> ProofEngineTypes.tactic
-
-val reflexivity_tac: ProofEngineTypes.tactic
-val symmetry_tac: ProofEngineTypes.tactic
-val transitivity_tac: term:Cic.term -> ProofEngineTypes.tactic
+++ /dev/null
-(***********************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
-(* \VV/ *************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Méthode d'élimination de Fourier *)
-(* Référence:
-Auteur(s) : Fourier, Jean-Baptiste-Joseph
-
-Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
-
-Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
-
-Pages: 326-327
-
-http://gallica.bnf.fr/
-*)
-
-(** @author The Coq Development Team *)
-
-
-(* Un peu de calcul sur les rationnels...
-Les opérations rendent des rationnels normalisés,
-i.e. le numérateur et le dénominateur sont premiers entre eux.
-*)
-
-
-(** Type for coefficents *)
-type rational = {
-num:int; (** Numerator *)
-den:int; (** Denumerator *)
-};;
-
-(** Debug function.
- @param x the rational to print*)
-let print_rational x =
- print_int x.num;
- print_string "/";
- print_int x.den
-;;
-
-let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
-
-(** The constant 0*)
-let r0 = {num=0;den=1};;
-(** The constant 1*)
-let r1 = {num=1;den=1};;
-
-let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
- if x.num=0 then r0
- else (let d=pgcd x.num x.den in
- let d= (if d<0 then -d else d) in
- {num=(x.num)/d;den=(x.den)/d});;
-
-(** Calculates the opposite of a rational.
- @param x The rational
- @return -x*)
-let rop x = rnorm {num=(-x.num);den=x.den};;
-
-(** Sums two rationals.
- @param x A rational
- @param y Another rational
- @return x+y*)
-let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
-(** Substracts two rationals.
- @param x A rational
- @param y Another rational
- @return x-y*)
-let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
-(** Multiplyes two rationals.
- @param x A rational
- @param y Another rational
- @return x*y*)
-let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
-(** Inverts arational.
- @param x A rational
- @return x{^ -1} *)
-let rinv x = rnorm {num=x.den;den=x.num};;
-(** Divides two rationals.
- @param x A rational
- @param y Another rational
- @return x/y*)
-let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
-
-let rinf x y = x.num*y.den < y.num*x.den;;
-let rinfeq x y = x.num*y.den <= y.num*x.den;;
-
-
-(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
-c1x1+...+cnxn < d si strict=true, <= sinon,
-hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
-*)
-
-type ineq = {coef:rational list;
- hist:rational list;
- strict:bool};;
-
-let pop x l = l:=x::(!l);;
-
-(* sépare la liste d'inéquations s selon que leur premier coefficient est
-négatif, nul ou positif. *)
-let partitionne s =
- let lpos=ref [] in
- let lneg=ref [] in
- let lnul=ref [] in
- List.iter (fun ie -> match ie.coef with
- [] -> raise (Failure "empty ineq")
- |(c::r) -> if rinf c r0
- then pop ie lneg
- else if rinf r0 c then pop ie lpos
- else pop ie lnul)
- s;
- [!lneg;!lnul;!lpos]
-;;
-(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
-(add_hist [(equation 1, s1);...;(équation n, sn)])
-=
-[{équation 1, [1;0;...;0], s1};
- {équation 2, [0;1;...;0], s2};
- ...
- {équation n, [0;0;...;1], sn}]
-*)
-let add_hist le =
- let n = List.length le in
- let i=ref 0 in
- List.map (fun (ie,s) ->
- let h =ref [] in
- for k=1 to (n-(!i)-1) do pop r0 h; done;
- pop r1 h;
- for k=1 to !i do pop r0 h; done;
- i:=!i+1;
- {coef=ie;hist=(!h);strict=s})
- le
-;;
-(* additionne deux inéquations *)
-let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
- hist=List.map2 rplus ie1.hist ie2.hist;
- strict=ie1.strict || ie2.strict}
-;;
-(* multiplication d'une inéquation par un rationnel (positif) *)
-let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
- hist=List.map (fun x -> rmult a x) ie.hist;
- strict= ie.strict}
-;;
-(* on enlève le premier coefficient *)
-let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
-;;
-(* le premier coefficient: "tête" de l'inéquation *)
-let hd_coef ie = List.hd ie.coef
-;;
-
-(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
-*)
-let deduce_add lneg lpos =
- let res=ref [] in
- List.iter (fun i1 ->
- List.iter (fun i2 ->
- let a = rop (hd_coef i1) in
- let b = hd_coef i2 in
- pop (ie_tl (ie_add (ie_emult b i1)
- (ie_emult a i2))) res)
- lpos)
- lneg;
- !res
-;;
-(* élimination de la première variable à partir d'une liste d'inéquations:
-opération qu'on itère dans l'algorithme de Fourier.
-*)
-let deduce1 s i=
- match (partitionne s) with
- [lneg;lnul;lpos] ->
- let lnew = deduce_add lneg lpos in
- (match lneg with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->();
- match lpos with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->());
- (List.map ie_tl lnul)@lnew
- |_->assert false
-;;
-(* algorithme de Fourier: on élimine successivement toutes les variables.
-*)
-let deduce lie =
- let n = List.length (fst (List.hd lie)) in
- let lie=ref (add_hist lie) in
- for i=1 to n-1 do
- lie:= deduce1 !lie i;
- done;
- !lie
-;;
-
-(* donne [] si le système a des find solutions,
-sinon donne [c,s,lc]
-où lc est la combinaison linéaire des inéquations de départ
-qui donne 0 < c si s=true
- ou 0 <= c sinon
-cette inéquation étant absurde.
-*)
-(** Tryes to find if the system admits solutions.
- @param lie the list of inequations
- @return a list that can be empty if the system has solutions. Otherwise it returns a
- one elements list [\[(c,s,lc)\]]. {b c} is the rational that can be obtained solving the system,
- {b s} is true if the inequation that proves that the system is absurd is of type [c < 0], false if
- [c <= 0], {b lc} is a list of rational that represents the liear combination to obtain the
- absurd inequation *)
-let unsolvable lie =
- let lr = deduce lie in
- let res = ref [] in
- (try (List.iter (fun e ->
- match e with
- {coef=[c];hist=lc;strict=s} ->
- if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
- then (res := [c,s,lc];
- raise (Failure "contradiction found"))
- |_->assert false)
- lr)
- with _ -> ());
- !res
-;;
-
-(* Exemples:
-
-let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
-deduce test1;;
-unsolvable test1;;
-
-let test2=[
-[r1;r1;r0;r0;r0],false;
-[r0;r1;r1;r0;r0],false;
-[r0;r0;r1;r1;r0],false;
-[r0;r0;r0;r1;r1],false;
-[r1;r0;r0;r0;r1],false;
-[rop r1;rop r1;r0;r0;r0],false;
-[r0;rop r1;rop r1;r0;r0],false;
-[r0;r0;rop r1;rop r1;r0],false;
-[r0;r0;r0;rop r1;rop r1],false;
-[rop r1;r0;r0;r0;rop r1],false
-];;
-deduce test2;;
-unsolvable test2;;
-
-*)
+++ /dev/null
-type rational = { num : int; den : int; }
-val print_rational : rational -> unit
-val pgcd : int -> int -> int
-val r0 : rational
-val r1 : rational
-val rnorm : rational -> rational
-val rop : rational -> rational
-val rplus : rational -> rational -> rational
-val rminus : rational -> rational -> rational
-val rmult : rational -> rational -> rational
-val rinv : rational -> rational
-val rdiv : rational -> rational -> rational
-val rinf : rational -> rational -> bool
-val rinfeq : rational -> rational -> bool
-type ineq = { coef : rational list; hist : rational list; strict : bool; }
-val pop : 'a -> 'a list ref -> unit
-val partitionne : ineq list -> ineq list list
-val add_hist : (rational list * bool) list -> ineq list
-val ie_add : ineq -> ineq -> ineq
-val ie_emult : rational -> ineq -> ineq
-val ie_tl : ineq -> ineq
-val hd_coef : ineq -> rational
-val deduce_add : ineq list -> ineq list -> ineq list
-val deduce1 : ineq list -> int -> ineq list
-val deduce : (rational list * bool) list -> ineq list
-val unsolvable :
- (rational list * bool) list -> (rational * bool * rational list) list
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-
-(******************** THE FOURIER TACTIC ***********************)
-
-(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
-des inéquations et équations sont entiers. En attendant la tactique Field.
-*)
-
-open Fourier
-open ProofEngineTypes
-
-
-let debug x = print_string ("____ "^x) ; flush stdout;;
-
-let debug_pcontext x =
- let str = ref "" in
- List.iter (fun y -> match y with Some(Cic.Name(a),_) -> str := !str ^
- a ^ " " | _ ->()) x ;
- debug ("contesto : "^ (!str) ^ "\n")
-;;
-
-(******************************************************************************
-Operations on linear combinations.
-
-Opérations sur les combinaisons linéaires affines.
-La partie homogène d'une combinaison linéaire est en fait une table de hash
-qui donne le coefficient d'un terme du calcul des constructions,
-qui est zéro si le terme n'y est pas.
-*)
-
-
-
-(**
- The type for linear combinations
-*)
-type flin = {fhom:(Cic.term , rational)Hashtbl.t;fcste:rational}
-;;
-
-(**
- @return an empty flin
-*)
-let flin_zero () = {fhom = Hashtbl.create 50;fcste=r0}
-;;
-
-(**
- @param f a flin
- @param x a Cic.term
- @return the rational associated with x (coefficient)
-*)
-let flin_coef f x =
- try
- (Hashtbl.find f.fhom x)
- with
- _ -> r0
-;;
-
-(**
- Adds c to the coefficient of x
- @param f a flin
- @param x a Cic.term
- @param c a rational
- @return the new flin
-*)
-let flin_add f x c =
- match x with
- Cic.Rel(n) ->(
- let cx = flin_coef f x in
- Hashtbl.remove f.fhom x;
- Hashtbl.add f.fhom x (rplus cx c);
- f)
- |_->debug ("Internal error in Fourier! this is not a Rel "^CicPp.ppterm x^"\n");
- let cx = flin_coef f x in
- Hashtbl.remove f.fhom x;
- Hashtbl.add f.fhom x (rplus cx c);
- f
-;;
-(**
- Adds c to f.fcste
- @param f a flin
- @param c a rational
- @return the new flin
-*)
-let flin_add_cste f c =
- {fhom=f.fhom;
- fcste=rplus f.fcste c}
-;;
-
-(**
- @return a empty flin with r1 in fcste
-*)
-let flin_one () = flin_add_cste (flin_zero()) r1;;
-
-(**
- Adds two flin
-*)
-let flin_plus f1 f2 =
- let f3 = flin_zero() in
- Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
- Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
- flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
-;;
-
-(**
- Substracts two flin
-*)
-let flin_minus f1 f2 =
- let f3 = flin_zero() in
- Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
- Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
- flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
-;;
-
-(**
- @return a times f
-*)
-let flin_emult a f =
- let f2 = flin_zero() in
- Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
- flin_add_cste f2 (rmult a f.fcste);
-;;
-
-
-(*****************************************************************************)
-
-
-(**
- @param t a term
- @raise Failure if conversion is impossible
- @return rational proiection of t
-*)
-let rec rational_of_term t =
- (* fun to apply f to the first and second rational-term of l *)
- let rat_of_binop f l =
- let a = List.hd l and
- b = List.hd(List.tl l) in
- f (rational_of_term a) (rational_of_term b)
- in
- (* as before, but f is unary *)
- let rat_of_unop f l =
- f (rational_of_term (List.hd l))
- in
- match t with
- | Cic.Cast (t1,t2) -> (rational_of_term t1)
- | Cic.Appl (t1::next) ->
- (match t1 with
- Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then
- rat_of_unop rop next
- else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then
- rat_of_unop rinv next
- else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then
- rat_of_binop rmult next
- else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then
- rat_of_binop rdiv next
- else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then
- rat_of_binop rplus next
- else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then
- rat_of_binop rminus next
- else failwith "not a rational"
- | _ -> failwith "not a rational")
- | Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then r1
- else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then r0
- else failwith "not a rational"
- | _ -> failwith "not a rational"
-;;
-
-(* coq wrapper
-let rational_of_const = rational_of_term;;
-*)
-let fails f a =
- try
- ignore (f a);
- false
- with
- _-> true
- ;;
-
-let rec flin_of_term t =
- let fl_of_binop f l =
- let a = List.hd l and
- b = List.hd(List.tl l) in
- f (flin_of_term a) (flin_of_term b)
- in
- try(
- match t with
- | Cic.Cast (t1,t2) -> (flin_of_term t1)
- | Cic.Appl (t1::next) ->
- begin
- match t1 with
- Cic.Const (u,boh) ->
- begin
- if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then
- flin_emult (rop r1) (flin_of_term (List.hd next))
- else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then
- fl_of_binop flin_plus next
- else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then
- fl_of_binop flin_minus next
- else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then
- begin
- let arg1 = (List.hd next) and
- arg2 = (List.hd(List.tl next))
- in
- if fails rational_of_term arg1
- then
- if fails rational_of_term arg2
- then
- ( (* prodotto tra 2 incognite ????? impossibile*)
- failwith "Sistemi lineari!!!!\n"
- )
- else
- (
- match arg1 with
- Cic.Rel(n) -> (*trasformo al volo*)
- (flin_add (flin_zero()) arg1 (rational_of_term arg2))
- |_-> (* test this *)
- let tmp = flin_of_term arg1 in
- flin_emult (rational_of_term arg2) (tmp)
- )
- else
- if fails rational_of_term arg2
- then
- (
- match arg2 with
- Cic.Rel(n) -> (*trasformo al volo*)
- (flin_add (flin_zero()) arg2 (rational_of_term arg1))
- |_-> (* test this *)
- let tmp = flin_of_term arg2 in
- flin_emult (rational_of_term arg1) (tmp)
-
- )
- else
- ( (*prodotto tra razionali*)
- (flin_add_cste (flin_zero()) (rmult (rational_of_term arg1) (rational_of_term arg2)))
- )
- (*try
- begin
- (*let a = rational_of_term arg1 in
- debug("ho fatto rational of term di "^CicPp.ppterm arg1^
- " e ho ottenuto "^string_of_int a.num^"/"^string_of_int a.den^"\n");*)
- let a = flin_of_term arg1
- try
- begin
- let b = (rational_of_term arg2) in
- debug("ho fatto rational of term di "^CicPp.ppterm arg2^
- " e ho ottenuto "^string_of_int b.num^"/"^string_of_int b.den^"\n");
- (flin_add_cste (flin_zero()) (rmult a b))
- end
- with
- _ -> debug ("ho fallito2 su "^CicPp.ppterm arg2^"\n");
- (flin_add (flin_zero()) arg2 a)
- end
- with
- _-> debug ("ho fallito1 su "^CicPp.ppterm arg1^"\n");
- (flin_add(flin_zero()) arg1 (rational_of_term arg2))
- *)
- end
- else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then
- let a=(rational_of_term (List.hd next)) in
- flin_add_cste (flin_zero()) (rinv a)
- else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then
- begin
- let b=(rational_of_term (List.hd(List.tl next))) in
- try
- begin
- let a = (rational_of_term (List.hd next)) in
- (flin_add_cste (flin_zero()) (rdiv a b))
- end
- with
- _-> (flin_add (flin_zero()) (List.hd next) (rinv b))
- end
- else assert false
- end
- |_ -> assert false
- end
- | Cic.Const (u,boh) ->
- begin
- if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then flin_one ()
- else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then flin_zero ()
- else assert false
- end
- |_-> assert false)
- with _ -> debug("eccezione = "^CicPp.ppterm t^"\n");flin_add (flin_zero()) t r1
-;;
-
-(* coq wrapper
-let flin_of_constr = flin_of_term;;
-*)
-
-(**
- Translates a flin to (c,x) list
- @param f a flin
- @return something like (c1,x1)::(c2,x2)::...::(cn,xn)
-*)
-let flin_to_alist f =
- let res=ref [] in
- Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
- !res
-;;
-
-(* Représentation des hypothèses qui sont des inéquations ou des équations.
-*)
-
-(**
- The structure for ineq
-*)
-type hineq={hname:Cic.term; (* le nom de l'hypothèse *)
- htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
- hleft:Cic.term;
- hright:Cic.term;
- hflin:flin;
- hstrict:bool}
-;;
-
-(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
-*)
-
-let ineq1_of_term (h,t) =
- match t with (* match t *)
- Cic.Appl (t1::next) ->
- let arg1= List.hd next in
- let arg2= List.hd(List.tl next) in
- (match t1 with (* match t1 *)
- Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then
- [{hname=h;
- htype="Rlt";
- hleft=arg1;
- hright=arg2;
- hflin= flin_minus (flin_of_term arg1)
- (flin_of_term arg2);
- hstrict=true}]
- else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then
- [{hname=h;
- htype="Rgt";
- hleft=arg2;
- hright=arg1;
- hflin= flin_minus (flin_of_term arg2)
- (flin_of_term arg1);
- hstrict=true}]
- else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then
- [{hname=h;
- htype="Rle";
- hleft=arg1;
- hright=arg2;
- hflin= flin_minus (flin_of_term arg1)
- (flin_of_term arg2);
- hstrict=false}]
- else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then
- [{hname=h;
- htype="Rge";
- hleft=arg2;
- hright=arg1;
- hflin= flin_minus (flin_of_term arg2)
- (flin_of_term arg1);
- hstrict=false}]
- else assert false
- | Cic.MutInd (u,i,o) ->
- if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then
- let t0= arg1 in
- let arg1= arg2 in
- let arg2= List.hd(List.tl (List.tl next)) in
- (match t0 with
- Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.r_URI then
- [{hname=h;
- htype="eqTLR";
- hleft=arg1;
- hright=arg2;
- hflin= flin_minus (flin_of_term arg1)
- (flin_of_term arg2);
- hstrict=false};
- {hname=h;
- htype="eqTRL";
- hleft=arg2;
- hright=arg1;
- hflin= flin_minus (flin_of_term arg2)
- (flin_of_term arg1);
- hstrict=false}]
- else assert false
- |_-> assert false)
- else assert false
- |_-> assert false)(* match t1 *)
- |_-> assert false (* match t *)
-;;
-(* coq wrapper
-let ineq1_of_constr = ineq1_of_term;;
-*)
-
-(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
-*)
-
-let rec print_rl l =
- match l with
- []-> ()
- | a::next -> Fourier.print_rational a ; print_string " " ; print_rl next
-;;
-
-let rec print_sys l =
- match l with
- [] -> ()
- | (a,b)::next -> (print_rl a;
- print_string (if b=true then "strict\n"else"\n");
- print_sys next)
- ;;
-
-(*let print_hash h =
- Hashtbl.iter (fun x y -> print_string ("("^"-"^","^"-"^")")) h
-;;*)
-
-let fourier_lineq lineq1 =
- let nvar=ref (-1) in
- let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
- List.iter (fun f ->
- Hashtbl.iter (fun x c ->
- try ignore(Hashtbl.find hvar x)
- with Not_found -> nvar:=(!nvar)+1;
- Hashtbl.add hvar x (!nvar);
- debug("aggiungo una var "^
- string_of_int !nvar^" per "^
- CicPp.ppterm x^"\n"))
- f.hflin.fhom)
- lineq1;
- (*print_hash hvar;*)
- debug("Il numero di incognite e' "^string_of_int (!nvar+1)^"\n");
- let sys= List.map (fun h->
- let v=Array.create ((!nvar)+1) r0 in
- Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x) <- c)
- h.hflin.fhom;
- ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
- lineq1 in
- debug ("chiamo unsolvable sul sistema di "^
- string_of_int (List.length sys) ^"\n");
- print_sys sys;
- unsolvable sys
-;;
-
-(*****************************************************************************
-Construction de la preuve en cas de succès de la méthode de Fourier,
-i.e. on obtient une contradiction.
-*)
-
-
-let _eqT = Cic.MutInd(HelmLibraryObjects.Logic.eq_URI, 0, []) ;;
-let _False = Cic.MutInd (HelmLibraryObjects.Logic.false_URI, 0, []) ;;
-let _not = Cic.Const (HelmLibraryObjects.Logic.not_URI,[]);;
-let _R0 = Cic.Const (HelmLibraryObjects.Reals.r0_URI,[]);;
-let _R1 = Cic.Const (HelmLibraryObjects.Reals.r1_URI,[]);;
-let _R = Cic.Const (HelmLibraryObjects.Reals.r_URI,[]);;
-let _Rfourier_eqLR_to_le=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"), []) ;;
-let _Rfourier_eqRL_to_le=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"), []) ;;
-let _Rfourier_ge_to_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_ge_to_le.con"), []) ;;
-let _Rfourier_gt_to_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_gt_to_lt.con"), []) ;;
-let _Rfourier_le=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_le.con"), []) ;;
-let _Rfourier_le_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_le_le.con"), []) ;;
-let _Rfourier_le_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_le_lt.con"), []) ;;
-let _Rfourier_lt=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_lt.con"), []) ;;
-let _Rfourier_lt_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_lt_le.con"), []) ;;
-let _Rfourier_lt_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_lt_lt.con"), []) ;;
-let _Rfourier_not_ge_lt = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_ge_lt.con"), []) ;;
-let _Rfourier_not_gt_le = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_gt_le.con"), []) ;;
-let _Rfourier_not_le_gt = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_le_gt.con"), []) ;;
-let _Rfourier_not_lt_ge = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_lt_ge.con"), []) ;;
-let _Rinv = Cic.Const (HelmLibraryObjects.Reals.rinv_URI, []);;
-let _Rinv_R1 = Cic.Const(HelmLibraryObjects.Reals.rinv_r1_URI, []);;
-let _Rle = Cic.Const (HelmLibraryObjects.Reals.rle_URI, []);;
-let _Rle_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_mult_inv_pos.con"), []) ;;
-let _Rle_not_lt = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_not_lt.con"), []) ;;
-let _Rle_zero_1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"), []) ;;
-let _Rle_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_zero_pos_plus1.con"), []) ;;
-let _Rlt = Cic.Const (HelmLibraryObjects.Reals.rlt_URI, []);;
-let _Rlt_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_mult_inv_pos.con"), []) ;;
-let _Rlt_not_le = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_not_le.con"), []) ;;
-let _Rlt_zero_1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"), []) ;;
-let _Rlt_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_zero_pos_plus1.con"), []) ;;
-let _Rminus = Cic.Const (HelmLibraryObjects.Reals.rminus_URI, []);;
-let _Rmult = Cic.Const (HelmLibraryObjects.Reals.rmult_URI, []);;
-let _Rnot_le_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rnot_le_le.con"), []) ;;
-let _Rnot_lt0 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rnot_lt0.con"), []) ;;
-let _Rnot_lt_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rnot_lt_lt.con"), []) ;;
-let _Ropp = Cic.Const (HelmLibraryObjects.Reals.ropp_URI, []);;
-let _Rplus = Cic.Const (HelmLibraryObjects.Reals.rplus_URI, []);;
-
-(******************************************************************************)
-
-let is_int x = (x.den)=1
-;;
-
-(* fraction = couple (num,den) *)
-let rec rational_to_fraction x= (x.num,x.den)
-;;
-
-(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
-*)
-
-let rec int_to_real_aux n =
- match n with
- 0 -> _R0 (* o forse R0 + R0 ????? *)
- | 1 -> _R1
- | _ -> Cic.Appl [ _Rplus ; _R1 ; int_to_real_aux (n-1) ]
-;;
-
-
-let int_to_real n =
- let x = int_to_real_aux (abs n) in
- if n < 0 then
- Cic.Appl [ _Ropp ; x ]
- else
- x
-;;
-
-
-(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
-*)
-
-let rational_to_real x =
- let (n,d)=rational_to_fraction x in
- Cic.Appl [ _Rmult ; int_to_real n ; Cic.Appl [ _Rinv ; int_to_real d ] ]
-;;
-
-(* preuve que 0<n*1/d
-*)
-
-let tac_zero_inf_pos (n,d) =
- let tac_zero_inf_pos (n,d) status =
- (*let cste = pf_parse_constr gl in*)
- let pall str (proof,goal) t =
- debug ("tac "^str^" :\n" );
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("th = "^ CicPp.ppterm t ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- in
- let tacn=ref (mk_tactic (fun status ->
- pall "n0" status _Rlt_zero_1 ;
- apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in
- let tacd=ref (mk_tactic (fun status ->
- pall "d0" status _Rlt_zero_1 ;
- apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in
-
-
- for i=1 to n-1 do
- tacn:=(Tacticals.then_
- ~start:(mk_tactic (fun status ->
- pall ("n"^string_of_int i) status _Rlt_zero_pos_plus1;
- apply_tactic
- (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1)
- status))
- ~continuation:!tacn);
- done;
- for i=1 to d-1 do
- tacd:=(Tacticals.then_
- ~start:(mk_tactic (fun status ->
- pall "d" status _Rlt_zero_pos_plus1 ;
- apply_tactic
- (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) status))
- ~continuation:!tacd);
- done;
-
-debug("TAC ZERO INF POS\n");
- apply_tactic
- (Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_mult_inv_pos)
- ~continuations:[!tacn ;!tacd ] )
- status
- in
- mk_tactic (tac_zero_inf_pos (n,d))
-;;
-
-
-
-(* preuve que 0<=n*1/d
-*)
-
-let tac_zero_infeq_pos gl (n,d) =
- let tac_zero_infeq_pos gl (n,d) status =
- (*let cste = pf_parse_constr gl in*)
- debug("inizio tac_zero_infeq_pos\n");
- let tacn = ref
- (*(if n=0 then
- (PrimitiveTactics.apply_tac ~term:_Rle_zero_zero )
- else*)
- (PrimitiveTactics.apply_tac ~term:_Rle_zero_1 )
- (* ) *)
- in
- let tacd=ref (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1 ) in
- for i=1 to n-1 do
- tacn:=(Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
- ~term:_Rle_zero_pos_plus1) ~continuation:!tacn);
- done;
- for i=1 to d-1 do
- tacd:=(Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
- ~term:_Rlt_zero_pos_plus1) ~continuation:!tacd);
- done;
- apply_tactic
- (Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rle_mult_inv_pos)
- ~continuations:[!tacn;!tacd]) status
- in
- mk_tactic (tac_zero_infeq_pos gl (n,d))
-;;
-
-
-
-(* preuve que 0<(-n)*(1/d) => False
-*)
-
-let tac_zero_inf_false gl (n,d) =
- let tac_zero_inf_false gl (n,d) status =
- if n=0 then
- apply_tactic (PrimitiveTactics.apply_tac ~term:_Rnot_lt0) status
- else
- apply_tactic (Tacticals.then_
- ~start:(mk_tactic (apply_tactic (PrimitiveTactics.apply_tac ~term:_Rle_not_lt)))
- ~continuation:(tac_zero_infeq_pos gl (-n,d)))
- status
- in
- mk_tactic (tac_zero_inf_false gl (n,d))
-;;
-
-(* preuve que 0<=n*(1/d) => False ; n est negatif
-*)
-
-let tac_zero_infeq_false gl (n,d) =
- let tac_zero_infeq_false gl (n,d) status =
- let (proof, goal) = status in
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
-
- debug("faccio fold di " ^ CicPp.ppterm
- (Cic.Appl
- [_Rle ; _R0 ;
- Cic.Appl
- [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]
- ]
- ) ^ "\n") ;
- debug("apply di _Rlt_not_le a "^ CicPp.ppterm ty ^"\n");
- (*CSC: Patch to undo the over-simplification of RewriteSimpl *)
- apply_tactic
- (Tacticals.then_
- ~start:
- (ReductionTactics.fold_tac
- ~reduction:(const_lazy_reduction CicReduction.whd)
- ~pattern:(ProofEngineTypes.conclusion_pattern None)
- ~term:
- (const_lazy_term
- (Cic.Appl
- [_Rle ; _R0 ;
- Cic.Appl
- [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]])))
- ~continuation:
- (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_not_le)
- ~continuation:(tac_zero_inf_pos (-n,d))))
- status
- in
- mk_tactic (tac_zero_infeq_false gl (n,d))
-;;
-
-
-(* *********** ********** ******** ??????????????? *********** **************)
-
-let apply_type_tac ~cast:t ~applist:al =
- let apply_type_tac ~cast:t ~applist:al (proof,goal) =
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,t)::metasenv in
- let proof' = curi,metasenv',_subst,pbo,pty, attrs in
- let proof'',goals =
- apply_tactic
- (PrimitiveTactics.apply_tac
- (*~term:(Cic.Appl ((Cic.Cast (Cic.Meta (fresh_meta,irl),t))::al)) *)
- ~term:(Cic.Appl ((Cic.Meta (fresh_meta,irl))::al))) (* ??? *)
- (proof',goal)
- in
- proof'',fresh_meta::goals
- in
- mk_tactic (apply_type_tac ~cast:t ~applist:al)
-;;
-
-let my_cut ~term:c =
- let my_cut ~term:c (proof,goal) =
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,c)::metasenv in
- let proof' = curi,metasenv',_subst,pbo,pty, attrs in
- let proof'',goals =
- apply_tactic
- (apply_type_tac
- ~cast:(Cic.Prod(Cic.Name "Anonymous",c,CicSubstitution.lift 1 ty))
- ~applist:[Cic.Meta(fresh_meta,irl)])
- (proof',goal)
- in
- (* We permute the generated goals to be consistent with Coq *)
- match goals with
- [] -> assert false
- | he::tl -> proof'',he::fresh_meta::tl
- in
- mk_tactic (my_cut ~term:c)
-;;
-
-let exact = PrimitiveTactics.exact_tac;;
-
-let tac_use h =
- let tac_use h status =
- let (proof, goal) = status in
- debug("Inizio TC_USE\n");
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("hname = "^ CicPp.ppterm h.hname ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- apply_tactic
- (match h.htype with
- "Rlt" -> exact ~term:h.hname
- | "Rle" -> exact ~term:h.hname
- | "Rgt" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_gt_to_lt)
- ~continuation:(exact ~term:h.hname))
- | "Rge" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_ge_to_le)
- ~continuation:(exact ~term:h.hname))
- | "eqTLR" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqLR_to_le)
- ~continuation:(exact ~term:h.hname))
- | "eqTRL" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqRL_to_le)
- ~continuation:(exact ~term:h.hname))
- | _->assert false)
- status
- in
- mk_tactic (tac_use h)
-;;
-
-let is_ineq (h,t) =
- match t with
- Cic.Appl ( Cic.Const(u,boh)::next) ->
- (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI or
- UriManager.eq u HelmLibraryObjects.Reals.rgt_URI or
- UriManager.eq u HelmLibraryObjects.Reals.rle_URI or
- UriManager.eq u HelmLibraryObjects.Reals.rge_URI then true
- else if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then
- (match (List.hd next) with
- Cic.Const (uri,_) when
- UriManager.eq uri HelmLibraryObjects.Reals.r_URI
- -> true
- | _ -> false)
- else false)
- |_->false
-;;
-
-let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
-
-let mkAppL a =
- Cic.Appl(Array.to_list a)
-;;
-
-(* Résolution d'inéquations linéaires dans R *)
-let rec strip_outer_cast c = match c with
- | Cic.Cast (c,_) -> strip_outer_cast c
- | _ -> c
-;;
-
-(*let find_in_context id context =
- let rec find_in_context_aux c n =
- match c with
- [] -> failwith (id^" not found in context")
- | a::next -> (match a with
- Some (Cic.Name(name),_) when name = id -> n
- (*? magari al posto di _ qualcosaltro?*)
- | _ -> find_in_context_aux next (n+1))
- in
- find_in_context_aux context 1
-;;
-
-(* mi sembra quadratico *)
-let rec filter_real_hyp context cont =
- match context with
- [] -> []
- | Some(Cic.Name(h),Cic.Decl(t))::next -> (
- let n = find_in_context h cont in
- debug("assegno "^string_of_int n^" a "^CicPp.ppterm t^"\n");
- [(Cic.Rel(n),t)] @ filter_real_hyp next cont)
- | a::next -> debug(" no\n"); filter_real_hyp next cont
-;;*)
-
-let filter_real_hyp context _ =
- let rec filter_aux context num =
- match context with
- [] -> []
- | Some(Cic.Name(h),Cic.Decl(t))::next ->
- [(Cic.Rel(num),t)] @ filter_aux next (num+1)
- | a::next -> filter_aux next (num+1)
- in
- filter_aux context 1
-;;
-
-
-(* lifts everithing at the conclusion level *)
-let rec superlift c n=
- match c with
- [] -> []
- | Some(name,Cic.Decl(a))::next ->
- [Some(name,Cic.Decl(CicSubstitution.lift n a))]@ superlift next (n+1)
- | Some(name,Cic.Def(a,ty))::next ->
- [Some(name,
- Cic.Def((CicSubstitution.lift n a),CicSubstitution.lift n ty))
- ] @ superlift next (n+1)
- | _::next -> superlift next (n+1) (*?? ??*)
-
-;;
-
-let equality_replace a b =
- let equality_replace a b status =
- debug("inizio EQ\n");
- let module C = Cic in
- let proof,goal = status in
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let a_eq_b = C.Appl [ _eqT ; _R ; a ; b ] in
- let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,a_eq_b)::metasenv in
- debug("chamo rewrite tac su"^CicPp.ppterm (C.Meta (fresh_meta,irl)));
- let (proof,goals) = apply_tactic
- (EqualityTactics.rewrite_simpl_tac
- ~direction:`LeftToRight
- ~pattern:(ProofEngineTypes.conclusion_pattern None)
- (C.Meta (fresh_meta,irl)) [])
- ((curi,metasenv',_subst,pbo,pty, attrs),goal)
- in
- let new_goals = fresh_meta::goals in
- debug("fine EQ -> goals : "^string_of_int( List.length new_goals) ^" = "
- ^string_of_int( List.length goals)^"+ meta\n");
- (proof,new_goals)
- in
- mk_tactic (equality_replace a b)
-;;
-
-let tcl_fail a (proof,goal) =
- match a with
- 1 -> raise (ProofEngineTypes.Fail (lazy "fail-tactical"))
- | _ -> (proof,[goal])
-;;
-
-(* Galla: moved in variousTactics.ml
-let assumption_tac (proof,goal)=
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let num = ref 0 in
- let tac_list = List.map
- ( fun x -> num := !num + 1;
- match x with
- Some(Cic.Name(nm),t) -> (nm,exact ~term:(Cic.Rel(!num)))
- | _ -> ("fake",tcl_fail 1)
- )
- context
- in
- Tacticals.first ~tactics:tac_list (proof,goal)
-;;
-*)
-(* Galla: moved in negationTactics.ml
-(* !!!!! fix !!!!!!!!!! *)
-let contradiction_tac (proof,goal)=
- Tacticals.then_
- (*inutile sia questo che quello prima della chiamata*)
- ~start:PrimitiveTactics.intros_tac
- ~continuation:(Tacticals.then_
- ~start:(VariousTactics.elim_type_tac ~term:_False)
- ~continuation:(assumption_tac))
- (proof,goal)
-;;
-*)
-
-(* ********************* TATTICA ******************************** *)
-
-let rec fourier (s_proof,s_goal)=
- let s_curi,s_metasenv,_subst,s_pbo,s_pty, attrs = s_proof in
- let s_metano,s_context,s_ty = CicUtil.lookup_meta s_goal s_metasenv in
- debug ("invoco fourier_tac sul goal "^string_of_int(s_goal)^" e contesto:\n");
- debug_pcontext s_context;
-
-(* here we need to negate the thesis, but to do this we need to apply the
- right theoreme,so let's parse our thesis *)
-
- let th_to_appl = ref _Rfourier_not_le_gt in
- (match s_ty with
- Cic.Appl ( Cic.Const(u,boh)::args) ->
- th_to_appl :=
- (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then
- _Rfourier_not_ge_lt
- else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then
- _Rfourier_not_gt_le
- else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then
- _Rfourier_not_le_gt
- else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then
- _Rfourier_not_lt_ge
- else failwith "fourier can't be applyed")
- |_-> failwith "fourier can't be applyed");
- (* fix maybe strip_outer_cast goes here?? *)
-
- (* now let's change our thesis applying the th and put it with hp *)
-
- let proof,gl = apply_tactic
- (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:!th_to_appl)
- ~continuation:(PrimitiveTactics.intros_tac ()))
- (s_proof,s_goal)
- in
- let goal = if List.length gl = 1 then List.hd gl
- else failwith "a new goal" in
-
- debug ("port la tesi sopra e la nego. contesto :\n");
- debug_pcontext s_context;
-
- (* now we have all the right environment *)
-
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
-
- (* now we want to convert hp to inequations, but first we must lift
- everyting to thesis level, so that a variable has the save Rel(n)
- in each hp ( needed by ineq1_of_term ) *)
-
- (* ? fix if None ?????*)
- (* fix change superlift with a real name *)
-
- let l_context = superlift context 1 in
- let hyps = filter_real_hyp l_context l_context in
-
- debug ("trasformo in diseq. "^ string_of_int (List.length hyps)^" ipotesi\n");
-
- let lineq =ref [] in
-
- (* transform hyps into inequations *)
-
- List.iter (fun h -> try (lineq:=(ineq1_of_term h)@(!lineq))
- with _-> ())
- hyps;
-
- debug ("applico fourier a "^ string_of_int (List.length !lineq)^
- " disequazioni\n");
-
- let res=fourier_lineq (!lineq) in
- let tac=ref Tacticals.id_tac in
- if res=[] then
- (print_string "Tactic Fourier fails.\n";flush stdout;
- failwith "fourier_tac fails")
- else
- (
- match res with (*match res*)
- [(cres,sres,lc)]->
-
- (* in lc we have the coefficient to "reduce" the system *)
-
- print_string "Fourier's method can prove the goal...\n";flush stdout;
-
- debug "I coeff di moltiplicazione rit sono: ";
-
- let lutil=ref [] in
- List.iter
- (fun (h,c) -> if c<>r0 then (lutil:=(h,c)::(!lutil);
- (* DBG *)Fourier.print_rational(c);print_string " "(* DBG *))
- )
- (List.combine (!lineq) lc);
-
- print_string (" quindi lutil e' lunga "^
- string_of_int (List.length (!lutil))^"\n");
-
- (* on construit la combinaison linéaire des inéquation *)
-
- (match (!lutil) with (*match (!lutil) *)
- (h1,c1)::lutil ->
- debug ("elem di lutil ");Fourier.print_rational c1;print_string "\n";
-
- let s=ref (h1.hstrict) in
-
-
- let t1 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hleft] ) in
- let t2 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hright]) in
-
- List.iter (fun (h,c) ->
- s:=(!s)||(h.hstrict);
- t1:=(Cic.Appl [_Rplus;!t1;Cic.Appl
- [_Rmult;rational_to_real c;h.hleft ] ]);
- t2:=(Cic.Appl [_Rplus;!t2;Cic.Appl
- [_Rmult;rational_to_real c;h.hright] ]))
- lutil;
-
- let ineq=Cic.Appl [(if (!s) then _Rlt else _Rle);!t1;!t2 ] in
- let tc=rational_to_real cres in
-
-
-(* ora ho i termini che descrivono i passi di fourier per risolvere il sistema *)
-
- debug "inizio a costruire tac1\n";
- Fourier.print_rational(c1);
-
- let tac1=ref ( mk_tactic (fun status ->
- apply_tactic
- (if h1.hstrict then
- (Tacticals.thens
- ~start:(mk_tactic (fun status ->
- debug ("inizio t1 strict\n");
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("th = "^ CicPp.ppterm _Rfourier_lt ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- apply_tactic
- (PrimitiveTactics.apply_tac ~term:_Rfourier_lt) status))
- ~continuations:[tac_use h1;
- tac_zero_inf_pos (rational_to_fraction c1)])
- else
- (Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le)
- ~continuations:[tac_use h1;tac_zero_inf_pos
- (rational_to_fraction c1)]))
- status))
-
- in
- s:=h1.hstrict;
- List.iter (fun (h,c) ->
- (if (!s) then
- (if h.hstrict then
- (debug("tac1 1\n");
- tac1:=(Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_lt_lt)
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)]))
- else
- (debug("tac1 2\n");
- Fourier.print_rational(c1);
- tac1:=(Tacticals.thens
- ~start:(mk_tactic (fun status ->
- debug("INIZIO TAC 1 2\n");
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("th = "^ CicPp.ppterm _Rfourier_lt_le ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- apply_tactic
- (PrimitiveTactics.apply_tac ~term:_Rfourier_lt_le)
- status))
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)])))
- else
- (if h.hstrict then
- (debug("tac1 3\n");
- tac1:=(Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_lt)
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)]))
- else
- (debug("tac1 4\n");
- tac1:=(Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_le)
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)]))));
- s:=(!s)||(h.hstrict)) (* end fun -> *)
- lutil;(*end List.iter*)
-
- let tac2 =
- if sres then
- tac_zero_inf_false goal (rational_to_fraction cres)
- else
- tac_zero_infeq_false goal (rational_to_fraction cres)
- in
- tac:=(Tacticals.thens
- ~start:(my_cut ~term:ineq)
- ~continuations:[Tacticals.then_
- ~start:( mk_tactic (fun status ->
- let (proof, goal) = status in
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- apply_tactic
- (ReductionTactics.change_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty))
- (const_lazy_term (Cic.Appl [ _not; ineq])))
- status))
- ~continuation:(Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:
- (if sres then _Rnot_lt_lt else _Rnot_le_le))
- ~continuation:(Tacticals.thens
- ~start:(mk_tactic (fun status ->
- debug("t1 ="^CicPp.ppterm !t1 ^"t2 ="^
- CicPp.ppterm !t2 ^"tc="^ CicPp.ppterm tc^"\n");
- let r = apply_tactic
- (equality_replace (Cic.Appl [_Rminus;!t2;!t1] ) tc)
- status
- in
- (match r with (p,gl) ->
- debug("eq1 ritorna "^string_of_int(List.length gl)^"\n" ));
- r))
- ~continuations:[(Tacticals.thens
- ~start:(mk_tactic (fun status ->
- let r = apply_tactic
- (equality_replace (Cic.Appl[_Rinv;_R1]) _R1)
- status
- in
- (match r with (p,gl) ->
- debug("eq2 ritorna "^string_of_int(List.length gl)^"\n" ));
- r))
- ~continuations:
- [PrimitiveTactics.apply_tac ~term:_Rinv_R1;
- Tacticals.first
- ~tactics:[Ring.ring_tac; Tacticals.id_tac]
- ])
- ;(*Tacticals.id_tac*)
- Tacticals.then_
- ~start:(mk_tactic (fun status ->
- let (proof, goal) = status in
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- (* check if ty is of type *)
- let w1 =
- debug("qui c'e' gia' l'or "^CicPp.ppterm ty^"\n");
- (match ty with
- Cic.Prod (Cic.Anonymous,a,b) -> (Cic.Appl [_not;a])
- |_ -> assert false)
- in
- let r = apply_tactic
- (ReductionTactics.change_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty))
- (const_lazy_term w1)) status
- in
- debug("fine MY_CHNGE\n");
- r))
- ~continuation:(*PORTINGTacticals.id_tac*)tac2]))
- ;(*Tacticals.id_tac*)!tac1]);(*end tac:=*)
-
- |_-> assert false)(*match (!lutil) *)
- |_-> assert false); (*match res*)
- debug ("finalmente applico tac\n");
- (
- let r = apply_tactic !tac (proof,goal) in
- debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r
-
- )
-;;
-
-let fourier_tac = mk_tactic fourier
-
-
+++ /dev/null
-(*
-val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic
-val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
-*)
-val fourier_tac: ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module PEH = ProofEngineHelpers
-module U = CicUniv
-module TC = CicTypeChecker
-module PET = ProofEngineTypes
-module S = CicSubstitution
-module PT = PrimitiveTactics
-module T = Tacticals
-module FNG = FreshNamesGenerator
-module MI = CicMkImplicit
-module PESR = ProofEngineStructuralRules
-module HEL = HExtlib
-
-let fail_msg0 = "unexported clearbody: invalid argument"
-let fail_msg2 = "fwd: no applicable simplification"
-
-let error msg = raise (PET.Fail (lazy msg))
-
-(* unexported tactics *******************************************************)
-
-let id_tac =
- let id_tac (proof,goal) =
- try
- let _, metasenv, _subst, _, _, _ = proof in
- let _, _, _ = CicUtil.lookup_meta goal metasenv in
- (proof,[goal])
- with CicUtil.Meta_not_found _ -> (proof, [])
- in
- PET.mk_tactic id_tac
-
-let clearbody ~index =
- let rec find_name index = function
- | Some (Cic.Name name, _) :: _ when index = 1 -> name
- | _ :: tail when index > 1 -> find_name (pred index) tail
- | _ -> error fail_msg0
- in
- let clearbody status =
- let (proof, goal) = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- PET.apply_tactic (PESR.clearbody ~hyp:(find_name index context)) status
- in
- PET.mk_tactic clearbody
-
-(* lapply *******************************************************************)
-
-let strip_prods metasenv context ?how_many to_what term =
- let irl = MI.identity_relocation_list_for_metavariable context in
- let mk_meta metasenv its_type =
- let index = MI.new_meta metasenv [] in
- let metasenv = [index, context, its_type] @ metasenv in
- metasenv, Cic.Meta (index, irl), index
- in
- let update_counters = function
- | None, [] -> None, false, id_tac, []
- | None, to_what :: tail -> None, true, PT.apply_tac ~term:to_what, tail
- | Some hm, [] -> Some (pred hm), false, id_tac, []
- | Some hm, to_what :: tail -> Some (pred hm), true, PT.apply_tac ~term:to_what, tail
- in
- let rec aux metasenv metas conts tw = function
- | Some hm, _ when hm <= 0 -> metasenv, metas, conts
- | xhm, Cic.Prod (Cic.Name _, t1, t2) ->
- let metasenv, meta, index = mk_meta metasenv t1 in
- aux metasenv (meta :: metas) (conts @ [id_tac, index]) tw (xhm, (S.subst meta t2))
- | xhm, Cic.Prod (Cic.Anonymous, t1, t2) ->
- let xhm, pos, tac, tw = update_counters (xhm, tw) in
- let metasenv, meta, index = mk_meta metasenv t1 in
- let conts = if pos then (tac, index) :: conts else conts @ [tac, index] in
- aux metasenv (meta :: metas) conts tw (xhm, (S.subst meta t2))
- | _, t -> metasenv, metas, conts
- in
- aux metasenv [] [] to_what (how_many, term)
-
-let get_clearables context terms =
- let aux = function
- | Cic.Rel i
- | Cic.Appl (Cic.Rel i :: _) -> PEH.get_name context i
- | _ -> None
- in
- HEL.list_rev_map_filter aux terms
-
-let lapply_tac_aux ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- (* ?(substs = []) *) ?how_many ?(to_what = []) what =
- let letin_tac term = PT.letin_tac ~mk_fresh_name_callback term in
- let lapply_tac (proof, goal) =
- let xuri, metasenv, _subst, u, t, attrs = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- let lemma, _ = TC.type_of_aux' metasenv context what U.oblivion_ugraph in
- let lemma = FNG.clean_dummy_dependent_types lemma in
- let metasenv, metas, conts = strip_prods metasenv context ?how_many to_what lemma in
- let conclusion =
- match metas with [] -> what | _ -> Cic.Appl (what :: List.rev metas)
- in
- let tac =
- T.then_ ~start:(letin_tac conclusion)
- ~continuation:(clearbody ~index:1)
- in
- let proof = (xuri, metasenv, _subst, u, t, attrs) in
- let aux (proof, goals) (tac, goal) =
- let proof, new_goals = PET.apply_tactic tac (proof, goal) in
- proof, goals @ new_goals
- in
- List.fold_left aux (proof, []) ((tac, goal) :: conts)
- in
- PET.mk_tactic lapply_tac
-
-let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- (* ?(substs = []) *) ?(linear = false) ?how_many ?(to_what = []) what =
- let lapply_tac status =
- let proof, goal = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- let lapply = lapply_tac_aux ~mk_fresh_name_callback ?how_many ~to_what what in
- let tac =
- if linear then
- let hyps = get_clearables context (what :: to_what) in
- T.then_ ~start:lapply
- ~continuation:(PESR.clear ~hyps) (* T.try_tactic ~tactic: *)
- else
- lapply
- in
- PET.apply_tactic tac status
- in
- PET.mk_tactic lapply_tac
-
-(* fwd **********************************************************************)
-
-let fwd_simpl_tac
- ?(mk_fresh_name_callback = FNG.mk_fresh_name ~subst:[])
- ~dbd hyp =
-assert false (* MATITA 1.0
- let lapply_tac to_what lemma =
- lapply_tac ~mk_fresh_name_callback ~how_many:1 ~to_what:[to_what] lemma
- in
- let fwd_simpl_tac status =
- let (proof, goal) = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, context, ty = CicUtil.lookup_meta goal metasenv in
- let index, major = PEH.lookup_type metasenv context hyp in
- match FwdQueries.fwd_simpl ~dbd major with
- | [] -> error fail_msg2
- | uri :: _ ->
- Printf.eprintf "fwd: %s\n" (UriManager.string_of_uri uri); flush stderr;
- let start = lapply_tac (Cic.Rel index) (Cic.Const (uri, [])) in
- let tac = T.then_ ~start ~continuation:(PESR.clear ~hyps:[hyp]) in
- PET.apply_tactic tac status
- in
- PET.mk_tactic fwd_simpl_tac
- *)
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val lapply_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?linear:bool -> ?how_many:int -> ?to_what:Cic.term list -> Cic.term ->
- ProofEngineTypes.tactic
-
-val fwd_simpl_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- dbd:HSql.dbd -> string -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*********************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti *)
-(* 8/09/2004 *)
-(* *)
-(* *)
-(*********************************************************************)
-
-(* $Id$ *)
-
-(* the file contains an hash table of objects of the library
- equivalent to some object in the standard subset; it is
- mostly used to filter useless cases in auto *)
-
-
-let equivalent_objects =
-(* finte costanti; i.e. costanti senza corpo *)
-[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack0.con"(*,"finte costanti"*);
- UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ac10.con"(*,"finte costanti"*);
- UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack2.con"(*,"finte costanti"*)
- ]@
-(* inutili mostri *)
-[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg0.con"(*,"useless monster"*);
- UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg1.con"(*,"useless monster"*);
- UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/ResAck0.con"(*,"useless monster"*)
- ]@
-(* istanze *)
- (UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"*))::
-[
-UriManager.uri_of_string "cic:/Paris/ZF/src/useful/lem_iff_sym.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/iff_sym.con"*);
-UriManager.uri_of_string "cic:/Lyon/AUTOMATA/Ensf_types/False_imp_P.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/Rfunctions/sum_f_R0_triangle.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Misc/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_not_and.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/or_not_and.con"*);
-UriManager.uri_of_string "cic:/Rocq/DEMOS/Sorting/diff_true_false.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/diff_true_false.con"*);
-UriManager.uri_of_string "cic:/CoRN/metrics/CMetricSpaces/nz.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Max/le_max_l.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/Decidable/not_or.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*);
-UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_eq.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_sqrt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_def.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eqT2eq.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_eq_0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rsqr_0_uniq.con"*);
-UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/en_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_10.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_pos.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*);
-UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/le.ind#xpointer(1/1/1)"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_n_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"*);
-UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor1.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_diag_eq_mult_2.con"*);
-UriManager.uri_of_string "cic:/Coq/Relations/Newman/caseRxy.con"(*,UriManager.uri_of_string "cic:/Coq/Relations/Newman/Ind_proof.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/S_plus_r.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_n_Sm.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zmult_ab0a0b0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_integral.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax8.con"(*,UriManager.uri_of_string "cic:/Coq/NArith/BinPos/ZC2.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/Zlt_reg_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat_l.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*);
-UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_1.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Classic.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_pos_lt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_sqr.con"*);
-UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo_def/sin_antisym.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo/sin_neg.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/false_implies_everything.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*);
-UriManager.uri_of_string "cic:/Coq/ring/Setoid_ring_normalize/index_eq_prop.con"(*,UriManager.uri_of_string "cic:/Coq/ring/Ring_normalize/index_eq_prop.con"*);
-UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_pred.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_pred.con"*);
-UriManager.uri_of_string "cic:/Lannion/continuations/FOUnify_cps/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*);
-UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_right.con"(*,UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_cons.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_compat_l.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rplus_lt_0_compat.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/DiscrR/Rplus_lt_pos.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*);
-UriManager.uri_of_string "cic:/CoRN/fta/KeyLemma/lem_1c.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*);
-UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA20.con"(*,UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA17.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_2.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/injective_projections.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*);
-UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zle_lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_lt_compat.con"*);
-UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*);
-UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/not_gt_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_gt.con"*);
-UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*);
-UriManager.uri_of_string "cic:/CoRN/algebra/Basics/lt_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_lt_compat_r.con"*);
-UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_neg.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_non_eq.con"*);
-UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_Sn_m.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Qhomographic_Qpositive_to_Qpositive/one_non_negative.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zle_0_1.con"*);
-UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rle_0_1.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/proof_irrel.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*);
-UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_eq.con"*);
-UriManager.uri_of_string "cic:/Coq/IntMap/Mapiter/pair_sp.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/ProofIrrelevance/proof_irrelevance_cci.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_or_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_and_or.con"*);
-UriManager.uri_of_string "cic:/CoRN/model/structures/Zsec/Zplus_wd0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_eq_compat.con"*);
-UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor6.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_0_r_reverse.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/S_inj.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*);
-UriManager.uri_of_string "cic:/Coq/ZArith/Wf_Z/Z_of_nat_complete.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/IZN.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_orb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/orb_comm.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/PartSum/plus_sum.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Cauchy_prod/sum_plus.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Qpositive/minus_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*);
-UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_zero.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1_auto/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_andb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/andb_comm.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/canonicite/Prelude0/Morgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/TrueP.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/FalseP.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zminus_eq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zminus_eq.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_1.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*);
-UriManager.uri_of_string "cic:/Orsay/Maths/divide/Zabs_ind.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_ind.con"*);
-UriManager.uri_of_string "cic:/CoRN/algebra/Basics/Zmult_minus_distr_r.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_minus_distr_l.con"*);
-UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/Sn_eq_Sm_n_eq_m.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*);
-UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"*);
-UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA2.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/P_Rmin.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/P_Rmin.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Huffman/Aux/le_minus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*);
-UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_O_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_l.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/Berardi/inv2.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Berardi/AC.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/SeqProp/not_Rlt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rnot_lt_ge.con"*);
-UriManager.uri_of_string "cic:/Nancy/FOUnify/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_le_0_compat.con"*);
-UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le_sym.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_Zmult.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_n_O.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*);
-UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_mult.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat.con"*);
-UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_true2.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_left.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_l.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax3.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zgt_pos_0.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_triangle.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Buchberger/Buch/Sdep.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/prod_ind.con"*);
-UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rsum_abs.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*);
-UriManager.uri_of_string "cic:/Cachan/SMC/mu/minus_n_m_le_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*);
-UriManager.uri_of_string "cic:/Marseille/GC/lib_arith/lib_S_pred/eqnm_eqSnSm.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/predminus1.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/pred_of_minus.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/Rpower_pow.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/Rpower_pow.con"*);
-UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*);
-UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_neq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zlt_not_eq.con"*);
-UriManager.uri_of_string "cic:/Coq/Arith/Lt/nat_total_order.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_eq.con"*);
-UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/2)"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/1)"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zmult_pos_pos.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_O_compat.con"*);
-UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zlt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat.con"*);
-UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/pred_ext_and_rel_choice_imp_EM.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*);
-UriManager.uri_of_string "cic:/Sophia-Antipolis/Rsa/MiscRsa/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*)
-]
-;;
-
-let equiv_table = Hashtbl.create 503
-;;
-
-let _ = List.iter (fun a -> Hashtbl.add equiv_table a "") equivalent_objects
-;;
-
-let not_a_duplicate u =
- try
- ignore(Hashtbl.find equiv_table u); false
- with
- Not_found -> true
-;;
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*********************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti *)
-(* 8/09/2004 *)
-(* *)
-(* *)
-(*********************************************************************)
-
-
-val not_a_duplicate : UriManager.uri -> bool
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-exception History_failure
-
-class ['a] history size =
- let unsome = function Some x -> x | None -> assert false in
- object (self)
-
- val history_data = Array.create (size + 1) None
-
- val mutable history_hd = 0 (* rightmost index *)
- val mutable history_cur = 0 (* current index *)
- val mutable history_tl = 0 (* leftmost index *)
-
- method private is_empty = history_data.(history_cur) = None
-
- method push (status: 'a) =
- if self#is_empty then
- history_data.(history_cur) <- Some status
- else begin
- history_cur <- (history_cur + 1) mod size;
- history_data.(history_cur) <- Some status;
- history_hd <- history_cur; (* throw away fake future line *)
- if history_hd = history_tl then (* tail overwritten *)
- history_tl <- (history_tl + 1) mod size
- end
-
- method undo = function
- | 0 -> unsome history_data.(history_cur)
- | steps when steps > 0 ->
- let max_undo_steps =
- if history_cur >= history_tl then
- history_cur - history_tl
- else
- history_cur + (size - history_tl)
- in
- if steps > max_undo_steps then
- raise History_failure;
- history_cur <- history_cur - steps;
- if history_cur < 0 then (* fix underflow *)
- history_cur <- size + history_cur;
- unsome history_data.(history_cur)
- | steps (* when steps > 0 *) -> self#redo ~-steps
-
- method redo = function
- | 0 -> unsome history_data.(history_cur)
- | steps when steps > 0 ->
- let max_redo_steps =
- if history_hd >= history_cur then
- history_hd - history_cur
- else
- history_hd + (size - history_cur)
- in
- if steps > max_redo_steps then
- raise History_failure;
- history_cur <- (history_cur + steps) mod size;
- unsome history_data.(history_cur)
- | steps (* when steps > 0 *) -> self#undo ~-steps
-
- end
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-exception History_failure
-
-class ['a] history :
- int ->
- object
- method push : 'a -> unit
- method redo : int -> 'a
- method undo : int -> 'a
- end
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let fake_constructor_tac ~n (proof, goal) =
- let module C = Cic in
- let module R = CicReduction in
- let (_,metasenv,_subst,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- match (R.whd context ty) with
- (C.MutInd (uri, typeno, exp_named_subst))
- | (C.Appl ((C.MutInd (uri, typeno, exp_named_subst))::_)) ->
- ProofEngineTypes.apply_tactic (
- PrimitiveTactics.apply_tac
- ~term: (C.MutConstruct (uri, typeno, n, exp_named_subst)))
- (proof, goal)
- | _ -> raise (ProofEngineTypes.Fail (lazy "Constructor: failed"))
-;;
-
-let constructor_tac ~n = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n)
-
-let exists_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;;
-let split_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;;
-let left_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;;
-let right_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:2) ;;
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val constructor_tac: n:int -> ProofEngineTypes.tactic
-
-val exists_tac: ProofEngineTypes.tactic
-val split_tac: ProofEngineTypes.tactic
-val left_tac: ProofEngineTypes.tactic
-val right_tac: ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
-*
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple
-exception NotAnInductiveTypeToEliminate
-
-let debug = false;;
-let debug_print =
- fun msg -> if debug then prerr_endline (Lazy.force msg) else ()
-
-
-let inside_obj = function
- | Cic.InductiveDefinition (type_list,params, nleft, _) ->
- (type_list,params,nleft)
- | _ -> raise (Invalid_argument "Errore in inside_obj")
-
-let term_to_list = function
- | Cic.Appl l -> l
- | _ -> raise (Invalid_argument "Errore in term_to_list")
-
-
-let rec baseuri_of_term = function
- | Cic.Appl l -> baseuri_of_term (List.hd l)
- | Cic.MutInd (baseuri, tyno, []) -> baseuri
- | _ -> raise (Invalid_argument "baseuri_of_term")
-
-(* returns DX1 = DX1 -> ... DXn=DXn -> GOALTY *)
-let rec foo_cut nleft parameters parameters_ty body uri_of_eq selections =
- if nleft > 0
- then
- foo_cut (nleft-1) (List.tl parameters) (List.tl parameters_ty) body
- uri_of_eq selections
- else
- match parameters,selections with
- | hd::tl, x::xs when x ->
- Cic.Prod (
- Cic.Anonymous,
- Cic.Appl[Cic.MutInd (uri_of_eq ,0,[]);
- (List.hd parameters_ty) ; hd; hd],
- foo_cut nleft (List.map (CicSubstitution.lift 1) tl)
- (List.map (CicSubstitution.lift 1) (List.tl parameters_ty))
- (CicSubstitution.lift 1 body) uri_of_eq xs)
- | hd::tl,x::xs ->
- foo_cut nleft tl (List.tl parameters_ty) body uri_of_eq xs
- | [],[] -> body
- | _ -> raise (Invalid_argument "inverter: the selection doesn't match the arity of the specified inductive type")
-;;
-
-(* from a complex Cic.Prod term, return the list of its components *)
-let rec get_sort_type term =
- match term with
- | Cic.Prod (_,src,tgt) -> (get_sort_type tgt)
- | _ -> term
-;;
-
-
-let rec cut_first n l =
- if n>0 then
- match l with
- | hd::tl -> cut_first (n-1) tl
- | [] -> []
- else l
-;;
-
-
-let rec cut_last l =
- match l with
- | hd::tl when tl != [] -> hd:: (cut_last tl)
- | _ -> []
-;;
-
-(* returns the term to apply*)
-let foo_appl nleft nright_consno term uri =
- let l = [] in
- let a = ref l in
- for n = 1 to nleft do
- a := !a @ [(Cic.Implicit None)]
- done;
- a:= !a @ [term];
- for n = 1 to nright_consno do
- a := !a @ [(Cic.Implicit None)]
- done;
- (* apply i_ind ? ... ? H *)
- Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1])
-;;
-
-
-(* induction/inversion, abbastanza semplicemente, consiste nel generare i prod
- * delle uguaglianze corrispondenti ai soli parametri destri appartenenti all'insieme S.
- * Attenzione al caso base: cos'e` replace_lifting?
- * S = {} e` il principio di induzione
- * S = insieme_dei_destri e` il principio di inversione *)
-let rec foo_prod nright right_param_tys rightparameters l2 base_rel goalty
- uri_of_eq rightparameters_ termty isSetType term selections selections_ =
- match right_param_tys, selections with
- | hd::tl, x::xs when x -> Cic.Prod (
- Cic.Anonymous,
- Cic.Appl
- [Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd rightparameters);
- Cic.Rel base_rel],
- foo_prod (nright-1)
- (List.map (CicSubstitution.lift 1) tl)
- (List.map (CicSubstitution.lift 1) (List.tl rightparameters))
- (List.map (CicSubstitution.lift 1) l2)
- base_rel (CicSubstitution.lift 1 goalty) uri_of_eq
- (List.map (CicSubstitution.lift 1) rightparameters_)
- (CicSubstitution.lift 1 termty)
- isSetType (CicSubstitution.lift 1 term)) xs selections_
- | hd::tl, x::xs ->
- foo_prod (nright-1) tl (List.tl rightparameters) l2
- (base_rel-1) goalty uri_of_eq rightparameters_ termty
- isSetType term xs selections_
- | [],[] ->
- ProofEngineReduction.replace_lifting
- ~equality:(fun _ -> CicUtil.alpha_equivalence)
- ~context:[]
- ~what: (if isSetType
- then rightparameters_ @ [term]
- else rightparameters_ )
- ~with_what: (List.map (CicSubstitution.lift (-1)) l2)
- ~where:goalty
- | _ -> raise (Invalid_argument "inverter: the selection doesn't match the arity of the specified inductive type")
-(* the same subterm of goalty could be simultaneously sx and dx!*)
-;;
-
-(* induction/inversion, abbastanza semplicemente, consiste nel generare i lambda
- * soltanto per i parametri destri appartenenti all'insieme S.
- * Warning: non ne sono piu` cosi` sicuro...
- * S = {} e` il principio di induzione
- * S = insieme_dei_destri e` il principio di inversione *)
-let rec foo_lambda nright right_param_tys nright_ right_param_tys_
- rightparameters created_vars base_rel goalty uri_of_eq rightparameters_
- termty isSetType term selections =
- match right_param_tys with
- | hd::tl -> Cic.Lambda (
- (Cic.Name ("lambda" ^ (string_of_int nright))),
- hd, (* type *)
- foo_lambda (nright-1)
- (List.map (CicSubstitution.lift 1) tl) nright_
- (List.map (CicSubstitution.lift 1) right_param_tys_)
- (List.map (CicSubstitution.lift 1) rightparameters)
- (List.map (CicSubstitution.lift 1) (created_vars @ [Cic.Rel 1]))
- base_rel (CicSubstitution.lift 1 goalty) uri_of_eq
- (List.map (CicSubstitution.lift 1) rightparameters_)
- (CicSubstitution.lift 1 termty) isSetType
- (CicSubstitution.lift 1 term)) selections
- | [] when isSetType -> Cic.Lambda (
- (Cic.Name ("lambda" ^ (string_of_int nright))),
- (ProofEngineReduction.replace_lifting
- ~equality:(fun _ -> CicUtil.alpha_equivalence)
- ~context:[]
- ~what: (rightparameters_ )
- ~with_what: (List.map (CicSubstitution.lift (-1)) created_vars)
- ~where:termty), (* type of H with replaced right parameters *)
- foo_prod nright_ (List.map (CicSubstitution.lift 1) right_param_tys_)
- (List.map (CicSubstitution.lift 1) rightparameters)
- (List.map (CicSubstitution.lift 1) (created_vars @ [Cic.Rel 1]))
- (base_rel+1) (CicSubstitution.lift 1 goalty) uri_of_eq
- (List.map (CicSubstitution.lift 1) rightparameters_)
- (CicSubstitution.lift 1 termty) isSetType
- (CicSubstitution.lift 1 term)) selections selections
- | [] -> foo_prod nright_ right_param_tys_ rightparameters created_vars
- base_rel goalty uri_of_eq rightparameters_
- termty isSetType term selections selections
-;;
-
-let isSetType paramty = ((Pervasives.compare
- (get_sort_type paramty)
- (Cic.Sort Cic.Prop)) != 0)
-
-exception EqualityNotDefinedYet
-let private_inversion_tac ~term selections =
- let module T = CicTypeChecker in
- let module R = CicReduction in
- let module C = Cic in
- let module P = PrimitiveTactics in
- let module PET = ProofEngineTypes in
- let private_inversion_tac ~term (proof, goal) =
-
- (*DEBUG*) debug_print (lazy ("private inversion begins"));
- let _,metasenv,_subst,_,_, _ = proof in
- let uri_of_eq =
- match LibraryObjects.eq_URI () with
- None -> raise EqualityNotDefinedYet
- | Some uri -> uri
- in
- let (_,context,goalty) = CicUtil.lookup_meta goal metasenv in
- let termty,_ = T.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
- let uri = baseuri_of_term termty in
- let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- let (_,_,typeno,_) =
- match termty with
- C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
- | C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::args) ->
- (uri,exp_named_subst,typeno,args)
- | _ -> raise NotAnInductiveTypeToEliminate
- in
- let buri = UriManager.buri_of_uri uri in
- let name,nleft,paramty,cons_list =
- match o with
- C.InductiveDefinition (tys,_,nleft,_) ->
- let (name,_,paramty,cons_list) = List.nth tys typeno in
- (name,nleft,paramty,cons_list)
- |_ -> assert false
- in
- let eliminator_uri =
- UriManager.uri_of_string (buri ^ "/" ^ name ^ "_ind" ^ ".con")
- in
- let parameters = (List.tl (term_to_list termty)) in
- let parameters_tys =
- (List.map
- (fun t -> (
- match (T.type_of_aux' metasenv context t CicUniv.oblivion_ugraph) with
- (term,graph) -> term))
- parameters)
- in
- let consno = List.length cons_list in
- let nright= ((List.length parameters)- nleft) in
- let isSetType = isSetType paramty in
- let cut_term = foo_cut nleft parameters
- parameters_tys goalty uri_of_eq selections in
- (*DEBUG*) debug_print (lazy ("cut term " ^ CicPp.ppterm cut_term));
- debug_print (lazy ("CONTEXT before apply HCUT: " ^
- (CicMetaSubst.ppcontext ~metasenv [] context )));
- debug_print (lazy ("termty " ^ CicPp.ppterm termty));
- (* cut DXn=DXn \to GOAL *)
- let proof1,gl1 = PET.apply_tactic (P.cut_tac cut_term) (proof,goal) in
- (* apply Hcut ; reflexivity *)
- let proof2, gl2 = PET.apply_tactic
- (Tacticals.then_
- ~start: (P.apply_tac (C.Rel 1)) (* apply Hcut *)
- ~continuation: (EqualityTactics.reflexivity_tac)
- ) (proof1, (List.hd gl1))
- in
- (*DEBUG*) debug_print (lazy ("after apply HCUT;reflexivity
- in private inversion"));
- (* apply (ledx_ind( lambda x. lambda y, ...)) *)
- let t1,metasenv,_subst,t3,t4, attrs = proof2 in
- let goal2 = List.hd (List.tl gl1) in
- let (_,context,g2ty) = CicUtil.lookup_meta goal2 metasenv in
- (* rightparameters type list *)
- let rightparam_ty_l = (cut_first nleft parameters_tys) in
- (* rightparameters list *)
- let rightparameters= cut_first nleft parameters in
- debug_print
- (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl rightparameters))));
- let lambda_t = foo_lambda nright rightparam_ty_l nright rightparam_ty_l
- rightparameters [] nright goalty uri_of_eq rightparameters termty isSetType
- term selections in
- let t = foo_appl nleft (nright+consno) lambda_t eliminator_uri in
- debug_print (lazy ("Lambda_t: " ^ (CicPp.ppterm t)));
- debug_print (lazy ("Term: " ^ (CicPp.ppterm termty)));
- debug_print (lazy ("Body: " ^ (CicPp.ppterm goalty)));
- debug_print
- (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl rightparameters))));
- debug_print (lazy ("CONTEXT before refinement: " ^
- (CicMetaSubst.ppcontext ~metasenv [] context )));
- (*DEBUG*) debug_print (lazy ("private inversion: term before refinement: " ^
- CicPp.ppterm t));
- let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t
- CicUniv.oblivion_ugraph
- in
- (*DEBUG*) debug_print (lazy ("private inversion: termine after refinement: "
- ^ CicPp.ppterm ref_t));
- let proof2 = (t1,metasenv'',_subst,t3,t4, attrs) in
- let my_apply_tac =
- let my_apply_tac status =
- let proof,goals =
- ProofEngineTypes.apply_tactic (P.apply_tac ref_t) status in
- let patched_new_goals =
- let (_,metasenv''',_subst,_,_, _) = proof in
- let new_goals = ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:metasenv''
- in
- List.filter (function i -> List.exists (function (j,_,_) -> j=i)
- metasenv''') new_goals @ goals
- in
- proof,patched_new_goals
- in
- ProofEngineTypes.mk_tactic my_apply_tac
- in
- let proof3,gl3 =
- PET.apply_tactic
- (Tacticals.then_
- ~start:my_apply_tac
- ~continuation:
- (ReductionTactics.simpl_tac (ProofEngineTypes.conclusion_pattern(None))))
- (proof2,goal2)
- in
-
- (proof3, gl3)
-in
-ProofEngineTypes.mk_tactic (private_inversion_tac ~term)
-;;
-
-
-let inversion_tac ~term =
- let module T = CicTypeChecker in
- let module R = CicReduction in
- let module C = Cic in
- let module P = PrimitiveTactics in
- let module PET = ProofEngineTypes in
- let inversion_tac ~term (proof, goal) =
- (*DEBUG*) debug_print (lazy ("inversion begins"));
- let _,metasenv,_subst,_,_, _ = proof in
- let (_,context,goalty) = CicUtil.lookup_meta goal metasenv in
- let termty,_ = T.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
- let uri, typeno =
- match termty with
- | Cic.MutInd (uri,typeno,_)
- | Cic.Appl(Cic.MutInd (uri,typeno,_)::_) -> uri,typeno
- | _ -> assert false
- in
- (* let uri = baseuri_of_term termty in *)
- let obj,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- let name,nleft,arity,cons_list =
- match obj with
- Cic.InductiveDefinition (tys,_,nleft,_) ->
- let (name,_,arity,cons_list) = List.nth tys typeno in
- (name,nleft,arity,cons_list)
- |_ -> assert false
- in
- let buri = UriManager.buri_of_uri uri in
- let inversor_uri =
- UriManager.uri_of_string (buri ^ "/" ^ name ^ "_inv" ^ ".con") in
- (* arity length = number of parameters plus 1 *)
- let arity_length = (List.length (term_to_list termty)) in
- (* Check the existence of any right parameter. *)
- assert (arity_length > (nleft + 1));
- let appl_term arity_consno uri =
- let l = [] in
- let a = ref l in
- for n = 1 to arity_consno do
- a := (Cic.Implicit None)::(!a)
- done;
- (* apply i_inv ? ...? H). *)
- Cic.Appl ([Cic.Const(uri,[])] @ !a @ [term])
- in
- let t = appl_term (arity_length + (List.length cons_list)) inversor_uri in
- let (t1,metasenv,_subst,t3,t4, attrs) = proof in
- let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t
- CicUniv.oblivion_ugraph
- in
- let proof = (t1,metasenv'',_subst,t3,t4, attrs) in
- let proof3,gl3 =
- ProofEngineTypes.apply_tactic (P.apply_tac ref_t) (proof,goal) in
- let patched_new_goals =
- let (_,metasenv''',_subst,_,_, _) = proof3 in
- let new_goals = ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:metasenv''
- in
- List.filter (function i -> List.exists (function (j,_,_) -> j=i)
- metasenv''') new_goals @ gl3
- in
- (proof3, patched_new_goals)
- in
-ProofEngineTypes.mk_tactic (inversion_tac ~term)
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val isSetType: Cic.term -> bool
-exception EqualityNotDefinedYet (* raised by private_inversion_tac only *)
-val private_inversion_tac: term: Cic.term -> bool list -> ProofEngineTypes.tactic
-val inversion_tac: term: Cic.term -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-let debug = false;;
-let debug_print =
- fun msg -> if debug then prerr_endline (Lazy.force msg) else ()
-
-(* cuts away the last element of a list 'l' *)
-let rec cut_last l =
- match l with
- | hd::tl when tl != [] -> hd:: (cut_last tl)
- | _ -> []
-;;
-
-(* cuts away the first 'n' elements of a list 'l' *)
-let rec cut_first n l =
- if n>0 then
- match l with
- | hd::tl -> cut_first (n-1) tl
- | [] -> []
- else l
-;;
-
-(* returns the first 'n' elements of a list 'l' *)
-let rec takefirst n l =
- if n > 0 then
- match l with
- hd::tl when n > 0 -> hd:: takefirst (n-1) tl
- | _ -> assert false
- else []
-;;
-
-(* from a complex Cic.Prod term, returns the list of its components *)
-let rec list_of_prod term =
- match term with
- | Cic.Prod (_,src,tgt) -> src::(list_of_prod tgt)
- | _ -> [term]
-;;
-
-let rec build_metas sort cons_list created_vars right_created_vars prop
- uri typeno =
- match cons_list with
- | hd::tl ->
- Cic.Prod(
- Cic.Anonymous,
- Cic.Implicit None,
- build_metas sort tl
- (List.map (CicSubstitution.lift 1) created_vars)
- (List.map (CicSubstitution.lift 1) right_created_vars)
- (List.map (CicSubstitution.lift 1) prop) uri typeno)
- | [] ->
- Cic.Prod(
- Cic.Name("H"), (*new name?*)
- Cic.Appl([Cic.MutInd(uri, typeno, [])] @ created_vars),
- Cic.Appl (( (List.map (CicSubstitution.lift 1) prop) @
- (List.map (CicSubstitution.lift 1 ) right_created_vars) @
- (if Inversion.isSetType sort then [Cic.Rel 1] else [])(*H*))
- ))
-;;
-
-(* computes the type of the abstract P *)
-let rec get_prop_arity sort rightparam_tys(*only to name m's*) created_vars_ty
- local_rvars left_created_vars nleft uri typeno =
- match (created_vars_ty) with
- hd::tl when (nleft > 0) ->
- get_prop_arity sort rightparam_tys tl local_rvars left_created_vars
- (nleft-1) uri typeno
- | hd::tl ->
- Cic.Prod(
- Cic.Name("m" ^ string_of_int(List.length rightparam_tys) ),
- hd,
- get_prop_arity sort (List.tl rightparam_tys)
- (List.map (CicSubstitution.lift 1) tl)
- (List.map (CicSubstitution.lift 1) (local_rvars @ [Cic.Rel 1]))
- (List.map (CicSubstitution.lift 1) left_created_vars) nleft uri typeno
- )
- | [] ->
- if Inversion.isSetType sort then
- Cic.Prod(Cic.Anonymous,
- Cic.Appl([Cic.MutInd(uri, typeno, [])]
- @ (List.map (CicSubstitution.lift (-1)) left_created_vars)
- @ (List.map (CicSubstitution.lift(-1)) local_rvars) ),
- Cic.Sort(Cic.Prop))
- else
- Cic.Sort Cic.Prop
-;;
-
-(* created vars is empty at the beginning *)
-let rec build_theorem rightparam_tys arity_l (*arity_l only to name p's*)
- arity cons_list created_vars created_vars_ty nleft
- uri typeno =
- match (arity) with
- Cic.Prod(_,src,tgt) ->
- Cic.Prod(
- Cic.Name("p" ^ string_of_int(List.length arity_l)),
- src,
- build_theorem rightparam_tys
- (List.tl arity_l) tgt cons_list
- (List.map (CicSubstitution.lift 1) (created_vars @ [Cic.Rel 1]))
- (List.map (CicSubstitution.lift 1) (created_vars_ty @ [src]))
- nleft uri typeno)
- | sort ->
- Cic.Prod(Cic.Name("P"),
- get_prop_arity sort rightparam_tys created_vars_ty [](*local vars*)
- (takefirst nleft created_vars) (*left_created_vars*) nleft uri typeno,
- build_metas sort cons_list created_vars (cut_first nleft created_vars)
- [(Cic.Rel 1)] uri typeno )
-;;
-
-let build_one typeno inversor_uri indty_uri nleft arity cons_list selections =
- (*check if there are right parameters, else return void*)
- if List.length (list_of_prod arity) = (nleft + 1) then
- None
- else
- try
- let arity_l = cut_last (list_of_prod arity) in
- let rightparam_tys = cut_first nleft arity_l in
- let theorem = build_theorem rightparam_tys arity_l arity cons_list
- [](*created_vars*) [](*created_vars_ty*) nleft indty_uri typeno in
- debug_print
- (lazy ("theorem prima di refine: " ^ (CicPp.ppterm theorem)));
- let (ref_theorem,_,metasenv,_) =
- CicRefine.type_of_aux' [] [] theorem CicUniv.oblivion_ugraph in
- (*DEBUG*) debug_print
- (lazy ("theorem dopo refine: " ^ (CicPp.ppterm ref_theorem)));
- let goal = CicMkImplicit.new_meta metasenv [] in
- let metasenv' = (goal,[],ref_theorem)::metasenv in
- let attrs = [`Class (`InversionPrinciple); `Generated] in
- let _subst = [] in
- let proof=
- Some inversor_uri,metasenv',_subst,
- lazy (Cic.Meta(goal,[])),ref_theorem, attrs in
- let _,applies =
- List.fold_right
- (fun _ (i,applies) ->
- i+1,PrimitiveTactics.apply_tac (Cic.Rel i)::applies
- ) cons_list (2,[]) in
- let proof1,gl1 =
- ProofEngineTypes.apply_tactic
- (Tacticals.then_
- ~start:(PrimitiveTactics.intros_tac ())
- (*if the number of applies is 1, we cannot use
- thens, but then_*)
- ~continuation:
- (match List.length applies with
- 0 -> Inversion.private_inversion_tac (Cic.Rel 1) selections
- | 1 ->
- Tacticals.then_
- ~start:(Inversion.private_inversion_tac (Cic.Rel 1) selections)
- ~continuation:(PrimitiveTactics.apply_tac (Cic.Rel 2))
- | _ ->
- Tacticals.thens
- ~start:(Inversion.private_inversion_tac (Cic.Rel 1) selections)
- ~continuations:applies))
- (proof,goal) in
- let _,metasenv,_subst,bo,ty, attrs = proof1 in
- assert (metasenv = []);
- Some
- (inversor_uri,
- Cic.Constant
- (UriManager.name_of_uri inversor_uri,Some (Lazy.force bo),ty,[],[]))
- with
- Inversion.EqualityNotDefinedYet ->
- HLog.warn "No default equality, no inversion principle";
- None
- | CicRefine.RefineFailure ls ->
- HLog.warn
- ("CicRefine.RefineFailure during generation of inversion principle: " ^
- Lazy.force ls) ;
- None
- | CicRefine.Uncertain ls ->
- HLog.warn
- ("CicRefine.Uncertain during generation of inversion principle: " ^
- Lazy.force ls) ;
- None
- | CicRefine.AssertFailure ls ->
- HLog.warn
- ("CicRefine.AssertFailure during generation of inversion principle: " ^
- Lazy.force ls) ;
- None
-;;
-
-let build_inverter ~add_obj status u indty_uri params =
- let indty_uri, indty_no, _ = UriManager.ind_uri_split indty_uri in
- let indty_no = match indty_no with None -> raise (Invalid_argument "not an inductive type")| Some n -> n in
- let indty, univ = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph indty_uri
- in
- match indty with
- | Cic.InductiveDefinition (tys,_,nleft,attrs) ->
- let _,inductive,_,_ = List.hd tys in
- if not inductive then raise (Invalid_argument "not an inductive type")
- else
- let name,_,arity,cons_list = List.nth tys (indty_no-1) in
- (match build_one (indty_no-1) u indty_uri nleft arity cons_list params with
- | None -> status,[]
- | Some (uri, obj) ->
- let status, added = add_obj uri obj status in
- status, uri::added)
- | _ -> assert false
-;;
-
-let build_inversion ~add_obj ~add_coercion uri obj =
- match obj with
- | Cic.InductiveDefinition (tys,_,nleft,attrs) ->
- let _,inductive,_,_ = List.hd tys in
- if not inductive then []
- else
- let counter = ref (List.length tys) in
- let all_inverters =
- List.fold_right
- (fun (name,_,arity,cons_list) res ->
- let arity_l = cut_last (list_of_prod arity) in
- let rightparam_tys = cut_first nleft arity_l in
- let params = HExtlib.mk_list true (List.length rightparam_tys) in
- let buri = UriManager.buri_of_uri uri in
- let inversor_uri =
- UriManager.uri_of_string (buri ^ "/" ^ name ^ "_inv" ^ ".con") in
- counter := !counter-1;
- match build_one !counter inversor_uri uri nleft arity cons_list params with
- None -> res
- | Some inv -> inv::res
- ) tys []
- in
- List.fold_left
- (fun lemmas (uri,obj) -> add_obj uri obj @ uri :: lemmas
- ) [] all_inverters
- | _ -> []
-;;
-
-let init () =
- LibrarySync.add_object_declaration_hook build_inversion;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id: primitiveTactics.ml 9014 2008-09-26 08:03:47Z tassi $ *)
-val init: unit -> unit
-val build_inverter: add_obj:(UriManager.uri -> Cic.obj -> 'b -> 'b * UriManager.uri list) ->
- 'b -> UriManager.uri -> UriManager.uri -> bool list ->
- 'b * UriManager.uri list
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-let nonvar uri = not (UriManager.uri_is_var uri)
-
-module Constr = MetadataConstraints
-
-exception Goal_is_not_an_equation
-
-let debug = false
-let debug_print s = if debug then prerr_endline (Lazy.force s)
-
-let ( ** ) x y = int_of_float ((float_of_int x) ** (float_of_int y))
-
-let signature_of_hypothesis context metasenv =
- let set, _ =
- List.fold_right
- (fun hyp (set,current_ctx) ->
- match hyp with
- | None -> set, hyp::current_ctx
- | Some (_, Cic.Decl t) ->
- Constr.UriManagerSet.union set (Constr.constants_of t),
- hyp::current_ctx
- | Some (_, Cic.Def (t, _)) ->
- try
- let ty,_ =
- CicTypeChecker.type_of_aux'
- metasenv current_ctx t CicUniv.oblivion_ugraph
- in
- let sort,_ =
- CicTypeChecker.type_of_aux'
- metasenv current_ctx ty CicUniv.oblivion_ugraph
- in
- let set = Constr.UriManagerSet.union set(Constr.constants_of ty)in
- match sort with
- | Cic.Sort Cic.Prop -> set, hyp::current_ctx
- | _ -> Constr.UriManagerSet.union set (Constr.constants_of t),
- hyp::current_ctx
- with
- | CicTypeChecker.TypeCheckerFailure _ -> set, hyp::current_ctx)
- context (Constr.UriManagerSet.empty,[])
- in
- set
-;;
-
-let intersect uris siguris =
- let set1 = List.fold_right Constr.UriManagerSet.add uris Constr.UriManagerSet.empty in
- let set2 =
- List.fold_right Constr.UriManagerSet.add siguris Constr.UriManagerSet.empty
- in
- let inter = Constr.UriManagerSet.inter set1 set2 in
- List.filter (fun s -> Constr.UriManagerSet.mem s inter) uris
-
-(* Profiling code
-let at_most =
- let profiler = CicUtil.profile "at_most" in
- fun ~dbd ~where uri -> profiler.profile (Constr.at_most ~dbd ~where) uri
-
-let sigmatch =
- let profiler = CicUtil.profile "sigmatch" in
- fun ~dbd ~facts ~where signature ->
- profiler.profile (MetadataConstraints.sigmatch ~dbd ~facts ~where) signature
-*)
-let at_most = Constr.at_most
-let sigmatch = MetadataConstraints.sigmatch
-
-let filter_uris_forward ~dbd (main, constants) uris =
- let main_uris =
- match main with
- | None -> []
- | Some (main, types) -> main :: types
- in
- let full_signature =
- List.fold_right Constr.UriManagerSet.add main_uris constants
- in
- List.filter (at_most ~dbd ~where:`Statement full_signature) uris
-
-let filter_uris_backward ~dbd ~facts signature uris =
- let siguris =
- List.map snd
- (sigmatch ~dbd ~facts ~where:`Statement signature)
- in
- intersect uris siguris
-
-let compare_goal_list proof goal1 goal2 =
- let _,metasenv, _subst, _,_, _ = proof in
- let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in
- let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in
- let ty_sort1,_ =
- CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.oblivion_ugraph
- in
- let ty_sort2,_ =
- CicTypeChecker.type_of_aux' metasenv ey2 ty2 CicUniv.oblivion_ugraph
- in
- let prop1 =
- let b,_ =
- CicReduction.are_convertible
- ey1 (Cic.Sort Cic.Prop) ty_sort1 CicUniv.oblivion_ugraph
- in
- if b then 0
- else 1
- in
- let prop2 =
- let b,_ =
- CicReduction.are_convertible
- ey2 (Cic.Sort Cic.Prop) ty_sort2 CicUniv.oblivion_ugraph
- in
- if b then 0
- else 1
- in
- prop1 - prop2
-
-(* experimental_hint is a version of hint for experimental
- purposes. It uses auto_tac_verbose instead of auto tac.
- Auto_tac verbose also returns a substitution - for the moment
- as a function from cic to cic, to be changed into an association
- list in the future -. This substitution is used to build a
- hash table of the inspected goals with their associated proofs.
- The cose is a cut and paste of the previous one: at the end
- of the experimentation we shall make a choice. *)
-
-let close_with_types s metasenv context =
- Constr.UriManagerSet.fold
- (fun e bag ->
- let t = CicUtil.term_of_uri e in
- let ty, _ =
- CicTypeChecker.type_of_aux' metasenv context t CicUniv.oblivion_ugraph
- in
- Constr.UriManagerSet.union bag (Constr.constants_of ty))
- s s
-
-let close_with_constructors s metasenv context =
- Constr.UriManagerSet.fold
- (fun e bag ->
- let t = CicUtil.term_of_uri e in
- match t with
- Cic.MutInd (uri,_,_)
- | Cic.MutConstruct (uri,_,_,_) ->
- (match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with
- Cic.InductiveDefinition(tl,_,_,_) ->
- snd
- (List.fold_left
- (fun (i,s) (_,_,_,cl) ->
- let _,s =
- List.fold_left
- (fun (j,s) _ ->
- let curi = UriManager.uri_of_uriref uri i (Some j) in
-(* prerr_endline ("adding " ^
- * (UriManager.string_of_uri curi)); *)
- j+1,Constr.UriManagerSet.add curi s) (1,s) cl in
- (i+1,s)) (0,bag) tl)
- | _ -> assert false)
- | _ -> bag)
- s s
-
-(* Profiling code
-let apply_tac_verbose =
- let profiler = CicUtil.profile "apply_tac_verbose" in
- fun ~term status -> profiler.profile (PrimitiveTactics.apply_tac_verbose ~term) status
-
-let sigmatch =
- let profiler = CicUtil.profile "sigmatch" in
- fun ~dbd ~facts ?(where=`Conclusion) signature -> profiler.profile (Constr.sigmatch ~dbd ~facts ~where) signature
-
-let cmatch' =
- let profiler = CicUtil.profile "cmatch'" in
- fun ~dbd ~facts signature -> profiler.profile (Constr.cmatch' ~dbd ~facts) signature
-*)
-let apply_tac_verbose = PrimitiveTactics.apply_tac_verbose
-let cmatch' = Constr.cmatch'
-
-(* used only by te old auto *)
-let signature_of_goal ~(dbd:HSql.dbd) ((proof, goal) as _status) =
- let (_, metasenv, _subst, _, _, _) = proof in
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let main, sig_constants = Constr.signature_of ty in
- let set = signature_of_hypothesis context metasenv in
- let set =
- match main with
- None -> set
- | Some (main,l) ->
- List.fold_right Constr.UriManagerSet.add (main::l) set in
- let set = Constr.UriManagerSet.union set sig_constants in
- let all_constants_closed = close_with_types set metasenv context in
- let uris =
- sigmatch ~dbd ~facts:false ~where:`Statement (None,all_constants_closed) in
- let uris = List.filter nonvar (List.map snd uris) in
- let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in
- uris
-
-let is_predicate u =
- let ty, _ =
- try CicTypeChecker.type_of_aux' [] []
- (CicUtil.term_of_uri u) CicUniv.oblivion_ugraph
- with CicTypeChecker.TypeCheckerFailure _ -> assert false
- in
- let rec check_last_pi = function
- | Cic.Prod (_,_,tgt) -> check_last_pi tgt
- | Cic.Sort Cic.Prop -> true
- | _ -> false
- in
- check_last_pi ty
-;;
-
-let only constants uri =
- prerr_endline (UriManager.string_of_uri uri);
- let t = CicUtil.term_of_uri uri in (* FIXME: write ty_of_term *)
- let ty,_ = CicTypeChecker.type_of_aux' [] [] t CicUniv.oblivion_ugraph in
- let consts = Constr.constants_of ty in
-(*
- prerr_endline ("XXX " ^ UriManager.string_of_uri uri);
- Constr.UriManagerSet.iter (fun u -> prerr_endline (" - " ^
- UriManager.string_of_uri u)) consts;
- Constr.UriManagerSet.iter (fun u -> prerr_endline (" + " ^
- UriManager.string_of_uri u)) constants;*)
- Constr.UriManagerSet.subset consts constants
-;;
-
-let rec types_of_equality = function
- | Cic.Appl [Cic.MutInd (uri, _, _); ty; _; _]
- when (LibraryObjects.is_eq_URI uri) ->
- let uri_set = Constr.constants_of ty in
- if Constr.UriManagerSet.equal uri_set Constr.UriManagerSet.empty then
- Constr.SetSet.empty
- else Constr.SetSet.singleton uri_set
- | Cic.Prod (_, s, t) ->
- Constr.SetSet.union (types_of_equality s) (types_of_equality t)
- | _ -> Constr.SetSet.empty
-;;
-
-let types_for_equality metasenv goal =
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let all = types_of_equality ty in
- let _, all =
- List.fold_left
- (fun (i,acc) _ ->
- let ty, _ =
- CicTypeChecker.type_of_aux'
- metasenv context (Cic.Rel i) CicUniv.oblivion_ugraph in
- let newty = types_of_equality ty in
- (i+1,Constr.SetSet.union newty acc))
- (1,all) context
- in all
-;;
-
-let signature_of metasenv goal =
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let ty_set = Constr.constants_of ty in
- let hyp_set = signature_of_hypothesis context metasenv in
- let set = Constr.UriManagerSet.union ty_set hyp_set in
- close_with_types
- (close_with_constructors (close_with_types set metasenv context)
- metasenv context)
- metasenv context
-
-
-let universe_of_goal ~(dbd:HSql.dbd) apply_only metasenv goal =
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let ty_set = Constr.constants_of ty in
- let hyp_set = signature_of_hypothesis context metasenv in
- let set = Constr.UriManagerSet.union ty_set hyp_set in
- let all_constants_closed = close_with_types set metasenv context in
- (* we split predicates from the rest *)
- let predicates, rest =
- Constr.UriManagerSet.partition is_predicate all_constants_closed
- in
- let uris =
- Constr.UriManagerSet.fold
- (fun u acc ->
- debug_print (lazy ("processing "^(UriManager.string_of_uri u)));
- let set_for_sigmatch =
- Constr.UriManagerSet.remove u all_constants_closed in
- if LibraryObjects.is_eq_URI (UriManager.strip_xpointer u) then
- (* equality has a special treatment *)
- (debug_print (lazy "special treatment");
- let tfe =
- Constr.SetSet.elements (types_for_equality metasenv goal)
- in
- List.fold_left
- (fun acc l ->
- let tyl = Constr.UriManagerSet.elements l in
- debug_print (lazy ("tyl: "^(String.concat "\n"
- (List.map UriManager.string_of_uri tyl))));
- let set_for_sigmatch =
- Constr.UriManagerSet.diff set_for_sigmatch l in
- let uris =
- sigmatch ~dbd ~facts:false ~where:`Statement
- (Some (u,tyl),set_for_sigmatch) in
- acc @ uris)
- acc tfe)
- else
- (debug_print (lazy "normal treatment");
- let uris =
- sigmatch ~dbd ~facts:false ~where:`Statement
- (Some (u,[]),set_for_sigmatch)
- in
- acc @ uris))
- predicates []
- in
-(*
- let uris =
- sigmatch ~dbd ~facts:false ~where:`Statement (None,all_constants_closed)
- in
-*)
- let uris = List.filter nonvar (List.map snd uris) in
- let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in
- if apply_only then
- List.filter (only all_constants_closed) uris
- else uris
-;;
-
-let filter_out_predicate set ctx menv =
- Constr.UriManagerSet.filter (fun u -> not (is_predicate u)) set
-;;
-
-let equations_for_goal ~(dbd:HSql.dbd) ?signature ((proof, goal) as _status) =
-(*
- let to_string set =
- "{\n" ^
- (String.concat "\n"
- (Constr.UriManagerSet.fold
- (fun u l -> (" "^UriManager.string_of_uri u)::l) set []))
- ^ "\n}"
- in
-*)
- let (_, metasenv, _subst, _, _, _) = proof in
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let main, sig_constants =
- match signature with
- | None -> Constr.signature_of ty
- | Some s -> s
- in
-(* Printf.printf "\nsig_constants: %s\n\n" (to_string sig_constants); *)
-(* match main with *)
-(* None -> raise Goal_is_not_an_equation *)
-(* | Some (m,l) -> *)
- let l =
- let eq_URI =
- match LibraryObjects.eq_URI () with
- None -> None
- | Some s ->
- Some
- (UriManager.uri_of_string
- (UriManager.string_of_uri s ^ "#xpointer(1/1)"))
- in
- match eq_URI,main with
- | Some eq_URI, Some (m, l) when UriManager.eq m eq_URI -> m::l
- | _ -> []
- in
- (*Printf.printf "\nSome (m, l): %s, [%s]\n\n"
- (UriManager.string_of_uri (List.hd l))
- (String.concat "; " (List.map UriManager.string_of_uri (List.tl l)));
- *)
- (* if m == UriManager.uri_of_string HelmLibraryObjects.Logic.eq_XURI then ( *)
- let set = signature_of_hypothesis context metasenv in
- (* Printf.printf "\nsignature_of_hypothesis: %s\n\n" (to_string set); *)
- let set = Constr.UriManagerSet.union set sig_constants in
- let set = filter_out_predicate set context metasenv in
- let set = close_with_types set metasenv context in
- (* Printf.printf "\ndopo close_with_types: %s\n\n" (to_string set); *)
- let set = close_with_constructors set metasenv context in
- (* Printf.printf "\ndopo close_with_constructors: %s\n\n" (to_string set); *)
- let set_for_sigmatch = List.fold_right Constr.UriManagerSet.remove l set in
- let uris =
- sigmatch ~dbd ~facts:false ~where:`Statement (main,set_for_sigmatch) in
- let uris = List.filter nonvar (List.map snd uris) in
- let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in
- let set = List.fold_right Constr.UriManagerSet.add l set in
- let uris = List.filter (only set) uris in
- uris
- (* ) *)
- (* else raise Goal_is_not_an_equation *)
-
-let experimental_hint
- ~(dbd:HSql.dbd) ?(facts=false) ?signature ((proof, goal) as status) =
- let (_, metasenv, _subst, _, _, _) = proof in
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let (uris, (main, sig_constants)) =
- match signature with
- | Some signature ->
- (sigmatch ~dbd ~facts signature, signature)
- | None ->
- (cmatch' ~dbd ~facts ty, Constr.signature_of ty)
- in
- let uris = List.filter nonvar (List.map snd uris) in
- let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in
- let types_constants =
- match main with
- | None -> Constr.UriManagerSet.empty
- | Some (main, types) ->
- List.fold_right Constr.UriManagerSet.add (main :: types)
- Constr.UriManagerSet.empty
- in
- let all_constants =
- let hyp_and_sug =
- Constr.UriManagerSet.union
- (signature_of_hypothesis context metasenv)
- sig_constants
- in
- let main =
- match main with
- | None -> Constr.UriManagerSet.empty
- | Some (main,_) ->
- let ty, _ =
- CicTypeChecker.type_of_aux'
- metasenv context (CicUtil.term_of_uri main)
- CicUniv.oblivion_ugraph
- in
- Constr.constants_of ty
- in
- Constr.UriManagerSet.union main hyp_and_sug
- in
-(* Constr.UriManagerSet.iter debug_print hyp_constants; *)
- let all_constants_closed = close_with_types all_constants metasenv context in
- let other_constants =
- Constr.UriManagerSet.diff all_constants_closed types_constants
- in
- debug_print (lazy "all_constants_closed");
- if debug then Constr.UriManagerSet.iter (fun s -> debug_print (lazy (UriManager.string_of_uri s))) all_constants_closed;
- debug_print (lazy "other_constants");
- if debug then Constr.UriManagerSet.iter (fun s -> debug_print (lazy (UriManager.string_of_uri s))) other_constants;
- let uris =
- let pow = 2 ** (Constr.UriManagerSet.cardinal other_constants) in
- if ((List.length uris < pow) or (pow <= 0))
- then begin
- debug_print (lazy "MetadataQuery: large sig, falling back to old method");
- filter_uris_forward ~dbd (main, other_constants) uris
- end else
- filter_uris_backward ~dbd ~facts (main, other_constants) uris
- in
- let rec aux = function
- | [] -> []
- | uri :: tl ->
- (let status' =
- try
- let (subst,(proof, goal_list)) =
- (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *)
- apply_tac_verbose
- ~term:(CicUtil.term_of_uri uri)
- status
- in
- let goal_list =
- List.stable_sort (compare_goal_list proof) goal_list
- in
- Some (uri, (subst,(proof, goal_list)))
- with ProofEngineTypes.Fail _ -> None
- in
- match status' with
- | None -> aux tl
- | Some status' -> status' :: aux tl)
- in
- List.stable_sort
- (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) ->
- Pervasives.compare (List.length goals1) (List.length goals2))
- (aux uris)
-
-let new_experimental_hint
- ~(dbd:HSql.dbd) ?(facts=false) ?signature ~universe
- ((proof, goal) as status)
-=
- let (_, metasenv, _subst, _, _, _) = proof in
- let (_, context, ty) = CicUtil.lookup_meta goal metasenv in
- let (uris, (main, sig_constants)) =
- match signature with
- | Some signature ->
- (sigmatch ~dbd ~facts signature, signature)
- | None ->
- (cmatch' ~dbd ~facts ty, Constr.signature_of ty) in
- let universe =
- List.fold_left
- (fun res u -> Constr.UriManagerSet.add u res)
- Constr.UriManagerSet.empty universe in
- let uris =
- List.fold_left
- (fun res (_,u) -> Constr.UriManagerSet.add u res)
- Constr.UriManagerSet.empty uris in
- let uris = Constr.UriManagerSet.inter uris universe in
- let uris = Constr.UriManagerSet.elements uris in
- let rec aux = function
- | [] -> []
- | uri :: tl ->
- (let status' =
- try
- let (subst,(proof, goal_list)) =
- (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *)
- apply_tac_verbose
- ~term:(CicUtil.term_of_uri uri)
- status
- in
- let goal_list =
- List.stable_sort (compare_goal_list proof) goal_list
- in
- Some (uri, (subst,(proof, goal_list)))
- with ProofEngineTypes.Fail _ -> None
- in
- match status' with
- | None -> aux tl
- | Some status' -> status' :: aux tl)
- in
- List.stable_sort
- (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) ->
- Pervasives.compare (List.length goals1) (List.length goals2))
- (aux uris)
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** @param vars if set variables (".var" URIs) are considered. Defaults to
- * false
- * @param pat shell like pattern matching over object names, a string where "*"
- * is interpreted as 0 or more characters and "?" as exactly one character *)
-
-(* used only by the old auto *)
-val signature_of_goal:
- dbd:HSql.dbd -> ProofEngineTypes.status ->
- UriManager.uri list
-
-val signature_of:
- Cic.metasenv ->
- ProofEngineTypes.goal ->
- MetadataConstraints.UriManagerSet.t
-
-val signature_of_hypothesis:
- Cic.hypothesis list ->
- Cic.metasenv ->
- MetadataConstraints.UriManagerSet.t
-
-val close_with_types:
- MetadataConstraints.UriManagerSet.t ->
- Cic.metasenv ->
- Cic.context ->
- MetadataConstraints.UriManagerSet.t
-
-val universe_of_goal:
- dbd:HSql.dbd ->
- bool -> (* apply only or not *)
- Cic.metasenv ->
- ProofEngineTypes.goal ->
- UriManager.uri list
-
-val equations_for_goal:
- dbd:HSql.dbd ->
- ?signature:MetadataConstraints.term_signature ->
- ProofEngineTypes.status -> UriManager.uri list
-
-val experimental_hint:
- dbd:HSql.dbd ->
- ?facts:bool ->
- ?signature:MetadataConstraints.term_signature ->
- ProofEngineTypes.status ->
- (UriManager.uri *
- ((Cic.term -> Cic.term) *
- (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list
-
-val new_experimental_hint:
- dbd:HSql.dbd ->
- ?facts:bool ->
- ?signature:MetadataConstraints.term_signature ->
- universe:UriManager.uri list ->
- ProofEngineTypes.status ->
- (UriManager.uri *
- ((Cic.term -> Cic.term) *
- (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let absurd_tac ~term =
- let absurd_tac ~term status =
- let (proof, goal) = status in
- let module C = Cic in
- let module U = UriManager in
- let module P = PrimitiveTactics in
- let _,metasenv,_subst,_,_, _ = proof in
- let _,context,ty = CicUtil.lookup_meta goal metasenv in
- let absurd_URI =
- match LibraryObjects.absurd_URI () with
- Some uri -> uri
- | None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default \"absurd\" theorem first. Please use the \"default\" command"))
- in
- let ty_term,_ =
- CicTypeChecker.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
- if (ty_term = (C.Sort C.Prop)) (* ma questo controllo serve?? *)
- then ProofEngineTypes.apply_tactic
- (P.apply_tac
- ~term:(
- C.Appl [(C.Const (absurd_URI, [] )) ;
- term ; ty])
- )
- status
- else raise (ProofEngineTypes.Fail (lazy "Absurd: Not a Proposition"))
- in
- ProofEngineTypes.mk_tactic (absurd_tac ~term)
-;;
-
-(* FG: METTERE I NOMI ANCHE QUI? CSC: in teoria si', per la intros*)
-let contradiction_tac =
- let contradiction_tac status =
- let module C = Cic in
- let module U = UriManager in
- let module P = PrimitiveTactics in
- let module T = Tacticals in
- let false_URI =
- match LibraryObjects.false_URI () with
- Some uri -> uri
- | None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default \"false\" definition first. Please use the \"default\" command"))
- in
- try
- ProofEngineTypes.apply_tactic (
- T.then_
- ~start:(P.intros_tac ())
- ~continuation:(
- T.then_
- ~start:
- (EliminationTactics.elim_type_tac (C.MutInd (false_URI, 0, [])))
- ~continuation: VariousTactics.assumption_tac))
- status
- with
- ProofEngineTypes.Fail msg when Lazy.force msg = "Assumption: No such assumption" -> raise (ProofEngineTypes.Fail (lazy "Contradiction: No such assumption"))
- (* sarebbe piu' elegante se Assumtion sollevasse un'eccezione tutta sua che questa cattura, magari con l'aiuto di try_tactics *)
- in
- ProofEngineTypes.mk_tactic contradiction_tac
-;;
-
-(* Questa era in fourierR.ml
-(* !!!!! fix !!!!!!!!!! *)
-let contradiction_tac (proof,goal)=
- Tacticals.then_
- ~start:(PrimitiveTactics.intros_tac ~name:"bo?" ) (*inutile sia questo che quello prima della chiamata*)
- ~continuation:(Tacticals.then_
- ~start:(VariousTactics.elim_type_tac ~term:_False)
- ~continuation:(assumption_tac))
- (proof,goal)
-;;
-*)
-
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val absurd_tac: term:Cic.term -> ProofEngineTypes.tactic
-val contradiction_tac: ProofEngineTypes.tactic
-
+++ /dev/null
-all:
- @make -C .. $@
-
-%:
- @make -C .. $@
-
+++ /dev/null
-make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata)
-
-./saturate -h per vedere una lista di parametri:
-
-./saturate: unknown option `-h'.
-Usage:
- -full Enable full mode
- -f Enable/disable full-reduction strategy (default: enabled)
- -r Weight-Age equality selection ratio (default: 4)
- -s symbols-based selection ratio (relative to the weight ratio, default: 0)
- -c Configuration file (for the db connection)
- -o Term ordering. Possible values are:
- kbo: Knuth-Bendix ordering
- nr-kbo: Non-recursive variant of kbo (default)
- lpo: Lexicographic path ordering
- -l Time limit in seconds (default: no limit)
- -w Maximal width (default: 3)
- -d Maximal depth (default: 3)
- -retrieve retrieve only
- -help Display this list of options
- --help Display this list of options
-
-
-./saturate -l 10 -demod-equalities
-
-dove -l 10 e` il timeout in secondi.
-
-Il programma legge da standard input il teorema, per esempio
-
-\forall n:nat.n + n = 2 * n
-\forall n:R.n + n = 2 * n
-\forall n:R.n+n=n+n
-
-l'input termina con una riga vuota (quindi basta un doppio invio alla fine)
-
-In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi
-active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output
-su file, per esempio usando tee:
-
-./saturate -l 10 -demod-equalities | tee output.txt
-
-Il formato di stampa e` quello per gli oggetti di tipo equality (usa la
-funzione Inference.string_of_equality)
-
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* let _profiler = <:profiler<_profiler>>;; *)
-
-(* $Id: inference.ml 6245 2006-04-05 12:07:51Z tassi $ *)
-
-type rule = SuperpositionRight | SuperpositionLeft | Demodulation
-type uncomparable = int -> int
-
-type equality =
- uncomparable * (* trick to break structural equality *)
- int * (* weight *)
- proof *
- (Cic.term * (* type *)
- Cic.term * (* left side *)
- Cic.term * (* right side *)
- Utils.comparison) * (* ordering *)
- Cic.metasenv * (* environment for metas *)
- int (* id *)
-and proof =
- | Exact of Cic.term
- | Step of Subst.substitution * (rule * int*(Utils.pos*int)* Cic.term)
- (* subst, (rule,eq1, eq2,predicate) *)
-and goal_proof = (rule * Utils.pos * int * Subst.substitution * Cic.term) list
-;;
-(* the hashtbl eq_id -> proof, max_eq_id *)
-module IntOt = struct type t = int let compare = Pervasives.compare end
-module M = Map.Make(IntOt)
-type equality_bag = equality M.t * int
-
-type goal = goal_proof * Cic.metasenv * Cic.term
-
-(* globals *)
-let mk_equality_bag () = M.empty, 10000 ;;
-
-let freshid (m,i) = (m,i+1), i+1 ;;
-
-let add_to_bag (id_to_eq,i) id eq = M.add id eq id_to_eq,i ;;
-
-let uncomparable = fun _ -> 0
-
-let mk_equality bag (weight,p,(ty,l,r,o),m) =
- let bag, id = freshid bag in
- let eq = (uncomparable,weight,p,(ty,l,r,o),m,id) in
- let bag = add_to_bag bag id eq in
- bag, eq
-;;
-
-let mk_tmp_equality (weight,(ty,l,r,o),m) =
- let id = -1 in
- uncomparable,weight,Exact (Cic.Implicit None),(ty,l,r,o),m,id
-;;
-
-
-let open_equality (_,weight,proof,(ty,l,r,o),m,id) =
- (weight,proof,(ty,l,r,o),m,id)
-
-let id_of e =
- let _,_,_,_,id = open_equality e in id
-;;
-
-
-let string_of_rule = function
- | SuperpositionRight -> "SupR"
- | SuperpositionLeft -> "SupL"
- | Demodulation -> "Demod"
-;;
-
-let string_of_equality ?env eq =
- match env with
- | None ->
- let w, _, (ty, left, right, o), m , id = open_equality eq in
- Printf.sprintf "Id: %d, Weight: %d, {%s}: %s =(%s) %s [%s]"
- id w (CicPp.ppterm ty)
- (CicPp.ppterm left)
- (Utils.string_of_comparison o) (CicPp.ppterm right)
- (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m))
-(* "..." *)
- | Some (_, context, _) ->
- let names = Utils.names_of_context context in
- let w, _, (ty, left, right, o), m , id = open_equality eq in
- Printf.sprintf "Id: %d, Weight: %d, {%s}: %s =(%s) %s [%s]"
- id w (CicPp.pp ty names)
- (CicPp.pp left names) (Utils.string_of_comparison o)
- (CicPp.pp right names)
- (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m))
-(* "..." *)
-;;
-
-let compare (_,_,_,s1,_,_) (_,_,_,s2,_,_) =
- Pervasives.compare s1 s2
-;;
-
-let rec max_weight_in_proof ((id_to_eq,_) as bag) current =
- function
- | Exact _ -> current
- | Step (_, (_,id1,(_,id2),_)) ->
- let eq1 = M.find id1 id_to_eq in
- let eq2 = M.find id2 id_to_eq in
- let (w1,p1,(_,_,_,_),_,_) = open_equality eq1 in
- let (w2,p2,(_,_,_,_),_,_) = open_equality eq2 in
- let current = max current w1 in
- let current = max_weight_in_proof bag current p1 in
- let current = max current w2 in
- max_weight_in_proof bag current p2
-
-let max_weight_in_goal_proof ((id_to_eq,_) as bag) =
- List.fold_left
- (fun current (_,_,id,_,_) ->
- let eq = M.find id id_to_eq in
- let (w,p,(_,_,_,_),_,_) = open_equality eq in
- let current = max current w in
- max_weight_in_proof bag current p)
-
-let max_weight bag goal_proof proof =
- let current = max_weight_in_proof bag 0 proof in
- max_weight_in_goal_proof bag current goal_proof
-
-let proof_of_id (id_to_eq,_) id =
- try
- let (_,p,(_,l,r,_),_,_) = open_equality (M.find id id_to_eq) in
- p,l,r
- with
- Not_found ->
- prerr_endline ("Unable to find the proof of " ^ string_of_int id);
- assert false
-;;
-
-let is_in (id_to_eq,_) id =
- M.mem id id_to_eq
-;;
-
-
-let string_of_proof ?(names=[]) bag p gp =
- let str_of_pos = function
- | Utils.Left -> "left"
- | Utils.Right -> "right"
- in
- let fst3 (x,_,_) = x in
- let rec aux margin name =
- let prefix = String.make margin ' ' ^ name ^ ": " in function
- | Exact t ->
- Printf.sprintf "%sExact (%s)\n"
- prefix (CicPp.pp t names)
- | Step (subst,(rule,eq1,(pos,eq2),pred)) ->
- Printf.sprintf "%s%s(%s|%d with %d dir %s pred %s))\n"
- prefix (string_of_rule rule) (Subst.ppsubst ~names subst) eq1 eq2 (str_of_pos pos)
- (CicPp.pp pred names)^
- aux (margin+1) (Printf.sprintf "%d" eq1) (fst3 (proof_of_id bag eq1)) ^
- aux (margin+1) (Printf.sprintf "%d" eq2) (fst3 (proof_of_id bag eq2))
- in
- aux 0 "" p ^
- String.concat "\n"
- (List.map
- (fun (r,pos,i,s,t) ->
- (Printf.sprintf
- "GOAL: %s %s %d %s %s\n" (string_of_rule r)
- (str_of_pos pos) i (Subst.ppsubst ~names s) (CicPp.pp t names)) ^
- aux 1 (Printf.sprintf "%d " i) (fst3 (proof_of_id bag i)))
- gp)
-;;
-
-let rec depend ((id_to_eq,_) as bag) eq id seen =
- let (_,p,(_,_,_,_),_,ideq) = open_equality eq in
- if List.mem ideq seen then
- false,seen
- else
- if id = ideq then
- true,seen
- else
- match p with
- | Exact _ -> false,seen
- | Step (_,(_,id1,(_,id2),_)) ->
- let seen = ideq::seen in
- let eq1 = M.find id1 id_to_eq in
- let eq2 = M.find id2 id_to_eq in
- let b1,seen = depend bag eq1 id seen in
- if b1 then b1,seen else depend bag eq2 id seen
-;;
-
-let depend bag eq id = fst (depend bag eq id []);;
-
-let ppsubst = Subst.ppsubst ~names:[];;
-
-(* returns an explicit named subst and a list of arguments for sym_eq_URI *)
-let build_ens uri termlist =
- let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match obj with
- | Cic.Constant (_, _, _, uris, _) ->
- (* assert (List.length uris <= List.length termlist); *)
- let rec aux = function
- | [], tl -> [], tl
- | (uri::uris), (term::tl) ->
- let ens, args = aux (uris, tl) in
- (uri, term)::ens, args
- | _, _ -> assert false
- in
- aux (uris, termlist)
- | _ -> assert false
-;;
-
-let mk_sym uri ty t1 t2 p =
- let ens, args = build_ens uri [ty;t1;t2;p] in
- Cic.Appl (Cic.Const(uri, ens) :: args)
-;;
-
-let mk_trans uri ty t1 t2 t3 p12 p23 =
- let ens, args = build_ens uri [ty;t1;t2;t3;p12;p23] in
- Cic.Appl (Cic.Const (uri, ens) :: args)
-;;
-
-let mk_eq_ind uri ty what pred p1 other p2 =
- let ens, args = build_ens uri [ty; what; pred; p1; other; p2] in
- Cic.Appl (Cic.Const (uri, ens) :: args)
-;;
-
-let p_of_sym ens tl =
- let args = List.map snd ens @ tl in
- match args with
- | [_;_;_;p] -> p
- | _ -> assert false
-;;
-
-let open_trans ens tl =
- let args = List.map snd ens @ tl in
- match args with
- | [ty;l;m;r;p1;p2] -> ty,l,m,r,p1,p2
- | _ -> assert false
-;;
-
-let open_sym ens tl =
- let args = List.map snd ens @ tl in
- match args with
- | [ty;l;r;p] -> ty,l,r,p
- | _ -> assert false
-;;
-
-let open_eq_ind args =
- match args with
- | [ty;l;pred;pl;r;pleqr] -> ty,l,pred,pl,r,pleqr
- | _ -> assert false
-;;
-
-let open_pred pred =
- match pred with
- | Cic.Lambda (_,_,(Cic.Appl [Cic.MutInd (uri, 0,_);ty;l;r]))
- when LibraryObjects.is_eq_URI uri -> ty,uri,l,r
- | _ -> Utils.debug_print (lazy (CicPp.ppterm pred)); assert false
-;;
-
-let is_not_fixed t =
- CicSubstitution.subst (Cic.Implicit None) t <>
- CicSubstitution.subst (Cic.Rel 1) t
-;;
-
-let canonical t context menv =
- let remove_cycles t =
- let is_transitive =
- function
- Cic.Appl (Cic.Const (uri_trans,_)::_)
- when LibraryObjects.is_trans_eq_URI uri_trans ->
- true
- | _ -> false in
- let rec collect =
- function
- Cic.Appl (Cic.Const (uri_trans,ens)::tl)
- when LibraryObjects.is_trans_eq_URI uri_trans ->
- let ty,l,m,r,p1,p2 = open_trans ens tl in
- (if is_transitive p1 then fst (collect p1) else [l,p1]) @
- (if is_transitive p2 then fst (collect p2) else [m,p2]),
- (r, uri_trans, ty)
- | t -> assert false in
- let rec cut_to_last_duplicate l acc =
- function
- [] -> List.rev acc
- | (l',p)::tl when l=l' ->
-if acc <> [] then
-Utils.debug_print (lazy ("!!! RISPARMIO " ^ string_of_int (List.length acc) ^ " PASSI"));
- cut_to_last_duplicate l [l',p] tl
- | (l',p)::tl ->
- cut_to_last_duplicate l ((l',p)::acc) tl
- in
- let rec rebuild =
- function
- (l,_)::_::_ as steps, ((r,uri_trans,ty) as last) ->
- (match cut_to_last_duplicate l [] steps with
- (l,p1)::((m,_)::_::_ as tl) ->
- mk_trans uri_trans ty l m r p1 (rebuild (tl,last))
- | [l,p1 ; m,p2] -> mk_trans uri_trans ty l m r p1 p2
- | [l,p1] -> p1
- | [] -> assert false)
- | _ -> assert false
- in
- if is_transitive t then
- rebuild (collect t)
- else
- t
- in
- let rec remove_refl t =
- match t with
- | Cic.Appl (((Cic.Const(uri_trans,ens))::tl) as args)
- when LibraryObjects.is_trans_eq_URI uri_trans ->
- let ty,l,m,r,p1,p2 = open_trans ens tl in
- (match p1,p2 with
- | Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_],p2 ->
- remove_refl p2
- | p1,Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_] ->
- remove_refl p1
- | _ -> Cic.Appl (List.map remove_refl args))
- | Cic.Appl l -> Cic.Appl (List.map remove_refl l)
- | Cic.LetIn (name,bo,ty,rest) ->
- Cic.LetIn (name,remove_refl bo,remove_refl ty,remove_refl rest)
- | _ -> t
- in
- let rec canonical_trough_lambda context = function
- | Cic.Lambda(name,ty,bo) ->
- let context' = (Some (name,Cic.Decl ty))::context in
- Cic.Lambda(name,ty,canonical_trough_lambda context' bo)
- | t -> canonical context t
-
- and canonical context t =
- match t with
- | Cic.LetIn(name,bo,ty,rest) ->
- let bo = canonical_trough_lambda context bo in
- let ty = canonical_trough_lambda context ty in
- let context' = (Some (name,Cic.Def (bo,ty)))::context in
- Cic.LetIn(name,bo,ty,canonical context' rest)
- | Cic.Appl (((Cic.Const(uri_sym,ens))::tl) as args)
- when LibraryObjects.is_sym_eq_URI uri_sym ->
- (match p_of_sym ens tl with
- | Cic.Appl ((Cic.Const(uri,ens))::tl)
- when LibraryObjects.is_sym_eq_URI uri ->
- canonical context (p_of_sym ens tl)
- | Cic.Appl ((Cic.Const(uri_trans,ens))::tl)
- when LibraryObjects.is_trans_eq_URI uri_trans ->
- let ty,l,m,r,p1,p2 = open_trans ens tl in
- mk_trans uri_trans ty r m l
- (canonical context (mk_sym uri_sym ty m r p2))
- (canonical context (mk_sym uri_sym ty l m p1))
- | Cic.Appl (([Cic.Const(uri_feq,ens);ty1;ty2;f;x;y;p]))
- when LibraryObjects.is_eq_f_URI uri_feq ->
- let eq = LibraryObjects.eq_URI_of_eq_f_URI uri_feq in
- let eq_f_sym =
- Cic.Const (LibraryObjects.eq_f_sym_URI ~eq, [])
- in
- let rc = Cic.Appl [eq_f_sym;ty1;ty2;f;x;y;p] in
- Utils.debug_print (lazy ("CANONICAL " ^ CicPp.ppterm rc));
- rc
- | Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_] as t
- when LibraryObjects.is_eq_URI uri -> t
- | _ -> Cic.Appl (List.map (canonical context) args))
- | Cic.Appl l -> Cic.Appl (List.map (canonical context) l)
- | _ -> t
- in
- remove_cycles (remove_refl (canonical context t))
-;;
-
-let compose_contexts ctx1 ctx2 =
- ProofEngineReduction.replace_lifting
- ~equality:(fun _ ->(=)) ~context:[] ~what:[Cic.Implicit(Some `Hole)] ~with_what:[ctx2] ~where:ctx1
-;;
-
-let put_in_ctx ctx t =
- ProofEngineReduction.replace_lifting
- ~equality:(fun _ -> (=)) ~context:[] ~what:[Cic.Implicit (Some `Hole)] ~with_what:[t] ~where:ctx
-;;
-
-let mk_eq uri ty l r =
- let ens, args = build_ens uri [ty; l; r] in
- Cic.Appl (Cic.MutInd(uri,0,ens) :: args)
-;;
-
-let mk_refl uri ty t =
- let ens, args = build_ens uri [ty; t] in
- Cic.Appl (Cic.MutConstruct(uri,0,1,ens) :: args)
-;;
-
-let open_eq = function
- | Cic.Appl [Cic.MutInd(uri,0,[]);ty;l;r] when LibraryObjects.is_eq_URI uri ->
- uri, ty, l ,r
- | _ -> assert false
-;;
-
-let mk_feq uri_feq ty ty1 left pred right t =
- let ens, args = build_ens uri_feq [ty;ty1;pred;left;right;t] in
- Cic.Appl (Cic.Const(uri_feq,ens) :: args)
-;;
-
-let rec look_ahead aux = function
- | Cic.Appl ((Cic.Const(uri_ind,ens))::tl) as t
- when LibraryObjects.is_eq_ind_URI uri_ind ||
- LibraryObjects.is_eq_ind_r_URI uri_ind ->
- let ty1,what,pred,p1,other,p2 = open_eq_ind tl in
- let ty2,eq,lp,rp = open_pred pred in
- let hole = Cic.Implicit (Some `Hole) in
- let ty2 = CicSubstitution.subst hole ty2 in
- aux ty1 (CicSubstitution.subst other lp) (CicSubstitution.subst other rp) hole ty2 t
- | Cic.Lambda (n,s,t) -> Cic.Lambda (n,s,look_ahead aux t)
- | t -> t
-;;
-
-let contextualize uri ty left right t =
- let hole = Cic.Implicit (Some `Hole) in
- (* aux [uri] [ty] [left] [right] [ctx] [ctx_ty] [t]
- *
- * the parameters validate this invariant
- * t: eq(uri) ty left right
- * that is used only by the base case
- *
- * ctx is a term with an hole. Cic.Implicit(Some `Hole) is the empty context
- * ctx_ty is the type of ctx
- *)
- let rec aux uri ty left right ctx_d ctx_ty t =
- match t with
- | Cic.Appl ((Cic.Const(uri_sym,ens))::tl)
- when LibraryObjects.is_sym_eq_URI uri_sym ->
- let ty,l,r,p = open_sym ens tl in
- mk_sym uri_sym ty l r (aux uri ty l r ctx_d ctx_ty p)
- | Cic.LetIn (name,body,bodyty,rest) ->
- Cic.LetIn
- (name,look_ahead (aux uri) body, bodyty,
- aux uri ty left right ctx_d ctx_ty rest)
- | Cic.Appl ((Cic.Const(uri_ind,ens))::tl)
- when LibraryObjects.is_eq_ind_URI uri_ind ||
- LibraryObjects.is_eq_ind_r_URI uri_ind ->
- let ty1,what,pred,p1,other,p2 = open_eq_ind tl in
- let ty2,eq,lp,rp = open_pred pred in
- let uri_trans = LibraryObjects.trans_eq_URI ~eq:uri in
- let uri_sym = LibraryObjects.sym_eq_URI ~eq:uri in
- let is_not_fixed_lp = is_not_fixed lp in
- let avoid_eq_ind = LibraryObjects.is_eq_ind_URI uri_ind in
- (* extract the context and the fixed term from the predicate *)
- let m, ctx_c, ty2 =
- let m, ctx_c = if is_not_fixed_lp then rp,lp else lp,rp in
- (* they were under a lambda *)
- let m = CicSubstitution.subst hole m in
- let ctx_c = CicSubstitution.subst hole ctx_c in
- let ty2 = CicSubstitution.subst hole ty2 in
- m, ctx_c, ty2
- in
- (* create the compound context and put the terms under it *)
- let ctx_dc = compose_contexts ctx_d ctx_c in
- let dc_what = put_in_ctx ctx_dc what in
- let dc_other = put_in_ctx ctx_dc other in
- (* m is already in ctx_c so it is put in ctx_d only *)
- let d_m = put_in_ctx ctx_d m in
- (* we also need what in ctx_c *)
- let c_what = put_in_ctx ctx_c what in
- (* now put the proofs in the compound context *)
- let p1 = (* p1: dc_what = d_m *)
- if is_not_fixed_lp then
- aux uri ty2 c_what m ctx_d ctx_ty p1
- else
- mk_sym uri_sym ctx_ty d_m dc_what
- (aux uri ty2 m c_what ctx_d ctx_ty p1)
- in
- let p2 = (* p2: dc_other = dc_what *)
- if avoid_eq_ind then
- mk_sym uri_sym ctx_ty dc_what dc_other
- (aux uri ty1 what other ctx_dc ctx_ty p2)
- else
- aux uri ty1 other what ctx_dc ctx_ty p2
- in
- (* if pred = \x.C[x]=m --> t : C[other]=m --> trans other what m
- if pred = \x.m=C[x] --> t : m=C[other] --> trans m what other *)
- let a,b,c,paeqb,pbeqc =
- if is_not_fixed_lp then
- dc_other,dc_what,d_m,p2,p1
- else
- d_m,dc_what,dc_other,
- (mk_sym uri_sym ctx_ty dc_what d_m p1),
- (mk_sym uri_sym ctx_ty dc_other dc_what p2)
- in
- mk_trans uri_trans ctx_ty a b c paeqb pbeqc
- | t when ctx_d = hole -> t
- | t ->
-(* let uri_sym = LibraryObjects.sym_eq_URI ~eq:uri in *)
-(* let uri_ind = LibraryObjects.eq_ind_URI ~eq:uri in *)
-
- let uri_feq = LibraryObjects.eq_f_URI ~eq:uri in
- let pred =
-(* let r = CicSubstitution.lift 1 (put_in_ctx ctx_d left) in *)
- let l =
- let ctx_d = CicSubstitution.lift 1 ctx_d in
- put_in_ctx ctx_d (Cic.Rel 1)
- in
-(* let lty = CicSubstitution.lift 1 ctx_ty in *)
-(* Cic.Lambda (Cic.Name "foo",ty,(mk_eq uri lty l r)) *)
- Cic.Lambda (Cic.Name "foo",ty,l)
- in
-(* let d_left = put_in_ctx ctx_d left in *)
-(* let d_right = put_in_ctx ctx_d right in *)
-(* let refl_eq = mk_refl uri ctx_ty d_left in *)
-(* mk_sym uri_sym ctx_ty d_right d_left *)
-(* (mk_eq_ind uri_ind ty left pred refl_eq right t) *)
- (mk_feq uri_feq ty ctx_ty left pred right t)
- in
- aux uri ty left right hole ty t
-;;
-
-let contextualize_rewrites t ty =
- let eq,ty,l,r = open_eq ty in
- contextualize eq ty l r t
-;;
-
-let add_subst subst =
- function
- | Exact t -> Exact (Subst.apply_subst subst t)
- | Step (s,(rule, id1, (pos,id2), pred)) ->
- Step (Subst.concat subst s,(rule, id1, (pos,id2), pred))
-;;
-
-let build_proof_step eq lift subst p1 p2 pos l r pred =
- let p1 = Subst.apply_subst_lift lift subst p1 in
- let p2 = Subst.apply_subst_lift lift subst p2 in
- let l = CicSubstitution.lift lift l in
- let l = Subst.apply_subst_lift lift subst l in
- let r = CicSubstitution.lift lift r in
- let r = Subst.apply_subst_lift lift subst r in
- let pred = CicSubstitution.lift lift pred in
- let pred = Subst.apply_subst_lift lift subst pred in
- let ty,body =
- match pred with
- | Cic.Lambda (_,ty,body) -> ty,body
- | _ -> assert false
- in
- let what, other =
- if pos = Utils.Left then l,r else r,l
- in
- let p =
- match pos with
- | Utils.Left ->
- mk_eq_ind (LibraryObjects.eq_ind_URI ~eq) ty what pred p1 other p2
- | Utils.Right ->
- mk_eq_ind (LibraryObjects.eq_ind_r_URI ~eq) ty what pred p1 other p2
- in
- p
-;;
-
-let parametrize_proof p l r =
- let uniq l = HExtlib.list_uniq (List.sort (fun (i,_) (j,_) -> Pervasives.compare i j) l) in
- let mot = CicUtil.metas_of_term_set in
- let parameters = uniq (mot p @ mot l @ mot r) in
- (* ?if they are under a lambda? *)
-(*
- let parameters =
- HExtlib.list_uniq (List.sort Pervasives.compare parameters)
- in
-*)
- (* resorts l such that *hopefully* dependencies can be inferred *)
- let guess_dependency p l =
- match p with
- | Cic.Appl ((Cic.Const(uri_ind,ens))::tl)
- when LibraryObjects.is_eq_ind_URI uri_ind ||
- LibraryObjects.is_eq_ind_r_URI uri_ind ->
- let ty,_,_,_,_,_ = open_eq_ind tl in
- let metas = CicUtil.metas_of_term ty in
- let nondep, dep =
- List.partition (fun (i,_) -> List.exists (fun (j,_) -> j=i) metas) l
- in
- nondep@dep
- | _ -> l
- in
- let parameters = guess_dependency p parameters in
- let what = List.map (fun (i,l) -> Cic.Meta (i,l)) parameters in
- let with_what, lift_no =
- List.fold_right (fun _ (acc,n) -> ((Cic.Rel n)::acc),n+1) what ([],1)
- in
- let p = CicSubstitution.lift (lift_no-1) p in
- let p =
- ProofEngineReduction.replace_lifting
- ~equality:(fun _ t1 t2 ->
- match t1,t2 with Cic.Meta (i,_),Cic.Meta(j,_) -> i=j | _ -> false)
- ~context:[]
- ~what ~with_what ~where:p
- in
- let ty_of_m _ = Cic.Implicit (Some `Type) in
- let args, proof,_ =
- List.fold_left
- (fun (instance,p,n) m ->
- (instance@[m],
- Cic.Lambda
- (Cic.Name ("X"^string_of_int n),
- CicSubstitution.lift (lift_no - n - 1) (ty_of_m m),
- p),
- n+1))
- ([Cic.Rel 1],p,1)
- what
- in
- let instance = match args with | [x] -> x | _ -> Cic.Appl args in
- proof, instance
-;;
-
-let wfo bag goalproof proof id =
- let rec aux acc id =
- let p,_,_ = proof_of_id bag id in
- match p with
- | Exact _ -> if (List.mem id acc) then acc else id :: acc
- | Step (_,(_,id1, (_,id2), _)) ->
- let acc = if not (List.mem id1 acc) then aux acc id1 else acc in
- let acc = if not (List.mem id2 acc) then aux acc id2 else acc in
- id :: acc
- in
- let acc =
- match proof with
- | Exact _ -> [id]
- | Step (_,(_,id1, (_,id2), _)) -> aux (aux [id] id1) id2
- in
- List.fold_left (fun acc (_,_,id,_,_) -> aux acc id) acc goalproof
-;;
-
-let string_of_id (id_to_eq,_) names id =
- if id = 0 then "" else
- try
- let (_,p,(t,l,r,_),m,_) = open_equality (M.find id id_to_eq) in
- match p with
- | Exact t ->
- Printf.sprintf "%d = %s: %s = %s [%s]" id
- (CicPp.pp t names) (CicPp.pp l names) (CicPp.pp r names)
-(* "..." *)
- (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m))
- | Step (_,(step,id1, (dir,id2), p) ) ->
- Printf.sprintf "%6d: %s %6d %6d %s =(%s) %s [%s]" id
- (string_of_rule step)
- id1 id2 (CicPp.pp l names) (CicPp.pp t names) (CicPp.pp r names)
- (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m))
- (*"..."*)
- with
- Not_found -> assert false
-
-let pp_proof bag names goalproof proof subst id initial_goal =
- String.concat "\n" (List.map (string_of_id bag names) (wfo bag goalproof proof id)) ^
- "\ngoal:\n " ^
- (String.concat "\n "
- (fst (List.fold_right
- (fun (r,pos,i,s,pred) (acc,g) ->
- let _,_,left,right = open_eq g in
- let ty =
- match pos with
- | Utils.Left -> CicReduction.head_beta_reduce (Cic.Appl[pred;right])
- | Utils.Right -> CicReduction.head_beta_reduce (Cic.Appl[pred;left])
- in
- let ty = Subst.apply_subst s ty in
- ("("^ string_of_rule r ^ " " ^ string_of_int i^") -> "
- ^ CicPp.pp ty names) :: acc,ty) goalproof ([],initial_goal)))) ^
- "\nand then subsumed by " ^ string_of_int id ^ " when " ^ Subst.ppsubst subst
-;;
-
-let rec find_deps bag m i =
- if M.mem i m then m
- else
- let p,_,_ = proof_of_id bag i in
- match p with
- | Exact _ -> M.add i [] m
- | Step (_,(_,id1,(_,id2),_)) ->
- let m = find_deps bag m id1 in
- let m = find_deps bag m id2 in
- (* without the uniq there is a stack overflow doing concatenation *)
- let xxx = [id1;id2] @ M.find id1 m @ M.find id2 m in
- let xxx = HExtlib.list_uniq (List.sort Pervasives.compare xxx) in
- M.add i xxx m
-;;
-
-let topological_sort bag l =
- (* build the partial order relation *)
- let m = List.fold_left (fun m i -> find_deps bag m i) M.empty l in
- let m = (* keep only deps inside l *)
- List.fold_left
- (fun m' i ->
- M.add i (List.filter (fun x -> List.mem x l) (M.find i m)) m')
- M.empty l
- in
- let m = M.map (fun x -> Some x) m in
- (* utils *)
- let keys m = M.fold (fun i _ acc -> i::acc) m [] in
- let split l m = List.filter (fun i -> M.find i m = Some []) l in
- let purge l m =
- M.mapi
- (fun k v -> if List.mem k l then None else
- match v with
- | None -> None
- | Some ll -> Some (List.filter (fun i -> not (List.mem i l)) ll))
- m
- in
- let rec aux m res =
- let keys = keys m in
- let ok = split keys m in
- let m = purge ok m in
- let res = ok @ res in
- if ok = [] then res else aux m res
- in
- let rc = List.rev (aux m []) in
- rc
-;;
-
-(* returns the list of ids that should be factorized *)
-let get_duplicate_step_in_wfo bag l p =
- let ol = List.rev l in
- let h = Hashtbl.create 13 in
- (* NOTE: here the n parameter is an approximation of the dependency
- between equations. To do things seriously we should maintain a
- dependency graph. This approximation is not perfect. *)
- let add i =
- let p,_,_ = proof_of_id bag i in
- match p with
- | Exact _ -> true
- | _ ->
- try
- let no = Hashtbl.find h i in
- Hashtbl.replace h i (no+1);
- false
- with Not_found -> Hashtbl.add h i 1;true
- in
- let rec aux = function
- | Exact _ -> ()
- | Step (_,(_,i1,(_,i2),_)) ->
- let go_on_1 = add i1 in
- let go_on_2 = add i2 in
- if go_on_1 then aux (let p,_,_ = proof_of_id bag i1 in p);
- if go_on_2 then aux (let p,_,_ = proof_of_id bag i2 in p)
- in
- aux p;
- List.iter
- (fun (_,_,id,_,_) -> aux (let p,_,_ = proof_of_id bag id in p))
- ol;
- (* now h is complete *)
- let proofs = Hashtbl.fold (fun k count acc-> (k,count)::acc) h [] in
- let proofs = List.filter (fun (_,c) -> c > 1) proofs in
- let res = topological_sort bag (List.map (fun (i,_) -> i) proofs) in
- res
-;;
-
-let build_proof_term bag eq h lift proof =
- let proof_of_id aux id =
- let p,l,r = proof_of_id bag id in
- try List.assoc id h,l,r with Not_found -> aux p, l, r
- in
- let rec aux = function
- | Exact term ->
- CicSubstitution.lift lift term
- | Step (subst,(rule, id1, (pos,id2), pred)) ->
- let p1,_,_ = proof_of_id aux id1 in
- let p2,l,r = proof_of_id aux id2 in
- let varname =
- match rule with
- | SuperpositionRight -> Cic.Name ("SupR" ^ Utils.string_of_pos pos)
- | Demodulation -> Cic.Name ("DemEq"^ Utils.string_of_pos pos)
- | _ -> assert false
- in
- let pred =
- match pred with
- | Cic.Lambda (_,a,b) -> Cic.Lambda (varname,a,b)
- | _ -> assert false
- in
- let p = build_proof_step eq lift subst p1 p2 pos l r pred in
-(* let cond = (not (List.mem 302 (Utils.metas_of_term p)) || id1 = 8 || id1 = 132) in
- if not cond then
- prerr_endline ("ERROR " ^ string_of_int id1 ^ " " ^ string_of_int id2);
- assert cond;*)
- p
- in
- aux proof
-;;
-
-let build_goal_proof ?(contextualize=true) ?(forward=false) bag eq l initial ty se context menv =
- let se = List.map (fun i -> Cic.Meta (i,[])) se in
- let lets = get_duplicate_step_in_wfo bag l initial in
- let letsno = List.length lets in
- let l = if forward then List.rev l else l in
- let lift_list l = List.map (fun (i,t) -> i,CicSubstitution.lift 1 t) l in
- let lets,_,h =
- List.fold_left
- (fun (acc,n,h) id ->
- let p,l,r = proof_of_id bag id in
- let cic = build_proof_term bag eq h n p in
- let real_cic,instance =
- parametrize_proof cic l r
- in
- let h = (id, instance)::lift_list h in
- acc@[id,real_cic],n+1,h)
- ([],0,[]) lets
- in
- let lets =
- List.map (fun (id,cic) -> id,cic,Cic.Implicit (Some `Type)) lets
- in
- let proof,se =
- let rec aux se current_proof = function
- | [] -> current_proof,se
- | (rule,pos,id,subst,pred)::tl ->
- let p,l,r = proof_of_id bag id in
- let p = build_proof_term bag eq h letsno p in
- let pos = if forward then pos else
- if pos = Utils.Left then Utils.Right else Utils.Left in
- let varname =
- match rule with
- | SuperpositionLeft -> Cic.Name ("SupL" ^ Utils.string_of_pos pos)
- | Demodulation -> Cic.Name ("DemG"^ Utils.string_of_pos pos)
- | _ -> assert false
- in
- let pred =
- match pred with
- | Cic.Lambda (_,a,b) -> Cic.Lambda (varname,a,b)
- | _ -> assert false
- in
- let proof =
- build_proof_step eq letsno subst current_proof p pos l r pred
- in
- let proof,se = aux se proof tl in
- Subst.apply_subst_lift letsno subst proof,
- List.map (fun x -> Subst.apply_subst(*_lift letsno*) subst x) se
- in
- aux se (build_proof_term bag eq h letsno initial) l
- in
- let n,proof =
- let initial = proof in
- List.fold_right
- (fun (id,cic,ty) (n,p) ->
- n-1,
- Cic.LetIn (
- Cic.Name ("H"^string_of_int id),
- cic,
- ty,
- p))
- lets (letsno-1,initial)
- in
- let proof =
- if contextualize
- then contextualize_rewrites proof (CicSubstitution.lift letsno ty)
- else proof in
- canonical proof context menv, se
-;;
-
-let refl_proof eq_uri ty term =
- Cic.Appl [Cic.MutConstruct (eq_uri, 0, 1, []); ty; term]
-;;
-
-let metas_of_proof bag p =
- let eq =
- match LibraryObjects.eq_URI () with
- | Some u -> u
- | None ->
- raise
- (ProofEngineTypes.Fail
- (lazy "No default equality defined when calling metas_of_proof"))
- in
- let p = build_proof_term bag eq [] 0 p in
- Utils.metas_of_term p
-;;
-
-let remove_local_context eq =
- let w, p, (ty, left, right, o), menv,id = open_equality eq in
- let p = Utils.remove_local_context p in
- let ty = Utils.remove_local_context ty in
- let left = Utils.remove_local_context left in
- let right = Utils.remove_local_context right in
- w, p, (ty, left, right, o), menv, id
-;;
-
-let relocate newmeta menv to_be_relocated =
- let subst, newmetasenv, newmeta =
- List.fold_right
- (fun i (subst, metasenv, maxmeta) ->
- let _,context,ty = CicUtil.lookup_meta i menv in
- let irl = [] in
- let newmeta = Cic.Meta(maxmeta,irl) in
- let newsubst = Subst.buildsubst i context newmeta ty subst in
- (* newsubst, (maxmeta,context,ty)::metasenv, maxmeta+1) *)
- newsubst, (maxmeta,[],ty)::metasenv, maxmeta+1)
- to_be_relocated (Subst.empty_subst, [], newmeta+1)
- in
- (* let subst = Subst.flatten_subst subst in *)
- let menv = Subst.apply_subst_metasenv subst (menv @ newmetasenv) in
- subst, menv, newmeta
-
-let fix_metas_goal (id_to_eq,newmeta) goal =
- let (proof, menv, ty) = goal in
- let to_be_relocated = List.map (fun i ,_,_ -> i) menv in
- let subst, menv, newmeta = relocate newmeta menv to_be_relocated in
- let ty = Subst.apply_subst subst ty in
- let proof =
- match proof with
- | [] -> assert false (* is a nonsense to relocate the initial goal *)
- | (r,pos,id,s,p) :: tl -> (r,pos,id,Subst.concat subst s,p) :: tl
- in
- (id_to_eq,newmeta+1),(proof, menv, ty)
-;;
-
-let fix_metas (id_to_eq, newmeta) eq =
- let w, p, (ty, left, right, o), menv,_ = open_equality eq in
- let to_be_relocated = List.map (fun i ,_,_ -> i) menv in
- let subst, metasenv, newmeta = relocate newmeta menv to_be_relocated in
- let ty = Subst.apply_subst subst ty in
- let left = Subst.apply_subst subst left in
- let right = Subst.apply_subst subst right in
- let fix_proof = function
- | Exact p -> Exact (Subst.apply_subst subst p)
- | Step (s,(r,id1,(pos,id2),pred)) ->
- Step (Subst.concat s subst,(r,id1,(pos,id2), pred))
- in
- let p = fix_proof p in
- let bag = id_to_eq, newmeta in
- let bag, e = mk_equality bag (w, p, (ty, left, right, o), metasenv) in
- bag, e
-;;
-
-exception NotMetaConvertible;;
-
-let meta_convertibility_aux table t1 t2 =
- let module C = Cic in
- let rec aux ((table_l,table_r) as table) t1 t2 =
- match t1, t2 with
- | C.Meta (m1, tl1), C.Meta (m2, tl2) when m1 = m2 -> table
- | C.Meta (m1, tl1), C.Meta (m2, tl2) when m1 < m2 -> aux table t2 t1
- | C.Meta (m1, tl1), C.Meta (m2, tl2) ->
- let m1_binding, table_l =
- try List.assoc m1 table_l, table_l
- with Not_found -> m2, (m1, m2)::table_l
- and m2_binding, table_r =
- try List.assoc m2 table_r, table_r
- with Not_found -> m1, (m2, m1)::table_r
- in
- if (m1_binding <> m2) || (m2_binding <> m1) then
- raise NotMetaConvertible
- else table_l,table_r
- | C.Var (u1, ens1), C.Var (u2, ens2)
- | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) ->
- aux_ens table ens1 ens2
- | C.Cast (s1, t1), C.Cast (s2, t2)
- | C.Prod (_, s1, t1), C.Prod (_, s2, t2)
- | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2) ->
- let table = aux table s1 s2 in
- aux table t1 t2
- | C.LetIn (_, s1, ty1, t1), C.LetIn (_, s2, ty2, t2) ->
- let table = aux table s1 s2 in
- let table = aux table ty1 ty2 in
- aux table t1 t2
- | C.Appl l1, C.Appl l2 -> (
- try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2)
- when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2
- | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2)
- when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 ->
- aux_ens table ens1 ens2
- | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2)
- when (UriManager.eq u1 u2) && i1 = i2 ->
- let table = aux table s1 s2 in
- let table = aux table t1 t2 in (
- try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> (
- try
- List.fold_left2
- (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) ->
- if i1 <> i2 then raise NotMetaConvertible
- else
- let res = (aux res s1 s2) in aux res t1 t2)
- table il1 il2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> (
- try
- List.fold_left2
- (fun res (n1, s1, t1) (n2, s2, t2) ->
- let res = aux res s1 s2 in aux res t1 t2)
- table il1 il2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | t1, t2 when t1 = t2 -> table
- | _, _ -> raise NotMetaConvertible
-
- and aux_ens table ens1 ens2 =
- let cmp (u1, t1) (u2, t2) =
- Pervasives.compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2)
- in
- let ens1 = List.sort cmp ens1
- and ens2 = List.sort cmp ens2 in
- try
- List.fold_left2
- (fun res (u1, t1) (u2, t2) ->
- if not (UriManager.eq u1 u2) then raise NotMetaConvertible
- else aux res t1 t2)
- table ens1 ens2
- with Invalid_argument _ -> raise NotMetaConvertible
- in
- aux table t1 t2
-;;
-
-
-let meta_convertibility_eq eq1 eq2 =
- let _, _, (ty, left, right, _), _,_ = open_equality eq1 in
- let _, _, (ty', left', right', _), _,_ = open_equality eq2 in
- if ty <> ty' then
- false
- else if (left = left') && (right = right') then
- true
- else if (left = right') && (right = left') then
- true
- else
- try
- let table = meta_convertibility_aux ([],[]) left left' in
- let _ = meta_convertibility_aux table right right' in
- true
- with NotMetaConvertible ->
- try
- let table = meta_convertibility_aux ([],[]) left right' in
- let _ = meta_convertibility_aux table right left' in
- true
- with NotMetaConvertible ->
- false
-;;
-
-let meta_convertibility t1 t2 =
- if t1 = t2 then
- true
- else
- try
- ignore(meta_convertibility_aux ([],[]) t1 t2);
- true
- with NotMetaConvertible ->
- false
-;;
-
-let meta_convertibility_subst t1 t2 menv =
- if t1 = t2 then
- Some([])
- else
- try
- let (l,_) = meta_convertibility_aux ([],[]) t1 t2 in
- let subst =
- List.map
- (fun (x,y) ->
- try
- let (_,c,t) = CicUtil.lookup_meta x menv in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable c in
- (y,(c,Cic.Meta(x,irl),t))
- with CicUtil.Meta_not_found _ ->
- try
- let (_,c,t) = CicUtil.lookup_meta y menv in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable c in
- (x,(c,Cic.Meta(y,irl),t))
- with CicUtil.Meta_not_found _ -> assert false) l in
- Some subst
- with NotMetaConvertible ->
- None
-;;
-
-exception TermIsNotAnEquality;;
-
-let term_is_equality term =
- match term with
- | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _]
- when LibraryObjects.is_eq_URI uri -> true
- | _ -> false
-;;
-
-let equality_of_term bag proof term newmetas =
- match term with
- | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2]
- when LibraryObjects.is_eq_URI uri ->
- let o = !Utils.compare_terms t1 t2 in
- let stat = (ty,t1,t2,o) in
- let w = Utils.compute_equality_weight stat in
- let bag, e = mk_equality bag (w, Exact proof, stat,newmetas) in
- bag, e
- | _ ->
- raise TermIsNotAnEquality
-;;
-
-let is_weak_identity eq =
- let _,_,(_,left, right,_),_,_ = open_equality eq in
- left = right
- (* doing metaconv here is meaningless *)
-;;
-
-let is_identity (_, context, ugraph) eq =
- let _,_,(ty,left,right,_),menv,_ = open_equality eq in
- (* doing metaconv here is meaningless *)
- left = right
-(* fst (CicReduction.are_convertible ~metasenv:menv context left right ugraph)
- * *)
-;;
-
-
-let term_of_equality eq_uri equality =
- let _, _, (ty, left, right, _), menv, _= open_equality equality in
- let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in
- let argsno = List.length menv in
- let t =
- CicSubstitution.lift argsno
- (Cic.Appl [Cic.MutInd (eq_uri, 0, []); ty; left; right])
- in
- snd (
- List.fold_right
- (fun (i,_,ty) (n, t) ->
- let name = Cic.Name ("X" ^ (string_of_int n)) in
- let ty = CicSubstitution.lift (n-1) ty in
- let t =
- ProofEngineReduction.replace
- ~equality:eq ~what:[i]
- ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t
- in
- (n-1, Cic.Prod (name, ty, t)))
- menv (argsno, t))
-;;
-
-let symmetric bag eq_ty l id uri m =
- let eq = Cic.MutInd(uri,0,[]) in
- let pred =
- Cic.Lambda (Cic.Name "Sym",eq_ty,
- Cic.Appl [CicSubstitution.lift 1 eq ;
- CicSubstitution.lift 1 eq_ty;
- Cic.Rel 1;CicSubstitution.lift 1 l])
- in
- let prefl =
- Exact (Cic.Appl
- [Cic.MutConstruct(uri,0,1,[]);eq_ty;l])
- in
- let bag, id1 =
- let bag, eq = mk_equality bag (0,prefl,(eq_ty,l,l,Utils.Eq),m) in
- let (_,_,_,_,id) = open_equality eq in
- bag, id
- in
- bag, Step(Subst.empty_subst,
- (Demodulation,id1,(Utils.Left,id),pred))
-;;
-
-module IntOT = struct
- type t = int
- let compare = Pervasives.compare
-end
-
-module IntSet = Set.Make(IntOT);;
-
-let n_purged = ref 0;;
-
-let collect ((id_to_eq,maxmeta) as bag) alive1 alive2 alive3 =
- let deps_of id =
- let p,_,_ = proof_of_id bag id in
- match p with
- | Exact _ -> IntSet.empty
- | Step (_,(_,id1,(_,id2),_)) ->
- IntSet.add id1 (IntSet.add id2 IntSet.empty)
- in
- let rec close s =
- let news = IntSet.fold (fun id s -> IntSet.union (deps_of id) s) s s in
- if IntSet.equal news s then s else close news
- in
- let l_to_s s l = List.fold_left (fun s x -> IntSet.add x s) s l in
- let alive_set = l_to_s (l_to_s (l_to_s IntSet.empty alive2) alive1) alive3 in
- let closed_alive_set = close alive_set in
- let to_purge =
- M.fold
- (fun k _ s ->
- if not (IntSet.mem k closed_alive_set) then
- k::s else s) id_to_eq []
- in
- n_purged := !n_purged + List.length to_purge;
- List.fold_right M.remove to_purge id_to_eq, maxmeta
-;;
-
-let get_stats () = ""
-(*
- <:show<Equality.>> ^
- "# of purged eq by the collector: " ^ string_of_int !n_purged ^ "\n"
-*)
-;;
-
-let rec pp_proofterm name t context =
- let rec skip_lambda tys ctx = function
- | Cic.Lambda (n,s,t) -> skip_lambda (s::tys) ((Some n)::ctx) t
- | t -> ctx,tys,t
- in
- let rename s name =
- match name with
- | Cic.Name s1 -> Cic.Name (s ^ s1)
- | _ -> assert false
- in
- let rec skip_letin ctx = function
- | Cic.LetIn (n,b,_,t) ->
- pp_proofterm (Some (rename "Lemma " n)) b ctx::
- skip_letin ((Some n)::ctx) t
- | t ->
- let ppterm t = CicPp.pp t ctx in
- let rec pp inner = function
- | Cic.Appl [Cic.Const (uri,[]);_;l;m;r;p1;p2]
- when Pcre.pmatch ~pat:"trans_eq" (UriManager.string_of_uri uri)->
- if not inner then
- (" " ^ ppterm l) :: pp true p1 @
- [ " = " ^ ppterm m ] @ pp true p2 @
- [ " = " ^ ppterm r ]
- else
- pp true p1 @
- [ " = " ^ ppterm m ] @ pp true p2
- | Cic.Appl [Cic.Const (uri,[]);_;l;m;p]
- when Pcre.pmatch ~pat:"sym_eq" (UriManager.string_of_uri uri)->
- pp true p
- | Cic.Appl [Cic.Const (uri,[]);_;_;_;_;_;p]
- when Pcre.pmatch ~pat:"eq_f" (UriManager.string_of_uri uri)->
- pp true p
- | Cic.Appl [Cic.Const (uri,[]);_;_;_;_;_;p]
- when Pcre.pmatch ~pat:"eq_OF_eq" (UriManager.string_of_uri uri)->
- pp true p
- | Cic.Appl [Cic.MutConstruct (uri,_,_,[]);_;_;t;p]
- when Pcre.pmatch ~pat:"ex.ind" (UriManager.string_of_uri uri)->
- [ "witness " ^ ppterm t ] @ pp true p
- | Cic.Appl (t::_) ->[ " [by " ^ ppterm t ^ "]"]
- | t ->[ " [by " ^ ppterm t ^ "]"]
- in
- let rec compat = function
- | a::b::tl -> (b ^ a) :: compat tl
- | h::[] -> [h]
- | [] -> []
- in
- let compat l = List.hd l :: compat (List.tl l) in
- compat (pp false t) @ ["";""]
- in
- let names, tys, body = skip_lambda [] context t in
- let ppname name = (match name with Some (Cic.Name s) -> s | _ -> "") in
- ppname name ^ ":\n" ^
- (if context = [] then
- let rec pp_l ctx = function
- | (t,name)::tl ->
- " " ^ ppname name ^ ": " ^ CicPp.pp t ctx ^ "\n" ^
- pp_l (name::ctx) tl
- | [] -> "\n\n"
- in
- pp_l [] (List.rev (List.combine tys names))
- else "")
- ^
- String.concat "\n" (skip_letin names body)
-;;
-
-let pp_proofterm t =
- "\n\n" ^
- pp_proofterm (Some (Cic.Name "Hypothesis")) t []
-;;
-
-let initial_nameset_list = [
- "x"; "y"; "z"; "t"; "u"; "v"; "a"; "b"; "c"; "d";
- "e"; "l"; "m"; "n"; "o"; "p"; "q"; "r";
-]
-
-module S = Set.Make(String)
-
-let initial_nameset = List.fold_right S.add initial_nameset_list S.empty, [];;
-
-let freshname (nameset, subst) term =
- let m = CicUtil.metas_of_term term in
- let nameset, subst =
- List.fold_left
- (fun (set,rc) (m,_) ->
- if List.mem_assoc m rc then set,rc else
- let name = S.choose set in
- let set = S.remove name set in
- set,
- (m,Cic.Const(UriManager.uri_of_string
- ("cic:/"^name^".con"),[]))::rc)
- (nameset,subst) m
- in
- let term =
- ProofEngineReduction.replace
- ~equality:(fun i t -> match t with Cic.Meta (j,_) -> i=j| _ -> false)
- ~what:(List.map fst subst)
- ~with_what:(List.map snd subst) ~where:term
- in
- (nameset, subst), term
-;;
-
-let remove_names_in_context (set,subst) names =
- List.fold_left
- (fun s n ->
- match n with Some (Cic.Name n) -> S.remove n s | _ -> s)
- set names, subst
-;;
-
-let string_of_id2 (id_to_eq,_) names nameset id =
- if id = 0 then "" else
- try
- let (_,_,(_,l,r,_),_,_) = open_equality (M.find id id_to_eq) in
- let nameset, l = freshname nameset l in
- let nameset, r = freshname nameset r in
- Printf.sprintf "%s = %s" (CicPp.pp l names) (CicPp.pp r names)
- with
- Not_found -> assert false
-;;
-
-let draw_proof bag names goal_proof proof id =
- let b = Buffer.create 100 in
- let fmt = Format.formatter_of_buffer b in
- let sint = string_of_int in
- let fst3 (x,_,_) = x in
- let visited = ref [] in
- let nameset = remove_names_in_context initial_nameset names in
- let rec fact id = function
- | Exact t ->
- if not (List.mem id !visited) then
- begin
- visited := id :: !visited;
- let nameset, t = freshname nameset t in
- let t = CicPp.pp t names in
- GraphvizPp.Dot.node (sint id)
- ~attrs:["label",t^":"^string_of_id2 bag names nameset id;
- "shape","rectangle"] fmt;
- end
- | Step (_,(_,id1,(_,id2),_)) ->
- GraphvizPp.Dot.edge (sint id) (sint id1) fmt;
- GraphvizPp.Dot.edge (sint id) (sint id2) fmt;
- let p1,_,_ = proof_of_id bag id1 in
- let p2,_,_ = proof_of_id bag id2 in
- fact id1 p1;
- fact id2 p2;
- if not (List.mem id !visited); then
- begin
- visited := id :: !visited;
- GraphvizPp.Dot.node (sint id)
- ~attrs:["label",sint id^":"^string_of_id2 bag names nameset id;
- "shape","ellipse"] fmt
- end
- in
- let sleft acc (_,_,id,_,_) =
- if acc != 0 then GraphvizPp.Dot.edge (sint acc) (sint id) fmt;
- fact id (fst3 (proof_of_id bag id));
- id
- in
- GraphvizPp.Dot.header ~node_attrs:["fontsize","10"; ] fmt;
- ignore(List.fold_left sleft id goal_proof);
- GraphvizPp.Dot.trailer fmt;
- let oc = open_out "/tmp/matita_paramod.dot" in
- Buffer.output_buffer oc b;
- close_out oc;
- Utils.debug_print (lazy "dot!");
- ignore(Unix.system
- "dot -Tps -o /tmp/matita_paramod.eps /tmp/matita_paramod.dot"
-(* "cat /tmp/matita_paramod.dot| tred | dot -Tps -o /tmp/matita_paramod.eps" *)
- );
- ignore(Unix.system "gv /tmp/matita_paramod.eps");
-;;
-
-let saturate_term (id_to_eq, maxmeta) metasenv subst context term =
- let maxmeta = max maxmeta (CicMkImplicit.new_meta metasenv subst) in
- let head, metasenv, args, newmeta =
- TermUtil.saturate_term maxmeta metasenv context term 0
- in
- (id_to_eq, newmeta), head, metasenv, args
-;;
-
-let push_maxmeta (id_to_eq, maxmeta) m = id_to_eq, max maxmeta m ;;
-let filter_metasenv_gt_maxmeta (_,maxmeta) =
- List.filter (fun (j,_,_) -> j >= maxmeta)
-;;
-let maxmeta = snd;;
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type rule = SuperpositionRight | SuperpositionLeft | Demodulation
-
-(* every equality group has its own bag. the bag contains the infos necessary
- * for building the proof. FIXME: should also contain maxmeta! *)
-type equality_bag
-
-val mk_equality_bag: unit -> equality_bag
-
-type equality
-
-and proof =
- Exact of Cic.term
- | Step of Subst.substitution * (rule * int * (Utils.pos * int) * Cic.term)
-
-and goal_proof = (rule * Utils.pos * int * Subst.substitution * Cic.term) list
-
-type goal = goal_proof * Cic.metasenv * Cic.term
-
-val pp_proof:
- equality_bag ->
- (Cic.name option) list -> goal_proof -> proof -> Subst.substitution -> int ->
- Cic.term -> string
-
-val draw_proof:
- equality_bag ->
- (Cic.name option) list -> goal_proof -> proof -> int -> unit
-
-val pp_proofterm: Cic.term -> string
-
-val mk_eq_ind :
- UriManager.uri ->
- Cic.term ->
- Cic.term ->
- Cic.term ->
- Cic.term ->
- Cic.term ->
- Cic.term ->
- Cic.term
-
-val mk_equality :
- equality_bag -> int * proof *
- (Cic.term * Cic.term * Cic.term * Utils.comparison) *
- Cic.metasenv -> equality_bag * equality
-
-val mk_tmp_equality :
- int * (Cic.term * Cic.term * Cic.term * Utils.comparison) * Cic.metasenv ->
- equality
-
-val open_equality :
- equality ->
- int * proof *
- (Cic.term * Cic.term * Cic.term * Utils.comparison) *
- Cic.metasenv * int
-val depend : equality_bag -> equality -> int -> bool
-val compare : equality -> equality -> int
-val max_weight_in_proof : equality_bag -> int -> proof -> int
-val max_weight : equality_bag -> goal_proof -> proof -> int
-val string_of_equality :
- ?env:Utils.environment -> equality -> string
-val string_of_proof :
- ?names:(Cic.name option)list -> equality_bag -> proof -> goal_proof -> string
-(* given a proof and a list of meta indexes we are interested in the
- * instantiation gives back the cic proof and the list of instantiations *)
-(* build_goal_proof [eq_URI] [goal_proof] [initial_proof] [ty]
- * [ty] is the type of the goal *)
-val build_goal_proof:
- ?contextualize:bool ->
- ?forward:bool ->
- equality_bag ->
- UriManager.uri -> goal_proof -> proof -> Cic.term-> int list ->
- Cic.context -> Cic.metasenv ->
- Cic.term * Cic.term list
-val build_proof_term :
- equality_bag ->
- UriManager.uri -> (int * Cic.term) list -> int -> proof -> Cic.term
-val refl_proof: UriManager.uri -> Cic.term -> Cic.term -> Cic.term
-(** ensures that metavariables in equality are unique *)
-val fix_metas_goal: equality_bag -> goal -> equality_bag * goal
-val fix_metas: equality_bag -> equality -> equality_bag * equality
-val metas_of_proof: equality_bag -> proof -> int list
-
-(* this should be used _only_ to apply (efficiently) this subst on the
- * initial proof passed to build_goal_proof *)
-val add_subst : Subst.substitution -> proof -> proof
-exception TermIsNotAnEquality;;
-
-(**
- raises TermIsNotAnEquality if term is not an equation.
- The first Cic.term is a proof of the equation
-*)
-val equality_of_term:
- equality_bag -> Cic.term -> Cic.term -> Cic.metasenv ->
- equality_bag * equality
-
-(**
- Re-builds the term corresponding to this equality
-*)
-val term_of_equality: UriManager.uri -> equality -> Cic.term
-val term_is_equality: Cic.term -> bool
-
-val saturate_term :
- equality_bag -> Cic.metasenv -> Cic.substitution -> Cic.context -> Cic.term ->
- equality_bag * Cic.term * Cic.metasenv * Cic.term list
-
-val push_maxmeta : equality_bag -> int -> equality_bag
-val maxmeta : equality_bag -> int
-val filter_metasenv_gt_maxmeta: equality_bag -> Cic.metasenv -> Cic.metasenv
-
-(** tests a sort of alpha-convertibility between the two terms, but on the
- metavariables *)
-val meta_convertibility: Cic.term -> Cic.term -> bool
-
-(** meta convertibility between two equations *)
-val meta_convertibility_eq: equality -> equality -> bool
-val meta_convertibility_subst:
- Cic.term -> Cic.term -> Cic.metasenv -> Cic.substitution option
-
-val is_weak_identity: equality -> bool
-val is_identity: Utils.environment -> equality -> bool
-
-val is_in: equality_bag -> int -> bool
-
-(* symmetric [eq_ty] [l] [id] [uri] [m]
- *
- * given an equality (_,p,(_,[l],r,_),[m],[id]) of 'type' l=r
- * returns the proof of the symmetric (r=l).
- *
- * [uri] is the uri of eq
- * [eq_ty] the ty of the equality sides
- *)
-val symmetric:
- equality_bag -> Cic.term -> Cic.term -> int -> UriManager.uri ->
- Cic.metasenv -> equality_bag * proof
-
-(* takes 3 lists of alive ids (they are threated the same way, the type is
- * funny just to not oblige you to concatenate them) and drops all the dead
- * equalities *)
-val collect: equality_bag -> int list -> int list -> int list -> equality_bag
-
-(* given an equality, returns the numerical id *)
-val id_of: equality -> int
-
-(* profiling statistics *)
-val get_stats: unit -> string
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module type EqualityIndex =
- sig
- module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality
- type t = Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet).t
- val empty : t
- val retrieve_generalizations : t -> Cic.term -> PosEqSet.t
- val retrieve_unifiables : t -> Cic.term -> PosEqSet.t
- val init_index : unit -> unit
- val remove_index : t -> Equality.equality -> t
- val index : t -> Equality.equality -> t
- val in_index : t -> Equality.equality -> bool
- val iter : t -> (Cic_indexable.CicIndexable.constant_name Discrimination_tree.path -> PosEqSet.t -> unit) -> unit
- end
-
-module DT =
-struct
- module OrderedPosEquality = struct
- type t = Utils.pos * Equality.equality
- let compare (p1,e1) (p2,e2) =
- let rc = Pervasives.compare p1 p2 in
- if rc = 0 then Equality.compare e1 e2 else rc
- end
-
- module PosEqSet = Set.Make(OrderedPosEquality);;
-
- include Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet)
-
-
- (* DISCRIMINATION TREES *)
- let init_index () = () ;;
-
- let remove_index tree equality =
- let _, _, (_, l, r, ordering), _,_ = Equality.open_equality equality in
- match ordering with
- | Utils.Gt -> remove_index tree l (Utils.Left, equality)
- | Utils.Lt -> remove_index tree r (Utils.Right, equality)
- | _ ->
- let tree = remove_index tree r (Utils.Right, equality) in
- remove_index tree l (Utils.Left, equality)
-
- let index tree equality =
- let _, _, (_, l, r, ordering), _,_ = Equality.open_equality equality in
- match ordering with
- | Utils.Gt -> index tree l (Utils.Left, equality)
- | Utils.Lt -> index tree r (Utils.Right, equality)
- | _ ->
- let tree = index tree r (Utils.Right, equality) in
- index tree l (Utils.Left, equality)
-
-
- let in_index tree equality =
- let _, _, (_, l, r, ordering), _,_ = Equality.open_equality equality in
- let meta_convertibility (pos,equality') =
- Equality.meta_convertibility_eq equality equality'
- in
- in_index tree l meta_convertibility || in_index tree r meta_convertibility
-
- end
-
-module PT =
- struct
- module OrderedPosEquality = struct
- type t = Utils.pos * Equality.equality
- let compare (p1,e1) (p2,e2) =
- let rc = Pervasives.compare p1 p2 in
- if rc = 0 then Equality.compare e1 e2 else rc
- end
-
- module PosEqSet = Set.Make(OrderedPosEquality);;
-
- include Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet)
-
-
- (* DISCRIMINATION TREES *)
- let init_index () = () ;;
-
- let remove_index tree equality =
- let _, _, (_, l, r, ordering), _,_ = Equality.open_equality equality in
- match ordering with
- | Utils.Gt -> remove_index tree l (Utils.Left, equality)
- | Utils.Lt -> remove_index tree r (Utils.Right, equality)
- | _ ->
- let tree = remove_index tree r (Utils.Right, equality) in
- remove_index tree l (Utils.Left, equality)
-
- let index tree equality =
- let _, _, (_, l, r, ordering), _,_ = Equality.open_equality equality in
- match ordering with
- | Utils.Gt -> index tree l (Utils.Left, equality)
- | Utils.Lt -> index tree r (Utils.Right, equality)
- | _ ->
- let tree = index tree r (Utils.Right, equality) in
- index tree l (Utils.Left, equality)
-
-
- let in_index tree equality =
- let _, _, (_, l, r, ordering), _,_ = Equality.open_equality equality in
- let meta_convertibility (pos,equality') =
- Equality.meta_convertibility_eq equality equality'
- in
- in_index tree l meta_convertibility || in_index tree r meta_convertibility
-end
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module type EqualityIndex =
- sig
- module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality
- type t = Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet).t
- val empty : t
- val retrieve_generalizations : t -> Cic.term -> PosEqSet.t
- val retrieve_unifiables : t -> Cic.term -> PosEqSet.t
- val init_index : unit -> unit
- val remove_index : t -> Equality.equality -> t
- val index : t -> Equality.equality -> t
- val in_index : t -> Equality.equality -> bool
- val iter : t -> (Cic_indexable.CicIndexable.constant_name Discrimination_tree.path -> PosEqSet.t -> unit) -> unit
- end
-
-module DT : EqualityIndex
-module PT : EqualityIndex
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* let _profiler = <:profiler<_profiler>>;; *)
-
-(* $Id$ *)
-
-open Utils;;
-open Printf;;
-
-let debug_print s = ();;(*prerr_endline (Lazy.force s);;*)
-
-let check_disjoint_invariant subst metasenv msg =
- if (List.exists
- (fun (i,_,_) -> (Subst.is_in_subst i subst)) metasenv)
- then
- begin
- prerr_endline ("not disjoint: " ^ msg);
- assert false
- end
-;;
-
-let rec check_irl start = function
- | [] -> true
- | None::tl -> check_irl (start+1) tl
- | (Some (Cic.Rel x))::tl ->
- if x = start then check_irl (start+1) tl else false
- | _ -> false
-;;
-
-let rec is_simple_term = function
- | Cic.Appl ((Cic.Meta _)::_) -> false
- | Cic.Appl l -> List.for_all is_simple_term l
- | Cic.Meta (i, l) -> let l = [] in check_irl 1 l
- | Cic.Rel _ -> true
- | Cic.Const _ -> true
- | Cic.MutInd (_, _, []) -> true
- | Cic.MutConstruct (_, _, _, []) -> true
- | _ -> false
-;;
-
-let locked menv i =
- List.exists (fun (j,_,_) -> i = j) menv
-;;
-
-let unification_simple locked_menv metasenv context t1 t2 ugraph =
- let module C = Cic in
- let module M = CicMetaSubst in
- let module U = CicUnification in
- let lookup = Subst.lookup_subst in
- let rec occurs_check subst what where =
- match where with
- | Cic.Meta(i,_) when i = what -> true
- | C.Appl l -> List.exists (occurs_check subst what) l
- | C.Meta _ ->
- let t = lookup where subst in
- if t <> where then occurs_check subst what t else false
- | _ -> false
- in
- let rec unif subst menv s t =
- let s = match s with C.Meta _ -> lookup s subst | _ -> s
- and t = match t with C.Meta _ -> lookup t subst | _ -> t
-
- in
- match s, t with
- | s, t when s = t -> subst, menv
- (* sometimes the same meta has different local contexts; this
- could create "cyclic" substitutions *)
- | C.Meta (i, _), C.Meta (j, _) when i=j -> subst, menv
- | C.Meta (i, _), C.Meta (j, _)
- when (locked locked_menv i) &&(locked locked_menv j) ->
- raise
- (U.UnificationFailure (lazy "Inference.unification.unif"))
- | C.Meta (i, _), C.Meta (j, _) when (locked locked_menv i) ->
- unif subst menv t s
- | C.Meta (i, _), C.Meta (j, _) when (i > j) && not (locked locked_menv j) ->
- unif subst menv t s
- | C.Meta (i,_), t when occurs_check subst i t ->
- raise
- (U.UnificationFailure (lazy "Inference.unification.unif"))
- | C.Meta (i, l), t when (locked locked_menv i) ->
- raise
- (U.UnificationFailure (lazy "Inference.unification.unif"))
- | C.Meta (i, l), t -> (
- try
- let _, _, ty = CicUtil.lookup_meta i menv in
- let subst = Subst.buildsubst i context t ty subst in
- subst, menv
- with CicUtil.Meta_not_found m ->
- let names = names_of_context context in
- (*debug_print
- (lazy*) prerr_endline
- (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m
- (CicPp.pp t1 names) (CicPp.pp t2 names)
- (print_metasenv menv) (print_metasenv metasenv));
- assert false
- )
- | _, C.Meta _ -> unif subst menv t s
- | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt ->
- raise (U.UnificationFailure (lazy "Inference.unification.unif"))
- | C.Appl (hds::tls), C.Appl (hdt::tlt) -> (
- try
- List.fold_left2
- (fun (subst', menv) s t -> unif subst' menv s t)
- (subst, menv) tls tlt
- with Invalid_argument _ ->
- raise (U.UnificationFailure (lazy "Inference.unification.unif"))
- )
- | _, _ ->
- raise (U.UnificationFailure (lazy "Inference.unification.unif"))
- in
- let subst, menv = unif Subst.empty_subst metasenv t1 t2 in
- let menv = Subst.filter subst menv in
- subst, menv, ugraph
-;;
-
-let profiler = HExtlib.profile "P/Inference.unif_simple[flatten]"
-let profiler2 = HExtlib.profile "P/Inference.unif_simple[flatten_fast]"
-let profiler3 = HExtlib.profile "P/Inference.unif_simple[resolve_meta]"
-let profiler4 = HExtlib.profile "P/Inference.unif_simple[filter]"
-
-let check_for_duplicates metas msg =
- let rec aux = function
- | [] -> true
- | (m,_,_)::tl ->
- not (List.exists (fun (i, _, _) -> i = m) tl) && aux tl in
- let b = aux metas in
- if not b then
- begin
- prerr_endline ("DUPLICATI ---- " ^ msg);
- prerr_endline (CicMetaSubst.ppmetasenv [] metas);
- assert false
- end
- else b
-;;
-
-let check_metasenv msg menv =
- List.iter
- (fun (i,ctx,ty) ->
- try ignore(CicTypeChecker.type_of_aux' menv ctx ty
- CicUniv.empty_ugraph)
- with
- | CicUtil.Meta_not_found _ ->
- prerr_endline (msg ^ CicMetaSubst.ppmetasenv [] menv);
- assert false
- | _ -> ()
- ) menv
-;;
-
-let unification_aux b metasenv1 metasenv2 context t1 t2 ugraph =
- let metasenv = metasenv1@metasenv2 in
- if Utils.debug_metas then
- begin
- ignore(check_for_duplicates metasenv "unification_aux");
- check_metasenv "unification_aux" metasenv;
- end;
- let subst, menv, ug =
- if not (is_simple_term t1) || not (is_simple_term t2) then (
- debug_print
- (lazy
- (Printf.sprintf "NOT SIMPLE TERMS: %s %s"
- (CicPp.ppterm t1) (CicPp.ppterm t2)));
- raise (CicUnification.UnificationFailure (lazy "Inference.unification.unif"))
- ) else
- if b then
- (* full unification *)
- unification_simple [] metasenv context t1 t2 ugraph
- else
- (* matching: metasenv1 is locked *)
- unification_simple metasenv1 metasenv context t1 t2 ugraph
- in
- if Utils.debug_res then
- ignore(check_disjoint_invariant subst menv "unif");
- (* let flatten subst =
- List.map
- (fun (i, (context, term, ty)) ->
- let context = apply_subst_context subst context in
- let term = apply_subst subst term in
- let ty = apply_subst subst ty in
- (i, (context, term, ty))) subst
- in
- let flatten subst = profiler.HExtlib.profile flatten subst in
- let subst = flatten subst in *)
- if Utils.debug_metas then
- ignore(check_for_duplicates menv "unification_aux prima di apply_subst");
- let menv = Subst.apply_subst_metasenv subst menv in
- if Utils.debug_metas then
- (let _ = check_for_duplicates menv "unif_aux after" in
- check_metasenv "unification_aux after 1" menv);
- subst, menv, ug
-;;
-
-exception MatchingFailure;;
-
-(** matching takes in input the _disjoint_ metasenv of t1 and t2;
-it perform unification in the union metasenv, then check that
-the first metasenv has not changed *)
-let matching metasenv1 metasenv2 context t1 t2 ugraph =
- try
- unification_aux false metasenv1 metasenv2 context t1 t2 ugraph
- with
- CicUnification.UnificationFailure _ ->
- raise MatchingFailure
-;;
-
-let unification m1 m2 c t1 t2 ug =
- let m1 =
- if (m1 = m2 && m1 <> []) then assert false
- (* (prerr_endline "eccoci 2"; []) *) else m1 in
- (*
- prerr_endline (CicPp.ppterm t1);
- prerr_endline (CicPp.ppterm t2);
- prerr_endline "++++++++++"; *)
- try
- unification_aux true m1 m2 c t1 t2 ug
- with exn ->
- raise exn
-;;
-
-let get_stats () = "" (*<:show<Inference.>>*) ;;
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception MatchingFailure
-
-(** matching between two terms. Can raise MatchingFailure *)
-val matching:
- Cic.metasenv -> Cic.metasenv -> Cic.context ->
- Cic.term -> Cic.term ->
- CicUniv.universe_graph ->
- Subst.substitution * Cic.metasenv * CicUniv.universe_graph
-
-(**
- special unification that checks if the two terms are "simple", and in
- such case should be significantly faster than CicUnification.fo_unif
-*)
-val unification:
- Cic.metasenv -> Cic.metasenv -> Cic.context ->
- Cic.term -> Cic.term ->
- CicUniv.universe_graph ->
- Subst.substitution * Cic.metasenv * CicUniv.universe_graph
-
-val get_stats: unit -> string
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* let _profiler = <:profiler<_profiler>>;; *)
-
-(* $Id$ *)
-
-module Index = Equality_indexing.DT (* discrimination tree based indexing *)
-(*
-module Index = Equality_indexing.DT (* path tree based indexing *)
-*)
-
-let debug_print = Utils.debug_print;;
-
-(*
-for debugging
-let check_equation env equation msg =
- let w, proof, (eq_ty, left, right, order), metas, args = equation in
- let metasenv, context, ugraph = env
- let metasenv' = metasenv @ metas in
- try
- CicTypeChecker.type_of_aux' metasenv' context left ugraph;
- CicTypeChecker.type_of_aux' metasenv' context right ugraph;
- ()
- with
- CicUtil.Meta_not_found _ as exn ->
- begin
- prerr_endline msg;
- prerr_endline (CicPp.ppterm left);
- prerr_endline (CicPp.ppterm right);
- raise exn
- end
-*)
-
-type retrieval_mode = Matching | Unification;;
-
-let string_of_res ?env =
- function
- None -> "None"
- | Some (t, s, m, u, (p,e)) ->
- Printf.sprintf "Some: (%s, %s, %s)"
- (Utils.string_of_pos p)
- (Equality.string_of_equality ?env e)
- (CicPp.ppterm t)
-;;
-
-let print_res ?env res =
- prerr_endline
- (String.concat "\n"
- (List.map (string_of_res ?env) res))
-;;
-
-let print_candidates ?env mode term res =
- let _ =
- match mode with
- | Matching ->
- prerr_endline ("| candidates Matching " ^ (CicPp.ppterm term))
- | Unification ->
- prerr_endline ("| candidates Unification " ^ (CicPp.ppterm term))
- in
- prerr_endline
- (String.concat "\n"
- (List.map
- (fun (p, e) ->
- Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p)
- (Equality.string_of_equality ?env e))
- res));
-;;
-
-
-let apply_subst = Subst.apply_subst
-
-let index = Index.index
-let remove_index = Index.remove_index
-let in_index = Index.in_index
-let empty = Index.empty
-let init_index = Index.init_index
-
-let check_disjoint_invariant subst metasenv msg =
- if (List.exists
- (fun (i,_,_) -> (Subst.is_in_subst i subst)) metasenv)
- then
- begin
- prerr_endline ("not disjoint: " ^ msg);
- assert false
- end
-;;
-
-let check_for_duplicates metas msg =
- let rec aux = function
- | [] -> true
- | (m,_,_)::tl -> not (List.exists (fun (i, _, _) -> i = m) tl) && aux tl in
- let b = aux metas in
- if not b then
- begin
- prerr_endline ("DUPLICATI " ^ msg);
- prerr_endline (CicMetaSubst.ppmetasenv [] metas);
- assert false
- end
- else ()
-;;
-
-let check_metasenv msg menv =
- List.iter
- (fun (i,ctx,ty) ->
- try ignore(CicTypeChecker.type_of_aux' menv ctx ty
- CicUniv.empty_ugraph)
- with
- | CicUtil.Meta_not_found _ ->
- prerr_endline (msg ^ CicMetaSubst.ppmetasenv [] menv);
- assert false
- | _ -> ()
- ) menv
-;;
-
-(* the metasenv returned by res must included in the original one,
-due to matching. If it fails, it is probably because we are not
-demodulating with a unit equality *)
-
-let not_unit_eq ctx eq =
- let (_,_,(ty,left,right,o),metas,_) = Equality.open_equality eq in
- let b =
- List.exists
- (fun (_,_,ty) ->
- try
- let s,_ = CicTypeChecker.type_of_aux' metas ctx ty CicUniv.oblivion_ugraph
- in s = Cic.Sort(Cic.Prop)
- with _ ->
- prerr_endline ("ERROR typing " ^ CicPp.ppterm ty); assert false) metas
- in b
-(*
-if b then prerr_endline ("not a unit equality: " ^ Equality.string_of_equality eq); b *)
-;;
-
-let check_demod_res res metasenv msg =
- match res with
- | Some (_, _, menv, _, _) ->
- let b =
- List.for_all
- (fun (i,_,_) ->
- (List.exists (fun (j,_,_) -> i=j) metasenv)) menv
- in
- if (not b) then
- begin
- debug_print (lazy ("extended context " ^ msg));
- debug_print (lazy (CicMetaSubst.ppmetasenv [] menv));
- end;
- b
- | None -> false
-;;
-
-let check_res res msg =
- match res with
- | Some (t, subst, menv, ug, eq_found) ->
- let eqs = Equality.string_of_equality (snd eq_found) in
- check_metasenv msg menv;
- check_disjoint_invariant subst menv msg;
- check_for_duplicates menv (msg ^ "\nchecking " ^ eqs);
- | None -> ()
-;;
-
-let check_target bag context target msg =
- let w, proof, (eq_ty, left, right, order), metas,_ =
- Equality.open_equality target in
- (* check that metas does not contains duplicates *)
- let eqs = Equality.string_of_equality target in
- let _ = check_for_duplicates metas (msg ^ "\nchecking " ^ eqs) in
- let actual = (Utils.metas_of_term left)@(Utils.metas_of_term right)
- @(Utils.metas_of_term eq_ty)@(Equality.metas_of_proof bag proof) in
- let menv = List.filter (fun (i, _, _) -> List.mem i actual) metas in
- let _ = if menv <> metas then
- begin
- prerr_endline ("extra metas " ^ msg);
- prerr_endline (CicMetaSubst.ppmetasenv [] metas);
- prerr_endline "**********************";
- prerr_endline (CicMetaSubst.ppmetasenv [] menv);
- prerr_endline ("left: " ^ (CicPp.ppterm left));
- prerr_endline ("right: " ^ (CicPp.ppterm right));
- prerr_endline ("ty: " ^ (CicPp.ppterm eq_ty));
- assert false
- end
- else () in ()
-(*
- try
- ignore(CicTypeChecker.type_of_aux'
- metas context (Founif.build_proof_term proof) CicUniv.empty_ugraph)
- with e ->
- prerr_endline msg;
- prerr_endline (Founif.string_of_proof proof);
- prerr_endline (CicPp.ppterm (Founif.build_proof_term proof));
- prerr_endline ("+++++++++++++left: " ^ (CicPp.ppterm left));
- prerr_endline ("+++++++++++++right: " ^ (CicPp.ppterm right));
- raise e
-*)
-
-
-(* returns a list of all the equalities in the tree that are in relation
- "mode" with the given term, where mode can be either Matching or
- Unification.
-
- Format of the return value: list of tuples in the form:
- (position - Left or Right - of the term that matched the given one in this
- equality,
- equality found)
-
- Note that if equality is "left = right", if the ordering is left > right,
- the position will always be Left, and if the ordering is left < right,
- position will be Right.
-*)
-
-let get_candidates ?env mode tree term =
- let s =
- match mode with
- | Matching ->
- Index.retrieve_generalizations tree term
- | Unification ->
- Index.retrieve_unifiables tree term
-
- in
- Index.PosEqSet.elements s
-;;
-
-(*
- finds the first equality in the index that matches "term", of type "termty"
- termty can be Implicit if it is not needed. The result (one of the sides of
- the equality, actually) should be not greater (wrt the term ordering) than
- term
-
- Format of the return value:
-
- (term to substitute, [Cic.Rel 1 properly lifted - see the various
- build_newtarget functions inside the various
- demodulation_* functions]
- substitution used for the matching,
- metasenv,
- ugraph, [substitution, metasenv and ugraph have the same meaning as those
- returned by CicUnification.fo_unif]
- (equality where the matching term was found, [i.e. the equality to use as
- rewrite rule]
- uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of
- the equality: this is used to build the proof term, again see one of
- the build_newtarget functions]
- ))
-*)
-let rec find_matches bag metasenv context ugraph lift_amount term termty =
- let module C = Cic in
- let module U = Utils in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let cmp = !Utils.compare_terms in
- let check = match termty with C.Implicit None -> false | _ -> true in
- function
- | [] -> None
- | candidate::tl ->
- let pos, equality = candidate in
- (* if not_unit_eq context equality then
- begin
- prerr_endline "not a unit";
- prerr_endline (Equality.string_of_equality equality)
- end; *)
- let (_, proof, (ty, left, right, o), metas,_) =
- Equality.open_equality equality
- in
- if Utils.debug_metas then
- ignore(check_target bag context (snd candidate) "find_matches");
- if Utils.debug_res then
- begin
- let c="eq = "^(Equality.string_of_equality (snd candidate)) ^ "\n"in
- let t="t = " ^ (CicPp.ppterm term) ^ "\n" in
- let m="metas = " ^ (CicMetaSubst.ppmetasenv [] metas) ^ "\n" in
- let ms="metasenv =" ^ (CicMetaSubst.ppmetasenv [] metasenv) ^ "\n" in
- let eq_uri =
- match LibraryObjects.eq_URI () with
- | Some (uri) -> uri
- | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in
- let p="proof = "^
- (CicPp.ppterm(Equality.build_proof_term bag eq_uri [] 0 proof))^"\n"
- in
-
- check_for_duplicates metas "gia nella metas";
- check_for_duplicates metasenv "gia nel metasenv";
- check_for_duplicates (metasenv@metas) ("not disjoint"^c^t^m^ms^p)
- end;
- if check && not (fst (CicReduction.are_convertible
- ~metasenv context termty ty ugraph)) then (
- find_matches bag metasenv context ugraph lift_amount term termty tl
- ) else
- let do_match c =
- let subst', metasenv', ugraph' =
- Founif.matching
- metasenv metas context term (S.lift lift_amount c) ugraph
- in
- if Utils.debug_metas then
- check_metasenv "founif :" metasenv';
- Some (Cic.Rel(1+lift_amount),subst',metasenv',ugraph',candidate)
- in
- let c, other =
- if pos = Utils.Left then left, right
- else right, left
- in
- if o <> U.Incomparable then
- let res =
- try
- do_match c
- with Founif.MatchingFailure ->
- find_matches bag metasenv context ugraph lift_amount term termty tl
- in
- if Utils.debug_res then ignore (check_res res "find1");
- res
- else
- let res =
- try do_match c
- with Founif.MatchingFailure -> None
- in
- if Utils.debug_res then ignore (check_res res "find2");
- match res with
- | Some (_, s, _, _, _) ->
- let c' = apply_subst s c in
- (*
- let other' = U.guarded_simpl context (apply_subst s other) in *)
- let other' = apply_subst s other in
- let order = cmp c' other' in
- if order = U.Gt then
- res
- else
- find_matches bag
- metasenv context ugraph lift_amount term termty tl
- | None ->
- find_matches bag metasenv context ugraph lift_amount term termty tl
-;;
-
-let find_matches metasenv context ugraph lift_amount term termty =
- find_matches metasenv context ugraph lift_amount term termty
-;;
-
-(*
- as above, but finds all the matching equalities, and the matching condition
- can be either Founif.matching or Inference.unification
-*)
-(* XXX termty unused *)
-let rec find_all_matches ?(unif_fun=Founif.unification) ?(demod=false)
- metasenv context ugraph lift_amount term termty =
- let module C = Cic in
- let module U = Utils in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- (* prerr_endline ("matching " ^ CicPp.ppterm term); *)
- let cmp x y =
- let r = !Utils.compare_terms x y in
-(*
- prerr_endline (
- CicPp.ppterm x ^ " " ^
- Utils.string_of_comparison r ^ " " ^
- CicPp.ppterm y );
-*)
- r
- in
- let check = match termty with C.Implicit None -> false | _ -> true in
- function
- | [] -> []
- | candidate::tl ->
- let pos, equality = candidate in
- let (_,_,(ty,left,right,o),metas,_)= Equality.open_equality equality in
- if check && not (fst (CicReduction.are_convertible
- ~metasenv context termty ty ugraph)) then (
- find_all_matches metasenv context ugraph lift_amount term termty tl
- ) else
- let do_match c =
- let subst', metasenv', ugraph' =
- unif_fun metasenv metas context term (S.lift lift_amount c) ugraph
- in
- (C.Rel (1+lift_amount),subst',metasenv',ugraph',candidate)
- in
-
- let c, other =
- if pos = Utils.Left then left, right
- else right, left
- in
- if o <> U.Incomparable then
- try
- let res = do_match c in
- res::(find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl)
- with
- | Founif.MatchingFailure
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl
- else
- try
- let res = do_match c in
- match res with
- | _, s, _, _, _ ->
- let c' = apply_subst s c
- and other' = apply_subst s other in
- let order = cmp c' other' in
- if (demod && order = U.Gt) ||
- (not demod && (order <> U.Lt && order <> U.Le))
- then
- res::(find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl)
- else
- find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl
- with
- | Founif.MatchingFailure
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl
-;;
-
-let find_all_matches
- ?unif_fun ?demod metasenv context ugraph lift_amount term termty l
-=
- find_all_matches
- ?unif_fun ?demod metasenv context ugraph lift_amount term termty l
- (*prerr_endline "CANDIDATES:";
- List.iter (fun (_,x)->prerr_endline (Founif.string_of_equality x)) l;
- prerr_endline ("MATCHING:" ^ CicPp.ppterm term ^ " are " ^ string_of_int
- (List.length rc));*)
-;;
-(*
- returns true if target is subsumed by some equality in table
-*)
-(*
-let print_res l =
- prerr_endline (String.concat "\n" (List.map (fun (_, subst, menv, ug,
- ((pos,equation),_)) -> Equality.string_of_equality equation)l))
-;;
-*)
-
-let subsumption_aux use_unification env table target =
- let _, _, (ty, left, right, _), tmetas, _ = Equality.open_equality target in
- let _, context, ugraph = env in
- let metasenv = tmetas in
- let predicate, unif_fun =
- if use_unification then
- Unification, Founif.unification
- else
- Matching, Founif.matching
- in
- let leftr =
- match left with
- | Cic.Meta _ when not use_unification -> []
- | _ ->
- let leftc = get_candidates predicate table left in
- find_all_matches ~unif_fun
- metasenv context ugraph 0 left ty leftc
- in
- let rec ok what leftorright = function
- | [] -> None
- | (_, subst, menv, ug, (pos,equation))::tl ->
- let _, _, (_, l, r, o), m,_ = Equality.open_equality equation in
- try
- let other = if pos = Utils.Left then r else l in
- let what' = Subst.apply_subst subst what in
- let other' = Subst.apply_subst subst other in
- let subst', menv', ug' =
- unif_fun metasenv m context what' other' ugraph
- in
- (match Subst.merge_subst_if_possible subst subst' with
- | None -> ok what leftorright tl
- | Some s -> Some (s, equation, leftorright <> pos ))
- with
- | Founif.MatchingFailure
- | CicUnification.UnificationFailure _ -> ok what leftorright tl
- in
- match ok right Utils.Left leftr with
- | Some _ as res -> res
- | None ->
- let rightr =
- match right with
- | Cic.Meta _ when not use_unification -> []
- | _ ->
- let rightc = get_candidates predicate table right in
- find_all_matches ~unif_fun
- metasenv context ugraph 0 right ty rightc
- in
- ok left Utils.Right rightr
-;;
-
-let subsumption x y z =
- subsumption_aux false x y z
-;;
-
-let unification x y z =
- subsumption_aux true x y z
-;;
-
-(* the target must be disjoint from the equations in the table *)
-let subsumption_aux_all use_unification env table target =
- let _, _, (ty, left, right, _), tmetas, _ = Equality.open_equality target in
- let _, context, ugraph = env in
- let metasenv = tmetas in
- if Utils.debug_metas then
- check_for_duplicates metasenv "subsumption_aux_all";
- let predicate, unif_fun =
- if use_unification then
- Unification, Founif.unification
- else
- Matching, Founif.matching
- in
- let leftr =
- match left with
- | Cic.Meta _ (*when not use_unification*) -> []
- | _ ->
- let leftc = get_candidates predicate table left in
- find_all_matches ~unif_fun
- metasenv context ugraph 0 left ty leftc
- in
- let rightr =
- match right with
- | Cic.Meta _ (*when not use_unification*) -> []
- | _ ->
- let rightc = get_candidates predicate table right in
- find_all_matches ~unif_fun
- metasenv context ugraph 0 right ty rightc
- in
- let rec ok_all what leftorright = function
- | [] -> []
- | (_, subst, menv, ug, (pos,equation))::tl ->
- let _, _, (_, l, r, o), m,_ = Equality.open_equality equation in
- try
- let other = if pos = Utils.Left then r else l in
- let what' = Subst.apply_subst subst what in
- let other' = Subst.apply_subst subst other in
- let subst', menv', ug' =
- unif_fun [] menv context what' other' ugraph
- in
- (match Subst.merge_subst_if_possible subst subst' with
- | None -> ok_all what leftorright tl
- | Some s ->
- (s, equation, leftorright <> pos )::(ok_all what leftorright tl))
- with
- | Founif.MatchingFailure
- | CicUnification.UnificationFailure _ -> (ok_all what leftorright tl)
- in
- (ok_all right Utils.Left leftr)@(ok_all left Utils.Right rightr )
-;;
-
-let subsumption_all x y z =
- subsumption_aux_all false x y z
-;;
-
-let unification_all x y z =
- subsumption_aux_all true x y z
-;;
-
-let rec demodulation_aux bag ?from ?(typecheck=false)
- metasenv context ugraph table lift_amount term =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- if Utils.debug_metas then
- check_for_duplicates metasenv "in input a demodulation aux";
- let candidates =
- get_candidates
- ~env:(metasenv,context,ugraph) (* Unification *) Matching table term
- in
-(* let candidates = List.filter (fun _,x -> not (not_unit_eq context x)) candidates in *)
- let res =
- match term with
- | C.Meta _ -> None
- | term ->
- let res =
- try
- let termty, ugraph =
- if typecheck then
- CicTypeChecker.type_of_aux' metasenv context term ugraph
- else
- C.Implicit None, ugraph
- in
- find_matches bag metasenv context ugraph
- lift_amount term termty candidates
- with _ ->
- prerr_endline "type checking error";
- prerr_endline ("menv :\n" ^ CicMetaSubst.ppmetasenv [] metasenv);
- prerr_endline ("term: " ^ (CicPp.ppterm term));
- assert false;
- (* None *)
- in
- let res =
- (if Utils.debug_res then
- ignore(check_res res "demod1");
- if check_demod_res res metasenv "demod" then res else None) in
- if res <> None then
- res
- else
- match term with
- | C.Appl l ->
- let res, ll =
- List.fold_left
- (fun (res, tl) t ->
- if res <> None then
- (res, tl @ [S.lift 1 t])
- else
- let r =
- demodulation_aux bag ~from:"1" metasenv context ugraph table ~typecheck
- lift_amount t
- in
- match r with
- | None -> (None, tl @ [S.lift 1 t])
- | Some (rel, _, _, _, _) -> (r, tl @ [rel]))
- (None, []) l
- in (
- match res with
- | None -> None
- | Some (_, subst, menv, ug, eq_found) ->
- Some (C.Appl ll, subst, menv, ug, eq_found)
- )
-(*
- | C.Prod (nn, s, t) ->
- let r1 =
- demodulation_aux bag ~from:"2"
- metasenv context ugraph table lift_amount s in (
- match r1 with
- | None ->
- let r2 =
- demodulation_aux bag metasenv
- ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t
- in (
- match r2 with
- | None -> None
- | Some (t', subst, menv, ug, eq_found) ->
- Some (C.Prod (nn, (S.lift 1 s), t'),
- subst, menv, ug, eq_found)
- )
- | Some (s', subst, menv, ug, eq_found) ->
- Some (C.Prod (nn, s', (S.lift 1 t)),
- subst, menv, ug, eq_found)
- )
- | C.Lambda (nn, s, t) ->
- prerr_endline "siam qui";
- let r1 =
- demodulation_aux bag
- metasenv context ugraph table lift_amount s in (
- match r1 with
- | None ->
- let r2 =
- demodulation_aux bag metasenv
- ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t
- in (
- match r2 with
- | None -> None
- | Some (t', subst, menv, ug, eq_found) ->
- Some (C.Lambda (nn, (S.lift 1 s), t'),
- subst, menv, ug, eq_found)
- )
- | Some (s', subst, menv, ug, eq_found) ->
- Some (C.Lambda (nn, s', (S.lift 1 t)),
- subst, menv, ug, eq_found)
- )
-*)
- | t ->
- None
- in
- if Utils.debug_res then ignore(check_res res "demod_aux output");
- res
-;;
-
-exception Foo
-
-(** demodulation, when target is an equality *)
-let rec demodulation_equality bag ?from eq_uri env table target =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let module U = Utils in
- let metasenv, context, ugraph = env in
- let w, proof, (eq_ty, left, right, order), metas, id =
- Equality.open_equality target
- in
- (* first, we simplify *)
-(* let right = U.guarded_simpl context right in *)
-(* let left = U.guarded_simpl context left in *)
-(* let order = !Utils.compare_terms left right in *)
-(* let stat = (eq_ty, left, right, order) in *)
-(* let w = Utils.compute_equality_weight stat in*)
- (* let target = Equality.mk_equality (w, proof, stat, metas) in *)
- if Utils.debug_metas then
- ignore(check_target bag context target "demod equalities input");
- let metasenv' = (* metasenv @ *) metas in
-
- let build_newtarget bag is_left (t, subst, menv, ug, eq_found) =
-
- if Utils.debug_metas then
- begin
- ignore(check_for_duplicates menv "input1");
- ignore(check_disjoint_invariant subst menv "input2");
- let substs = Subst.ppsubst subst in
- ignore(check_target bag context (snd eq_found) ("input3" ^ substs))
- end;
- let pos, equality = eq_found in
- let (_, proof',
- (ty, what, other, _), menv',id') = Equality.open_equality equality in
- (*
- let ty =
- try fst (CicTypeChecker.type_of_aux' menv' context what ugraph)
- with CicUtil.Meta_not_found _ -> ty
- in *)
- let ty, eq_ty = apply_subst subst ty, apply_subst subst eq_ty in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newterm, newproof =
- let bo =
- Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
-(* let name = C.Name ("x_Demod" ^ (string_of_int !demod_counter)) in*)
- let name = C.Name "x" in
- let bo' =
- let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in
- C.Appl [C.MutInd (eq_uri, 0, []); S.lift 1 eq_ty; l; r]
- in
- (bo, (Equality.Step (subst,(Equality.Demodulation, id,(pos,id'),
- (Cic.Lambda (name, ty, bo'))))))
- in
- let newmenv = menv in
- let left, right = if is_left then newterm, right else left, newterm in
- let ordering = !Utils.compare_terms left right in
- let stat = (eq_ty, left, right, ordering) in
- let bag, res =
- let w = Utils.compute_equality_weight stat in
- Equality.mk_equality bag (w, newproof, stat,newmenv)
- in
- if Utils.debug_metas then
- ignore(check_target bag context res "buildnew_target output");
- bag, res
- in
- let res =
- demodulation_aux bag ~from:"from3" metasenv' context ugraph table 0 left
- in
- if Utils.debug_res then check_res res "demod result";
- let bag, newtarget =
- match res with
- | Some t ->
- let bag, newtarget = build_newtarget bag true t in
- (* assert (not (Equality.meta_convertibility_eq target newtarget)); *)
- if (Equality.is_weak_identity newtarget) (* || *)
- (*Equality.meta_convertibility_eq target newtarget*) then
- bag, newtarget
- else
- demodulation_equality bag ?from eq_uri env table newtarget
- | None ->
- let res = demodulation_aux bag metasenv' context ugraph table 0 right in
- if Utils.debug_res then check_res res "demod result 1";
- match res with
- | Some t ->
- let bag, newtarget = build_newtarget bag false t in
- if (Equality.is_weak_identity newtarget) ||
- (Equality.meta_convertibility_eq target newtarget) then
- bag, newtarget
- else
- demodulation_equality bag ?from eq_uri env table newtarget
- | None ->
- bag, target
- in
- (* newmeta, newtarget *)
- bag, newtarget
-;;
-
-(**
- Performs the beta expansion of the term "term" w.r.t. "table",
- i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2
- in table.
-*)
-let rec betaexpand_term
- ?(subterms_only=false) metasenv context ugraph table lift_amount term
-=
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
-
- let res, lifted_term =
- match term with
- | C.Meta (i, l) ->
- let l = [] in
- let l', lifted_l =
- List.fold_right
- (fun arg (res, lifted_tl) ->
- match arg with
- | Some arg ->
- let arg_res, lifted_arg =
- betaexpand_term metasenv context ugraph table
- lift_amount arg in
- let l1 =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- (Some t)::lifted_tl, s, m, ug, eq_found)
- arg_res
- in
- (l1 @
- (List.map
- (fun (l, s, m, ug, eq_found) ->
- (Some lifted_arg)::l, s, m, ug, eq_found)
- res),
- (Some lifted_arg)::lifted_tl)
- | None ->
- (List.map
- (fun (r, s, m, ug, eq_found) ->
- None::r, s, m, ug, eq_found) res,
- None::lifted_tl)
- ) l ([], [])
- in
- let e =
- List.map
- (fun (l, s, m, ug, eq_found) ->
- (C.Meta (i, l), s, m, ug, eq_found)) l'
- in
- e, C.Meta (i, lifted_l)
-
- | C.Rel m ->
- [], if m <= lift_amount then C.Rel m else C.Rel (m+1)
-
- | C.Prod (nn, s, t) ->
- let l1, lifted_s =
- betaexpand_term metasenv context ugraph table lift_amount s in
- let l2, lifted_t =
- betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t in
- let l1' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1
- and l2' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in
- l1' @ l2', C.Prod (nn, lifted_s, lifted_t)
-
- | C.Lambda (nn, s, t) ->
- let l1, lifted_s =
- betaexpand_term metasenv context ugraph table lift_amount s in
- let l2, lifted_t =
- betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t in
- let l1' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1
- and l2' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in
- l1' @ l2', C.Lambda (nn, lifted_s, lifted_t)
-
- | C.Appl l ->
- let l', lifted_l =
- List.fold_left
- (fun (res, lifted_tl) arg ->
- let arg_res, lifted_arg =
- betaexpand_term metasenv context ugraph table lift_amount arg
- in
- let l1 =
- List.map
- (fun (a, s, m, ug, eq_found) ->
- a::lifted_tl, s, m, ug, eq_found)
- arg_res
- in
- (l1 @
- (List.map
- (fun (r, s, m, ug, eq_found) ->
- lifted_arg::r, s, m, ug, eq_found)
- res),
- lifted_arg::lifted_tl)
- ) ([], []) (List.rev l)
- in
- (List.map
- (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l',
- C.Appl lifted_l)
-
- | t -> [], (S.lift lift_amount t)
- in
- match term with
- | C.Meta (i, l) -> res, lifted_term
- | term ->
- let termty, ugraph =
- C.Implicit None, ugraph
-(* CicTypeChecker.type_of_aux' metasenv context term ugraph *)
- in
- let candidates = get_candidates Unification table term in
- (* List.iter (fun (_,e) -> debug_print (lazy (Equality.string_of_equality e))) candidates; *)
- let r =
- if subterms_only then
- []
- else
- find_all_matches
- metasenv context ugraph lift_amount term termty candidates
- in
- r @ res, lifted_term
-;;
-
-(**
- superposition_right
- returns a list of new clauses inferred with a right superposition step
- between the positive equation "target" and one in the "table" "newmeta" is
- the first free meta index, i.e. the first number above the highest meta
- index: its updated value is also returned
-*)
-let superposition_right bag
- ?(subterms_only=false) eq_uri (metasenv, context, ugraph) table target=
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let module CR = CicReduction in
- let module U = Utils in
- let w, eqproof, (eq_ty, left, right, ordering), newmetas,id =
- Equality.open_equality target
- in
- if Utils.debug_metas then
- ignore (check_target bag context target "superpositionright");
- let metasenv' = newmetas in
- let res1, res2 =
- match ordering with
- | U.Gt ->
- fst (betaexpand_term ~subterms_only metasenv' context ugraph table 0 left), []
- | U.Lt ->
- [], fst (betaexpand_term ~subterms_only metasenv' context ugraph table 0 right)
- | _ ->
- let res l r =
- List.filter
- (fun (_, subst, _, _, _) ->
- let subst = apply_subst subst in
- let o = !Utils.compare_terms (subst l) (subst r) in
- o <> U.Lt && o <> U.Le)
- (fst (betaexpand_term ~subterms_only metasenv' context ugraph table 0 l))
- in
- (res left right), (res right left)
- in
- let build_new bag ordering (bo, s, m, ug, eq_found) =
- if Utils.debug_metas then
- ignore (check_target bag context (snd eq_found) "buildnew1" );
-
- let pos, equality = eq_found in
- let (_, proof', (ty, what, other, _), menv',id') =
- Equality.open_equality equality in
- let what, other = if pos = Utils.Left then what, other else other, what in
-
- let ty, eq_ty = apply_subst s ty, apply_subst s eq_ty in
- let newgoal, newproof =
- (* qua *)
- let bo' =
- Utils.guarded_simpl context (apply_subst s (S.subst other bo))
- in
- let name = C.Name "x" in
- let bo'' =
- let l, r =
- if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in
- C.Appl [C.MutInd (eq_uri, 0, []); S.lift 1 eq_ty; l; r]
- in
- bo',
- Equality.Step
- (s,(Equality.SuperpositionRight,
- id,(pos,id'),(Cic.Lambda(name,ty,bo''))))
- in
- let bag, newequality =
- let left, right =
- if ordering = U.Gt then newgoal, apply_subst s right
- else apply_subst s left, newgoal in
- let neworder = !Utils.compare_terms left right in
- let newmenv = (* Founif.filter s *) m in
- let stat = (eq_ty, left, right, neworder) in
- let bag, eq' =
- let w = Utils.compute_equality_weight stat in
- Equality.mk_equality bag (w, newproof, stat, newmenv) in
- if Utils.debug_metas then
- ignore (check_target bag context eq' "buildnew3");
- let bag, eq' = Equality.fix_metas bag eq' in
- if Utils.debug_metas then
- ignore (check_target bag context eq' "buildnew4");
- bag, eq'
- in
- if Utils.debug_metas then
- ignore(check_target bag context newequality "buildnew2");
- bag, newequality
- in
- let bag, new1 =
- List.fold_right
- (fun x (bag,acc) ->
- let bag, e = build_new bag U.Gt x in
- bag, e::acc) res1 (bag,[])
- in
- let bag, new2 =
- List.fold_right
- (fun x (bag,acc) ->
- let bag, e = build_new bag U.Lt x in
- bag, e::acc) res2 (bag,[])
- in
- let ok e = not (Equality.is_identity (metasenv', context, ugraph) e) in
- bag, List.filter ok (new1 @ new2)
-;;
-
-(** demodulation, when the target is a theorem *)
-let rec demodulation_theorem bag env table theorem =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let eq_uri =
- match LibraryObjects.eq_URI() with
- | Some u -> u
- | None -> assert false in
- let metasenv, context, ugraph = env in
- let proof, theo, metas = theorem in
- let build_newtheorem (t, subst, menv, ug, eq_found) =
- let pos, equality = eq_found in
- let (_, proof', (ty, what, other, _), menv',id) =
- Equality.open_equality equality in
- let peq =
- match proof' with
- | Equality.Exact p -> p
- | _ -> assert false in
- let what, other =
- if pos = Utils.Left then what, other else other, what in
- let newtheo = apply_subst subst (S.subst other t) in
- let name = C.Name "x" in
- let body = apply_subst subst t in
- let pred = C.Lambda(name,ty,body) in
- let newproof =
- match pos with
- | Utils.Left ->
- Equality.mk_eq_ind eq_uri ty what pred proof other peq
- | Utils.Right ->
- Equality.mk_eq_ind eq_uri ty what pred proof other peq
- in
- newproof,newtheo
- in
- let res = demodulation_aux bag metas context ugraph table 0 theo in
- match res with
- | Some t ->
- let newproof, newtheo = build_newtheorem t in
- if Equality.meta_convertibility theo newtheo then
- newproof, newtheo
- else
- demodulation_theorem bag env table (newproof,newtheo,[])
- | None ->
- proof,theo
-;;
-
-(*****************************************************************************)
-(** OPERATIONS ON GOALS **)
-(** **)
-(** DEMODULATION_GOAL & SUPERPOSITION_LEFT **)
-(*****************************************************************************)
-
-(* new: demodulation of non_equality terms *)
-let build_newg bag context goal rule expansion =
- let goalproof,_,_ = goal in
- let (t,subst,menv,ug,eq_found) = expansion in
- let pos, equality = eq_found in
- let (_, proof', (ty, what, other, _), menv',id) =
- Equality.open_equality equality in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newterm, newgoalproof =
- let bo =
- Utils.guarded_simpl context
- (apply_subst subst (CicSubstitution.subst other t))
- in
- let name = Cic.Name "x" in
- let pred = apply_subst subst (Cic.Lambda (name,ty,t)) in
- let newgoalproofstep = (rule,pos,id,subst,pred) in
- bo, (newgoalproofstep::goalproof)
- in
- let newmetasenv = (* Founif.filter subst *) menv in
- (newgoalproof, newmetasenv, newterm)
-;;
-
-let rec demod bag env table goal =
- let _,menv,t = goal in
- let _, context, ugraph = env in
- let res = demodulation_aux bag menv context ugraph table 0 t (~typecheck:false)in
- match res with
- | Some newt ->
- let newg =
- build_newg bag context goal Equality.Demodulation newt
- in
- let _,_,newt = newg in
- if Equality.meta_convertibility t newt then
- false, goal
- else
- true, snd (demod bag env table newg)
- | None ->
- false, goal
-;;
-
-let open_goal g =
- match g with
- | (proof,menv,Cic.Appl[(Cic.MutInd(uri,0,_)) as eq;ty;l;r]) ->
- (* assert (LibraryObjects.is_eq_URI uri); *)
- proof,menv,eq,ty,l,r
- | _ -> assert false
-
-let ty_of_goal (_,_,ty) = ty ;;
-
-(* checks if two goals are metaconvertible *)
-let goal_metaconvertibility_eq g1 g2 =
- Equality.meta_convertibility (ty_of_goal g1) (ty_of_goal g2)
-;;
-
-(* when the betaexpand_term function is called on the left/right side of the
- * goal, the predicate has to be fixed
- * C[x] ---> (eq ty unchanged C[x])
- * [posu] is the side of the [unchanged] term in the original goal
- *)
-
-let fix_expansion goal posu (t, subst, menv, ug, eq_f) =
- let _,_,eq,ty,l,r = open_goal goal in
- let unchanged = if posu = Utils.Left then l else r in
- let unchanged = CicSubstitution.lift 1 unchanged in
- let ty = CicSubstitution.lift 1 ty in
- let pred =
- match posu with
- | Utils.Left -> Cic.Appl [eq;ty;unchanged;t]
- | Utils.Right -> Cic.Appl [eq;ty;t;unchanged]
- in
- (pred, subst, menv, ug, eq_f)
-;;
-
-(* ginve the old [goal], the side that has not changed [posu] and the
- * expansion builds a new goal *)
-let build_newgoal bag context goal posu rule expansion =
- let goalproof,_,_,_,_,_ = open_goal goal in
- let (t,subst,menv,ug,eq_found) = fix_expansion goal posu expansion in
- let pos, equality = eq_found in
- let (_, proof', (ty, what, other, _), menv',id) =
- Equality.open_equality equality in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newterm, newgoalproof =
- let bo =
- Utils.guarded_simpl context
- (apply_subst subst (CicSubstitution.subst other t))
- in
- let name = Cic.Name "x" in
- let pred = apply_subst subst (Cic.Lambda (name,ty,t)) in
- let newgoalproofstep = (rule,pos,id,subst,pred) in
- bo, (newgoalproofstep::goalproof)
- in
- let newmetasenv = (* Founif.filter subst *) menv in
- (newgoalproof, newmetasenv, newterm)
-;;
-
-(**
- superposition_left
- returns a list of new clauses inferred with a left superposition step
- the negative equation "target" and one of the positive equations in "table"
-*)
-let superposition_left bag (metasenv, context, ugraph) table goal =
- let names = Utils.names_of_context context in
- let proof,menv,eq,ty,l,r = open_goal goal in
- let c = !Utils.compare_terms l r in
- let newgoals =
- if c = Utils.Incomparable then
- begin
- let expansionsl, _ = betaexpand_term menv context ugraph table 0 l in
- let expansionsr, _ = betaexpand_term menv context ugraph table 0 r in
- (* prerr_endline "incomparable";
- prerr_endline (string_of_int (List.length expansionsl));
- prerr_endline (string_of_int (List.length expansionsr));
- *)
- List.map (build_newgoal bag context goal Utils.Right Equality.SuperpositionLeft) expansionsl
- @
- List.map (build_newgoal bag context goal Utils.Left Equality.SuperpositionLeft) expansionsr
- end
- else
- match c with
- | Utils.Gt ->
- let big,small,possmall = l,r,Utils.Right in
- let expansions, _ = betaexpand_term menv context ugraph table 0 big in
- List.map
- (build_newgoal bag context goal possmall Equality.SuperpositionLeft)
- expansions
- | Utils.Lt -> (* prerr_endline "LT"; *)
- let big,small,possmall = r,l,Utils.Left in
- let expansions, _ = betaexpand_term menv context ugraph table 0 big in
- List.map
- (build_newgoal bag context goal possmall Equality.SuperpositionLeft)
- expansions
- | Utils.Eq -> []
- | _ ->
- prerr_endline
- ("NOT GT, LT NOR EQ : "^CicPp.pp l names^" - "^CicPp.pp r names);
- assert false
- in
- (* rinfresco le meta *)
- List.fold_right
- (fun g (b,acc) ->
- let b,g = Equality.fix_metas_goal b g in
- b,g::acc)
- newgoals (bag,[])
-;;
-
-(** demodulation, when the target is a goal *)
-let rec demodulation_goal bag env table goal =
- let goalproof,menv,_,_,left,right = open_goal goal in
- let _, context, ugraph = env in
-(* let term = Utils.guarded_simpl (~debug:true) context term in*)
- let do_right () =
- let resright = demodulation_aux bag menv context ugraph table 0 right in
- match resright with
- | Some t ->
- let newg =
- build_newgoal bag context goal Utils.Left Equality.Demodulation t
- in
- if goal_metaconvertibility_eq goal newg then
- false, goal
- else
- true, snd (demodulation_goal bag env table newg)
- | None -> false, goal
- in
- let resleft = demodulation_aux bag menv context ugraph table 0 left in
- match resleft with
- | Some t ->
- let newg = build_newgoal bag context goal Utils.Right Equality.Demodulation t in
- if goal_metaconvertibility_eq goal newg then
- do_right ()
- else
- true, snd (demodulation_goal bag env table newg)
- | None -> do_right ()
-;;
-
-(* returns all the 1 step demodulations *)
-module C = Cic;;
-module S = CicSubstitution;;
-
-let rec demodulation_all_aux
- metasenv context ugraph table lift_amount term
-=
- let candidates =
- get_candidates ~env:(metasenv,context,ugraph) Matching table term
- in
- match term with
- | C.Meta _ -> []
- | _ ->
- let termty, ugraph = C.Implicit None, ugraph in
- let res =
- find_all_matches
- ~unif_fun:Founif.matching ~demod:true
- metasenv context ugraph lift_amount term termty candidates
- in
- match term with
- | C.Appl l ->
- let res, _, _, _ =
- List.fold_left
- (fun (res,b,l,r) t ->
- if not b then res,b,l,r
- else
- let demods_for_t =
- demodulation_all_aux
- metasenv context ugraph table lift_amount t
- in
- let b = demods_for_t = [] in
- res @
- List.map
- (fun (rel, s, m, ug, c) ->
- (Cic.Appl (l@[rel]@List.tl r), s, m, ug, c))
- demods_for_t, b, l@[List.hd r], List.tl r)
- (res, true, [], List.map (S.lift 1) l) l
- in
- res
- | t -> res
-;;
-
-let demod_all steps bag env table goal =
- let _, context, ugraph = env in
- let is_visited l (_,_,t) =
- List.exists (fun (_,_,s) -> Equality.meta_convertibility s t) l
- in
- let rec aux steps visited nf bag = function
- | _ when steps = 0 -> visited, bag, nf
- | [] -> visited, bag, nf
- | goal :: rest when is_visited visited goal-> aux steps visited nf bag rest
- | goal :: rest ->
- let visited = goal :: visited in
- let _,menv,t = goal in
- let res = demodulation_all_aux menv context ugraph table 0 t in
- let steps = if res = [] then steps-1 else steps in
- let new_goals =
- List.map (build_newg bag context goal Equality.Demodulation) res
- in
- let nf = if new_goals = [] then goal :: nf else nf in
- aux steps visited nf bag (new_goals @ rest)
- in
- aux steps [] [] bag [goal]
-;;
-
-let combine_demodulation_proofs bag env goal (pl,ml,l) (pr,mr,r) =
- let proof,m,eq,ty,left,right = open_goal goal in
- let pl =
- List.map
- (fun (rule,pos,id,subst,pred) ->
- let pred =
- match pred with
- | Cic.Lambda (name,src,tgt) ->
- Cic.Lambda (name,src,
- Cic.Appl[eq;ty;tgt;CicSubstitution.lift 1 right])
- | _ -> assert false
- in
- rule,pos,id,subst,pred)
- pl
- in
- let pr =
- List.map
- (fun (rule,pos,id,subst,pred) ->
- let pred =
- match pred with
- | Cic.Lambda (name,src,tgt) ->
- Cic.Lambda (name,src,
- Cic.Appl[eq;ty;CicSubstitution.lift 1 l;tgt])
- | _ -> assert false
- in
- rule,pos,id,subst,pred)
- pr
- in
- (pr@pl@proof, m, Cic.Appl [eq;ty;l;r])
-;;
-
-let demodulation_all_goal bag env table goal maxnf =
- let proof,menv,eq,ty,left,right = open_goal goal in
- let v1, bag, l_demod = demod_all maxnf bag env table ([],menv,left) in
- let v2, bag, r_demod = demod_all maxnf bag env table ([],menv,right) in
- let l_demod = if l_demod = [] then [ [], menv, left ] else l_demod in
- let r_demod = if r_demod = [] then [ [], menv, right ] else r_demod in
- List.fold_left
- (fun acc (_,_,l as ld) ->
- List.fold_left
- (fun acc (_,_,r as rd) ->
- combine_demodulation_proofs bag env goal ld rd :: acc)
- acc r_demod)
- [] l_demod
-;;
-
-let solve_demodulating bag env table initgoal steps =
- let proof,menv,eq,ty,left,right = open_goal initgoal in
- let uri =
- match eq with
- | Cic.MutInd (u,_,_) -> u
- | _ -> assert false
- in
- let _, context, ugraph = env in
- let v1, bag, l_demod = demod_all steps bag env table ([],menv,left) in
- let v2, bag, r_demod = demod_all steps bag env table ([],menv,right) in
- let is_solved left right ml mr =
- let m = ml @ (List.filter
- (fun (x,_,_) -> not (List.exists (fun (y,_,_) -> x=y)ml)) mr)
- in
- try
- let s,_,_ =
- Founif.unification [] m context left right CicUniv.empty_ugraph in
- Some (bag, m,s,Equality.Exact (Equality.refl_proof uri ty left))
- with CicUnification.UnificationFailure _ ->
- let solutions =
- unification_all env table (Equality.mk_tmp_equality
- (0,(Cic.Implicit None,left,right,Utils.Incomparable),m))
- in
- if solutions = [] then None
- else
- let s, e, swapped = List.hd solutions in
- let _,p,(ty,l,r,_),me,id = Equality.open_equality e in
- let bag, p =
- if swapped then Equality.symmetric bag ty l id uri me else bag, p
- in
- Some (bag, m,s, p)
- in
- let newgoal =
- HExtlib.list_findopt
- (fun (pr,mr,r) _ ->
- try
- let pl,ml,l,bag,m,s,p =
- match
- HExtlib.list_findopt (fun (pl,ml,l) _ ->
- match is_solved l r ml mr with
- | None -> None
- | Some (bag,m,s,p) -> Some (pl,ml,l,bag,m,s,p)
- ) l_demod
- with Some x -> x | _ -> raise Not_found
- in
- let pl =
- List.map
- (fun (rule,pos,id,subst,pred) ->
- let pred =
- match pred with
- | Cic.Lambda (name,src,tgt) ->
- Cic.Lambda (name,src,
- Cic.Appl[eq;ty;tgt;CicSubstitution.lift 1 right])
- | _ -> assert false
- in
- rule,pos,id,subst,pred)
- pl
- in
- let pr =
- List.map
- (fun (rule,pos,id,subst,pred) ->
- let pred =
- match pred with
- | Cic.Lambda (name,src,tgt) ->
- Cic.Lambda (name,src,
- Cic.Appl[eq;ty;CicSubstitution.lift 1 l;tgt])
- | _ -> assert false
- in
- rule,pos,id,subst,pred)
- pr
- in
- Some (bag,pr@pl@proof,m,s,p)
- with Not_found -> None)
- r_demod
- in
- newgoal
-;;
-
-
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module Index :
- sig
- module PosEqSet : Set.S
- with type elt = Utils.pos * Equality.equality
- and type t = Equality_indexing.DT.PosEqSet.t
- type t =
- Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet).t
- end
-
-val check_for_duplicates : Cic.metasenv -> string -> unit
-val index : Index.t -> Equality.equality -> Index.t
-val remove_index : Index.t -> Equality.equality -> Index.t
-val in_index : Index.t -> Equality.equality -> bool
-val empty : Index.t
-val init_index : unit -> unit
-val unification :
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.equality ->
- (Subst.substitution * Equality.equality * bool) option
-val subsumption :
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.equality ->
- (Subst.substitution * Equality.equality * bool) option
-val unification_all :
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.equality ->
- (Subst.substitution * Equality.equality * bool) list
-val subsumption_all :
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.equality ->
- (Subst.substitution * Equality.equality * bool) list
-val superposition_left :
- Equality.equality_bag ->
- Cic.conjecture list * Cic.context * CicUniv.universe_graph ->
- Index.t -> Equality.goal ->
- Equality.equality_bag * Equality.goal list
-
-val superposition_right :
- Equality.equality_bag ->
- ?subterms_only:bool ->
- UriManager.uri ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.equality ->
- Equality.equality_bag * Equality.equality list
-
-val demod :
- Equality.equality_bag ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.goal ->
- bool * Equality.goal
-val demodulation_equality :
- Equality.equality_bag ->
- ?from:string ->
- UriManager.uri ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.equality -> Equality.equality_bag * Equality.equality
-val demodulation_goal :
- Equality.equality_bag ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.goal ->
- bool * Equality.goal
-val demodulation_all_goal :
- Equality.equality_bag ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.goal -> int ->
- Equality.goal list
-val demodulation_theorem :
- Equality.equality_bag ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Cic.term * Cic.term * Cic.metasenv
- -> Cic.term * Cic.term
-
-val check_target:
- Equality.equality_bag ->
- Cic.context ->
- Equality.equality -> string -> unit
-val solve_demodulating:
- Equality.equality_bag ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Equality.goal ->
- int ->
- (Equality.equality_bag * Equality.goal_proof * Cic.metasenv *
- Subst.substitution * Equality.proof) option
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* let _profiler = <:profiler<_profiler>>;; *)
-
-(* $Id$ *)
-
-(* set to false to disable paramodulation inside auto_tac *)
-
-let fst3 a,_,_ = a;;
-let last _,_,a = a;;
-
-let connect_to_auto = true;;
-
-let debug_print = Utils.debug_print;;
-
-(* profiling statistics... *)
-let infer_time = ref 0.;;
-let forward_simpl_time = ref 0.;;
-let forward_simpl_new_time = ref 0.;;
-let backward_simpl_time = ref 0.;;
-let passive_maintainance_time = ref 0.;;
-
-(* limited-resource-strategy related globals *)
-let processed_clauses = ref 0;; (* number of equalities selected so far... *)
-let time_limit = ref 0.;; (* in seconds, settable by the user... *)
-let start_time = ref 0.;; (* time at which the execution started *)
-let elapsed_time = ref 0.;;
-(* let maximal_weight = ref None;; *)
-let maximal_retained_equality = ref None;;
-
-(* equality-selection related globals *)
-let use_fullred = ref true;;
-let weight_age_ratio = ref 6 (* 5 *);; (* settable by the user *)
-let weight_age_counter = ref !weight_age_ratio ;;
-let symbols_ratio = ref 0 (* 3 *);;
-let symbols_counter = ref 0;;
-
-(* non-recursive Knuth-Bendix term ordering by default *)
-(* Utils.compare_terms := Utils.rpo;; *)
-(* Utils.compare_terms := Utils.nonrec_kbo;; *)
-(* Utils.compare_terms := Utils.ao;; *)
-
-(* statistics... *)
-let derived_clauses = ref 0;;
-let kept_clauses = ref 0;;
-
-(* varbiables controlling the search-space *)
-let maxdepth = ref 3;;
-let maxwidth = ref 3;;
-
-type theorem = Cic.term * Cic.term * Cic.metasenv;;
-
-let symbols_of_equality equality =
- let (_, _, (_, left, right, _), _,_) = Equality.open_equality equality in
- let m1 = Utils.symbols_of_term left in
- let m =
- Utils.TermMap.fold
- (fun k v res ->
- try
- let c = Utils.TermMap.find k res in
- Utils.TermMap.add k (c+v) res
- with Not_found ->
- Utils.TermMap.add k v res)
- (Utils.symbols_of_term right) m1
- in
- m
-;;
-
-(* griggio *)
-module OrderedEquality = struct
- type t = Equality.equality
-
- let compare eq1 eq2 =
- match Equality.meta_convertibility_eq eq1 eq2 with
- | true -> 0
- | false ->
- let w1, _, (ty,left, right, _), m1,_ = Equality.open_equality eq1 in
- let w2, _, (ty',left', right', _), m2,_ = Equality.open_equality eq2 in
- match Pervasives.compare w1 w2 with
- | 0 ->
- let res = (List.length m1) - (List.length m2) in
- if res <> 0 then res else
- Equality.compare eq1 eq2
- | res -> res
-end
-
-module EqualitySet = Set.Make(OrderedEquality);;
-
-type passive_table = Equality.equality list * EqualitySet.t * Indexing.Index.t
-type active_table = Equality.equality list * Indexing.Index.t
-type new_proof =
- Equality.goal_proof * Equality.proof * int * Subst.substitution * Cic.metasenv
-type result =
- | ParamodulationFailure of
- string * active_table * passive_table * Equality.equality_bag
- | ParamodulationSuccess of
- new_proof * active_table * passive_table * Equality.equality_bag
-;;
-
-let list_of_passive (l,_,_) = l ;;
-let list_of_active (l,_) = l ;;
-
-let make_passive eq_list =
- let set =
- List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty eq_list
- in
- (* we have the invariant that the list and the set have the same
- * cardinality *)
- EqualitySet.elements set, set,
- List.fold_left Indexing.index Indexing.empty eq_list
-;;
-
-let make_empty_active () = [], Indexing.empty ;;
-let make_active eq_list =
- eq_list, List.fold_left Indexing.index Indexing.empty eq_list
-;;
-
-let size_of_passive (passive_list, _,_) = List.length passive_list;;
-let size_of_active (active_list, _) = List.length active_list;;
-
-let passive_is_empty = function
- | [], s , _ when EqualitySet.is_empty s -> true
- | [], s ,_ -> assert false (* the set and the list should be in sync *)
- | _ -> false
-;;
-
-type goals = Equality.goal list * Equality.goal list
-
-let no_more_passive_goals g = match g with | _,[] -> true | _ -> false;;
-
-
-let age_factor = 0.01;;
-
-(**
- selects one equality from passive. The selection strategy is a combination
- of weight, age and goal-similarity
-*)
-
-let rec select env g passive =
- processed_clauses := !processed_clauses + 1;
-(*
- let goal =
- match (List.rev goals) with goal::_ -> goal | _ -> assert false
- in
-*)
- let pos_list, pos_set, pos_table = passive in
- let remove eq l = List.filter (fun e -> Equality.compare e eq <> 0) l in
- if !weight_age_ratio > 0 then
- weight_age_counter := !weight_age_counter - 1;
- match !weight_age_counter with
- | 0 -> (
- weight_age_counter := !weight_age_ratio;
- let skip_giant pos_list pos_set pos_table =
- match pos_list with
- | (hd:EqualitySet.elt)::tl ->
- let w,_,_,_,_ = Equality.open_equality hd in
- if w < 30 then
- hd, (tl, EqualitySet.remove hd pos_set,
- Indexing.remove_index pos_table hd)
- else
-(*
- (prerr_endline
- ("+++ skipping giant of size "^string_of_int w^" +++");
-*)
- select env g (tl@[hd],pos_set,pos_table)
- | _ -> assert false
- in
- skip_giant pos_list pos_set pos_table)
-
-(*
- let rec skip_giant pos_list pos_set =
- match pos_list with
- | (hd:EqualitySet.elt)::tl ->
- let w,_,_,_,_ = Equality.open_equality hd in
- let pos_set = EqualitySet.remove hd pos_set in
- if w < 30 then
- hd, (tl, pos_set)
- else
- (prerr_endline
- ("+++ skipping giant of size "^string_of_int w^" +++");
- skip_giant tl pos_set)
- | _ -> assert false
- in
- skip_giant pos_list pos_set)
-
-*)
-(*
- | _ when (!symbols_counter > 0) ->
- (symbols_counter := !symbols_counter - 1;
- let cardinality map =
- Utils.TermMap.fold (fun k v res -> res + v) map 0
- in
- let symbols =
- let _, _, term = goal in
- Utils.symbols_of_term term
- in
- let card = cardinality symbols in
- let foldfun k v (r1, r2) =
- if Utils.TermMap.mem k symbols then
- let c = Utils.TermMap.find k symbols in
- let c1 = abs (c - v) in
- let c2 = v - c1 in
- r1 + c2, r2 + c1
- else
- r1, r2 + v
- in
- let f equality (i, e) =
- let common, others =
- Utils.TermMap.fold foldfun (symbols_of_equality equality) (0, 0)
- in
- let c = others + (abs (common - card)) in
- if c < i then (c, equality)
- else (i, e)
- in
- let e1 = EqualitySet.min_elt pos_set in
- let initial =
- let common, others =
- Utils.TermMap.fold foldfun (symbols_of_equality e1) (0, 0)
- in
- (others + (abs (common - card))), e1
- in
- let _, current = EqualitySet.fold f pos_set initial in
- current,
- (remove current pos_list, EqualitySet.remove current pos_set))
-*)
- | _ ->
- symbols_counter := !symbols_ratio;
- let my_min e1 e2 =
- let w1,_,_,_,_ = Equality.open_equality e1 in
- let w2,_,_,_,_ = Equality.open_equality e2 in
- if w1 < w2 then e1 else e2
- in
- let rec my_min_elt min = function
- | [] -> min
- | hd::tl -> my_min_elt (my_min hd min) tl
- in
-(* let current = EqualitySet.min_elt pos_set in *)
- let current = my_min_elt (List.hd pos_list) (List.tl pos_list) in
- current,(remove current pos_list, EqualitySet.remove current pos_set,
- Indexing.remove_index pos_table current)
-;;
-
-
-let filter_dependent bag passive id =
- let pos_list, pos_set, pos_table = passive in
- let passive,no_pruned =
- List.fold_right
- (fun eq ((list,set,table),no) ->
- if Equality.depend bag eq id then
- (list, EqualitySet.remove eq set,Indexing.remove_index table eq),
- no + 1
- else
- (eq::list,set,table), no)
- pos_list (([],pos_set,pos_table),0)
- in
-(*
- if no_pruned > 0 then
- prerr_endline ("+++ pruning "^ string_of_int no_pruned ^" passives +++");
-*)
- passive
-;;
-
-
-(* adds to passive a list of equalities new_pos *)
-let add_to_passive passive new_pos preferred =
- let pos_list, pos_set , pos_table = passive in
- let ok set equality = not (EqualitySet.mem equality set) in
- let pos = List.filter (ok pos_set) new_pos in
- let add set equalities =
- List.fold_left (fun s e -> EqualitySet.add e s) set equalities
- in
- let pos_head, pos_tail =
- List.partition
- (fun e -> List.exists (fun x -> Equality.compare x e = 0) preferred)
- pos
- in
- pos_head @ pos_list @ pos_tail, add pos_set pos,
- List.fold_left Indexing.index pos_table pos
-;;
-
-(* TODO *)
-(* removes from passive equalities that are estimated impossible to activate
- within the current time limit *)
-let prune_passive howmany (active, _) passive =
- let (pl, ps), tbl = passive in
- let howmany = float_of_int howmany
- and ratio = float_of_int !weight_age_ratio in
- let round v =
- let t = ceil v in
- int_of_float (if t -. v < 0.5 then t else v)
- in
- let in_weight = round (howmany *. ratio /. (ratio +. 1.))
- and in_age = round (howmany /. (ratio +. 1.)) in
- Utils.debug_print
- (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age));
- let counter = ref !symbols_ratio in
- let rec pickw w ps =
- if w > 0 then
- if !counter > 0 then
- let _ =
- counter := !counter - 1;
- if !counter = 0 then counter := !symbols_ratio in
- let e = EqualitySet.min_elt ps in
- let ps' = pickw (w-1) (EqualitySet.remove e ps) in
- EqualitySet.add e ps'
- else
- let e = EqualitySet.min_elt ps in
- let ps' = pickw (w-1) (EqualitySet.remove e ps) in
- EqualitySet.add e ps'
- else
- EqualitySet.empty
- in
- let ps = pickw in_weight ps in
- let rec picka w s l =
- if w > 0 then
- match l with
- | [] -> w, s, []
- | hd::tl when not (EqualitySet.mem hd s) ->
- let w, s, l = picka (w-1) s tl in
- w, EqualitySet.add hd s, hd::l
- | hd::tl ->
- let w, s, l = picka w s tl in
- w, s, hd::l
- else
- 0, s, l
- in
- let _, ps, pl = picka in_age ps pl in
- if not (EqualitySet.is_empty ps) then
- maximal_retained_equality := Some (EqualitySet.max_elt ps);
- let tbl =
- EqualitySet.fold
- (fun e tbl -> Indexing.index tbl e) ps Indexing.empty
- in
- (pl, ps), tbl
-;;
-
-
-(** inference of new equalities between current and some in active *)
-let infer bag eq_uri env current (active_list, active_table) =
- let (_,c,_) = env in
- if Utils.debug_metas then
- (ignore(Indexing.check_target bag c current "infer1");
- ignore(List.map (function current -> Indexing.check_target bag c current "infer2") active_list));
- let bag, new_pos =
- let bag, copy_of_current = Equality.fix_metas bag current in
- let active_table = Indexing.index active_table copy_of_current in
-(* let _ = <:start<current contro active>> in *)
- let bag, res =
- Indexing.superposition_right bag eq_uri env active_table current
- in
-(* let _ = <:stop<current contro active>> in *)
- if Utils.debug_metas then
- ignore(List.map
- (function current ->
- Indexing.check_target bag c current "sup0") res);
- let rec infer_positive bag table = function
- | [] -> bag, []
- | equality::tl ->
- let bag, res =
- Indexing.superposition_right bag
- ~subterms_only:true eq_uri env table equality
- in
- if Utils.debug_metas then
- ignore
- (List.map
- (function current ->
- Indexing.check_target bag c current "sup2") res);
- let bag, pos = infer_positive bag table tl in
- bag, res @ pos
- in
- let curr_table = Indexing.index Indexing.empty current in
- let bag, pos = infer_positive bag curr_table ((*copy_of_current::*)active_list) in
- if Utils.debug_metas then
- ignore(List.map
- (function current ->
- Indexing.check_target bag c current "sup3") pos);
- bag, res @ pos
- in
- derived_clauses := !derived_clauses + (List.length new_pos);
- match !maximal_retained_equality with
- | None -> bag, new_pos
- | Some eq ->
- ignore(assert false);
- (* if we have a maximal_retained_equality, we can discard all equalities
- "greater" than it, as they will never be reached... An equality is
- greater than maximal_retained_equality if it is bigger
- wrt. OrderedEquality.compare and it is less similar than
- maximal_retained_equality to the current goal *)
- bag, List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos
-;;
-
-let check_for_deep_subsumption env active_table eq =
- let _,_,(eq_ty, left, right, order),metas,id = Equality.open_equality eq in
- let check_subsumed deep l r =
- let eqtmp =
- Equality.mk_tmp_equality(0,(eq_ty,l,r,Utils.Incomparable),metas)in
- match Indexing.subsumption env active_table eqtmp with
- | None -> false
- | Some _ -> true
- in
- let rec aux b (ok_so_far, subsumption_used) t1 t2 =
- match t1,t2 with
- | t1, t2 when not ok_so_far -> ok_so_far, subsumption_used
- | t1, t2 when subsumption_used -> t1 = t2, subsumption_used
- | Cic.Appl (h1::l),Cic.Appl (h2::l') ->
- let rc = check_subsumed b t1 t2 in
- if rc then
- true, true
- else if h1 = h2 then
- (try
- List.fold_left2
- (fun (ok_so_far, subsumption_used) t t' ->
- aux true (ok_so_far, subsumption_used) t t')
- (ok_so_far, subsumption_used) l l'
- with Invalid_argument _ -> false,subsumption_used)
- else
- false, subsumption_used
- | _ -> false, subsumption_used
- in
- fst (aux false (true,false) left right)
-;;
-
-(** simplifies current using active and passive *)
-let forward_simplify bag eq_uri env current (active_list, active_table) =
- let _, context, _ = env in
- let demodulate bag table current =
- let bag, newcurrent =
- Indexing.demodulation_equality bag eq_uri env table current
- in
- bag, if Equality.is_identity env newcurrent then None else Some newcurrent
- in
- let demod bag current =
- if Utils.debug_metas then
- ignore (Indexing.check_target bag context current "demod0");
- let bag, res = demodulate bag active_table current in
- if Utils.debug_metas then
- ignore ((function None -> () | Some x ->
- ignore (Indexing.check_target bag context x "demod1");()) res);
- bag, res
- in
- let bag, res = demod bag current in
- match res with
- | None -> bag, None
- | Some c ->
- if Indexing.in_index active_table c ||
- check_for_deep_subsumption env active_table c
- then
- bag, None
- else
- bag, res
-;;
-
-(** simplifies new using active and passive *)
-let forward_simplify_new bag eq_uri env new_pos active =
- if Utils.debug_metas then
- begin
- let m,c,u = env in
- ignore(List.map
- (fun current -> Indexing.check_target bag c current "forward new pos")
- new_pos;)
- end;
- let active_list, active_table = active in
- let demodulate bag table target =
- let bag, newtarget =
- Indexing.demodulation_equality bag eq_uri env table target
- in
- bag, newtarget
- in
- (* we could also demodulate using passive. Currently we don't *)
- let bag, new_pos =
- List.fold_right (fun x (bag,acc) ->
- let bag, y = demodulate bag active_table x in
- bag, y::acc)
- new_pos (bag,[])
- in
- let new_pos_set =
- List.fold_left
- (fun s e ->
- if not (Equality.is_identity env e) then
- EqualitySet.add e s
- else s)
- EqualitySet.empty new_pos
- in
- let new_pos = EqualitySet.elements new_pos_set in
- let subs e = Indexing.subsumption env active_table e = None in
- let is_duplicate e = not (Indexing.in_index active_table e) in
- bag, List.filter subs (List.filter is_duplicate new_pos)
-;;
-
-
-(** simplifies a goal with equalities in active and passive *)
-let rec simplify_goal bag env goal (active_list, active_table) =
- let demodulate table goal = Indexing.demodulation_goal bag env table goal in
- let changed, goal = demodulate active_table goal in
- changed,
- if not changed then
- goal
- else
- snd (simplify_goal bag env goal (active_list, active_table))
-;;
-
-
-let simplify_goals bag env goals active =
- let a_goals, p_goals = goals in
- let p_goals = List.map (fun g -> snd (simplify_goal bag env g active)) p_goals in
- let a_goals = List.map (fun g -> snd (simplify_goal bag env g active)) a_goals in
- a_goals, p_goals
-;;
-
-
-(** simplifies active usign new *)
-let backward_simplify_active
- bag eq_uri env new_pos new_table min_weight active
-=
- let active_list, active_table = active in
- let bag, active_list, newa, pruned =
- List.fold_right
- (fun equality (bag, res, newn,pruned) ->
- let ew, _, _, _,id = Equality.open_equality equality in
- if ew < min_weight then
- bag, equality::res, newn,pruned
- else
- match
- forward_simplify bag eq_uri env equality (new_pos, new_table)
- with
- | bag, None -> bag, res, newn, id::pruned
- | bag, Some e ->
- if Equality.compare equality e = 0 then
- bag, e::res, newn, pruned
- else
- bag, res, e::newn, pruned)
- active_list (bag, [], [],[])
- in
- let find eq1 where =
- List.exists (Equality.meta_convertibility_eq eq1) where
- in
- let id_of_eq eq =
- let _, _, _, _,id = Equality.open_equality eq in id
- in
- let ((active1,pruned),tbl), newa =
- List.fold_right
- (fun eq ((res,pruned), tbl) ->
- if List.mem eq res then
- (res, (id_of_eq eq)::pruned),tbl
- else if (Equality.is_identity env eq) || (find eq res) then (
- (res, (id_of_eq eq)::pruned),tbl
- )
- else
- (eq::res,pruned), Indexing.index tbl eq)
- active_list (([],pruned), Indexing.empty),
- List.fold_right
- (fun eq p ->
- if (Equality.is_identity env eq) then p
- else eq::p)
- newa []
- in
- match newa with
- | [] -> bag, (active1,tbl), None, pruned
- | _ -> bag, (active1,tbl), Some newa, pruned
-;;
-
-
-(** simplifies passive using new *)
-let backward_simplify_passive
- bag eq_uri env new_pos new_table min_weight passive
-=
- let (pl, ps), passive_table = passive in
- let f bag equality (resl, ress, newn) =
- let ew, _, _, _ , _ = Equality.open_equality equality in
- if ew < min_weight then
- bag, (equality::resl, ress, newn)
- else
- match
- forward_simplify bag eq_uri env equality (new_pos, new_table)
- with
- | bag, None ->
- bag, (resl, EqualitySet.remove equality ress, newn)
- | bag, Some e ->
- if equality = e then
- bag, (equality::resl, ress, newn)
- else
- let ress = EqualitySet.remove equality ress in
- bag, (resl, ress, e::newn)
- in
- let bag, (pl, ps, newp) =
- List.fold_right (fun x (bag,acc) -> f bag x acc) pl (bag,([], ps, [])) in
- let passive_table =
- List.fold_left
- (fun tbl e -> Indexing.index tbl e) Indexing.empty pl
- in
- match newp with
- | [] -> bag, ((pl, ps), passive_table), None
- | _ -> bag, ((pl, ps), passive_table), Some (newp)
-;;
-
-let build_table equations =
- List.fold_left
- (fun (l, t, w) e ->
- let ew, _, _, _ , _ = Equality.open_equality e in
- e::l, Indexing.index t e, min ew w)
- ([], Indexing.empty, 1000000) equations
-;;
-
-
-let backward_simplify bag eq_uri env new' active =
- let new_pos, new_table, min_weight = build_table new' in
- let bag, active, newa, pruned =
- backward_simplify_active bag eq_uri env new_pos new_table min_weight active
- in
- bag, active, newa, pruned
-;;
-
-let close bag eq_uri env new' given =
- let new_pos, new_table, min_weight =
- List.fold_left
- (fun (l, t, w) e ->
- let ew, _, _, _ , _ = Equality.open_equality e in
- e::l, Indexing.index t e, min ew w)
- ([], Indexing.empty, 1000000) (snd new')
- in
- List.fold_left
- (fun (bag,p) c ->
- let bag, pos = infer bag eq_uri env c (new_pos,new_table) in
- bag, pos@p)
- (bag,[]) given
-;;
-
-let is_commutative_law eq =
- let w, proof, (eq_ty, left, right, order), metas , _ =
- Equality.open_equality eq
- in
- match left,right with
- Cic.Appl[f1;Cic.Meta _ as a1;Cic.Meta _ as b1],
- Cic.Appl[f2;Cic.Meta _ as a2;Cic.Meta _ as b2] ->
- f1 = f2 && a1 = b2 && a2 = b1
- | _ -> false
-;;
-
-let prova bag eq_uri env new' active =
- let given = List.filter is_commutative_law (fst active) in
- let _ =
- Utils.debug_print
- (lazy
- (Printf.sprintf "symmetric:\n%s\n"
- (String.concat "\n"
- (List.map
- (fun e -> Equality.string_of_equality ~env e)
- given)))) in
- close bag eq_uri env new' given
-;;
-
-(* returns an estimation of how many equalities in passive can be activated
- within the current time limit *)
-let get_selection_estimate () =
- elapsed_time := (Unix.gettimeofday ()) -. !start_time;
- (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *)
- int_of_float (
- ceil ((float_of_int !processed_clauses) *.
- ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.)))
-;;
-
-
-(** initializes the set of goals *)
-let make_goals goal =
- let active = []
- and passive = [0, [goal]] in
- active, passive
-;;
-
-let make_goal_set goal =
- ([],[goal])
-;;
-
-(** initializes the set of theorems *)
-let make_theorems theorems =
- theorems, []
-;;
-
-
-let activate_goal (active, passive) =
- if active = [] then
- match passive with
- | goal_conj::tl -> true, (goal_conj::active, tl)
- | [] -> false, (active, passive)
- else
- true, (active,passive)
-;;
-
-
-let activate_theorem (active, passive) =
- match passive with
- | theorem::tl -> true, (theorem::active, tl)
- | [] -> false, (active, passive)
-;;
-
-let rec simpl bag eq_uri env e others others_simpl =
- let active = others @ others_simpl in
- let tbl =
- List.fold_left
- (fun t e ->
- if Equality.is_identity env e then t else Indexing.index t e)
- Indexing.empty active
- in
- let bag, res =
- forward_simplify bag eq_uri env e (active, tbl)
- in
- match others with
- | hd::tl -> (
- match res with
- | None -> simpl bag eq_uri env hd tl others_simpl
- | Some e -> simpl bag eq_uri env hd tl (e::others_simpl)
- )
- | [] -> (
- match res with
- | None -> bag, others_simpl
- | Some e -> bag, e::others_simpl
- )
-;;
-
-let simplify_equalities bag eq_uri env equalities =
- Utils.debug_print
- (lazy
- (Printf.sprintf "equalities:\n%s\n"
- (String.concat "\n"
- (List.map Equality.string_of_equality equalities))));
-Utils.debug_print (lazy "SIMPLYFYING EQUALITIES...");
- match equalities with
- | [] -> bag, []
- | hd::tl ->
- let bag, res = simpl bag eq_uri env hd tl [] in
- let res = List.rev res in
- Utils.debug_print
- (lazy
- (Printf.sprintf "equalities AFTER:\n%s\n"
- (String.concat "\n"
- (List.map Equality.string_of_equality res))));
- bag, res
-;;
-
-let print_goals goals =
- (String.concat "\n"
- (List.map
- (fun (d, gl) ->
- let gl' =
- List.map
- (fun (p, _, t) ->
- (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl
- in
- Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals))
-;;
-
-let pp_goal_set msg goals names =
- let active_goals, passive_goals = goals in
- debug_print (lazy ("////" ^ msg));
- debug_print (lazy ("ACTIVE G: " ^
- (String.concat "\n " (List.map (fun (_,_,g) -> CicPp.pp g names)
- active_goals))));
- debug_print (lazy ("PASSIVE G: " ^
- (String.concat "\n " (List.map (fun (_,_,g) -> CicPp.pp g names)
- passive_goals))))
-;;
-
-let check_if_goal_is_subsumed bag ((_,ctx,_) as env) table (goalproof,menv,ty) =
-(* let names = Utils.names_of_context ctx in *)
- match ty with
- | Cic.Appl[Cic.MutInd(uri,_,_);eq_ty;left;right]
- when LibraryObjects.is_eq_URI uri ->
- (let bag, goal_equation =
- Equality.mk_equality bag
- (0,Equality.Exact (Cic.Implicit None),(eq_ty,left,right,Utils.Eq),menv)
- in
- (* match Indexing.subsumption env table goal_equation with *)
- match Indexing.unification env table goal_equation with
- | Some (subst, equality, swapped ) ->
-(*
- prerr_endline
- ("GOAL SUBSUMED IS: "^Equality.string_of_equality goal_equation ~env);
- prerr_endline
- ("GOAL IS SUBSUMED BY: "^Equality.string_of_equality equality ~env);
- prerr_endline ("SUBST:"^Subst.ppsubst ~names subst);
-*)
- let (_,p,(ty,l,r,_),m,id) = Equality.open_equality equality in
- let cicmenv = Subst.apply_subst_metasenv subst (m @ menv) in
- let bag, p =
- if swapped then
- Equality.symmetric bag eq_ty l id uri m
- else
- bag, p
- in
- bag, Some (goalproof, p, id, subst, cicmenv)
- | None ->
- bag, None)
- | _ -> bag, None
-;;
-
-let find_all_subsumed bag env table (goalproof,menv,ty) =
- match ty with
- | Cic.Appl[Cic.MutInd(uri,_,_);eq_ty;left;right]
- when LibraryObjects.is_eq_URI uri ->
- let bag, goal_equation =
- (Equality.mk_equality bag
- (0,Equality.Exact (Cic.Implicit None),(eq_ty,left,right,Utils.Eq),menv))
- in
- List.fold_right
- (fun (subst, equality, swapped) (bag,acc) ->
- let (_,p,(ty,l,r,_),m,id) = Equality.open_equality equality in
- let cicmenv = Subst.apply_subst_metasenv subst (m @ menv) in
- if Utils.debug_metas then
- Indexing.check_for_duplicates cicmenv "from subsumption";
- let bag, p =
- if swapped then
- Equality.symmetric bag eq_ty l id uri m
- else
- bag, p
- in
- bag, (goalproof, p, id, subst, cicmenv)::acc)
- (Indexing.subsumption_all env table goal_equation) (bag,[])
- (* (Indexing.unification_all env table goal_equation) *)
- | _ -> assert false
-;;
-
-
-let check_if_goal_is_identity env = function
- | (goalproof,m,Cic.Appl[Cic.MutInd(uri,_,ens);eq_ty;left;right])
- when left = right && LibraryObjects.is_eq_URI uri ->
- let reflproof = Equality.Exact (Equality.refl_proof uri eq_ty left) in
- Some (goalproof, reflproof, 0, Subst.empty_subst,m)
- | (goalproof,m,Cic.Appl[Cic.MutInd(uri,_,ens);eq_ty;left;right])
- when LibraryObjects.is_eq_URI uri ->
- (let _,context,_ = env in
- try
- let s,m,_ =
- Founif.unification [] m context left right CicUniv.empty_ugraph
- in
- let reflproof = Equality.Exact (Equality.refl_proof uri eq_ty left) in
- let m = Subst.apply_subst_metasenv s m in
- Some (goalproof, reflproof, 0, s,m)
- with CicUnification.UnificationFailure _ -> None)
- | _ -> None
-;;
-
-let rec check b goal = function
- | [] -> b, None
- | f::tl ->
- match f b goal with
- | b, None -> check b goal tl
- | b, (Some _ as ok) -> b, ok
-;;
-
-let simplify_goal_set bag env goals active =
- let active_goals, passive_goals = goals in
- let find (_,_,g) where =
- List.exists (fun (_,_,g1) -> Equality.meta_convertibility g g1) where
- in
- (* prova:tengo le passive semplificate
- let passive_goals =
- List.map (fun g -> snd (simplify_goal env g active)) passive_goals
- in *)
- List.fold_left
- (fun (acc_a,acc_p) goal ->
- match simplify_goal bag env goal active with
- | changed, g ->
- if changed then
- if find g acc_p then acc_a,acc_p else acc_a,g::acc_p
- else
- if find g acc_a then acc_a,acc_p else g::acc_a,acc_p)
- ([],passive_goals) active_goals
-;;
-
-let check_if_goals_set_is_solved bag env active passive goals =
- let active_goals, passive_goals = goals in
- List.fold_left
- (fun (bag, proof) goal ->
- match proof with
- | Some p -> bag, proof
- | None ->
- check bag goal [
- (fun b x -> b, check_if_goal_is_identity env x);
- (fun bag -> check_if_goal_is_subsumed bag env (snd active));
- (fun bag -> check_if_goal_is_subsumed bag env (last passive))
- ])
- (bag,None) (active_goals @ passive_goals)
-;;
-
-let infer_goal_set bag env active goals =
- let active_goals, passive_goals = goals in
- let rec aux bag = function
- | [] -> bag, (active_goals, [])
- | hd::tl ->
- let changed, selected = simplify_goal bag env hd active in
- let (_,m1,t1) = selected in
- let already_in =
- List.exists (fun (_,_,t) -> Equality.meta_convertibility t t1)
- active_goals
- in
- if already_in then
- aux bag tl
- else
- let passive_goals = tl in
- let bag, new_passive_goals =
- if Utils.metas_of_term t1 = [] then
- bag, passive_goals
- else
- let bag, new' =
- Indexing.superposition_left bag env (snd active) selected
- in
- bag, passive_goals @ new'
- in
- bag, (selected::active_goals, new_passive_goals)
- in
- aux bag passive_goals
-;;
-
-let infer_goal_set_with_current bag env current goals active =
- let active_goals, passive_goals = simplify_goal_set bag env goals active in
- let l,table,_ = build_table [current] in
- let bag, passive_goals =
- List.fold_left
- (fun (bag, acc) g ->
- let bag, new' = Indexing.superposition_left bag env table g in
- bag, acc @ new')
- (bag, passive_goals) active_goals
- in
- bag, active_goals, passive_goals
-;;
-
-let ids_of_goal g =
- let p,_,_ = g in
- let ids = List.map (fun _,_,i,_,_ -> i) p in
- ids
-;;
-
-let ids_of_goal_set (ga,gp) =
- List.flatten (List.map ids_of_goal ga) @
- List.flatten (List.map ids_of_goal gp)
-;;
-
-let size_of_goal_set_a (l,_) = List.length l;;
-let size_of_goal_set_p (_,l) = List.length l;;
-
-let pp_goals label goals context =
- let names = Utils.names_of_context context in
- List.iter
- (fun _,_,g ->
- debug_print (lazy
- (Printf.sprintf "Current goal: %s = %s\n" label (CicPp.pp g names))))
- (fst goals);
- List.iter
- (fun _,_,g ->
- debug_print (lazy
- (Printf.sprintf "PASSIVE goal: %s = %s\n" label (CicPp.pp g names))))
- (snd goals);
-;;
-
-let print_status iterno goals active passive =
- debug_print (lazy
- (Printf.sprintf "\n%d #ACTIVES: %d #PASSIVES: %d #GOALSET: %d(%d)"
- iterno (size_of_active active) (size_of_passive passive)
- (size_of_goal_set_a goals) (size_of_goal_set_p goals)))
-;;
-
-let add_to_active_aux bag active passive env eq_uri current =
- debug_print (lazy ("Adding to actives : " ^
- Equality.string_of_equality ~env current));
- match forward_simplify bag eq_uri env current active with
- | bag, None -> None, active, passive, bag
- | bag, Some current ->
- let bag, new' = infer bag eq_uri env current active in
- let active =
- let al, tbl = active in
- al @ [current], Indexing.index tbl current
- in
- let rec simplify bag new' active passive =
- let bag, new' =
- forward_simplify_new bag eq_uri env new' active
- in
- let bag, active, newa, pruned =
- backward_simplify bag eq_uri env new' active
- in
- let passive =
- List.fold_left (filter_dependent bag) passive pruned
- in
- match newa with
- | None -> bag, active, passive, new'
- | Some p -> simplify bag (new' @ p) active passive
- in
- let bag, active, passive, new' =
- simplify bag new' active passive
- in
- let passive = add_to_passive passive new' [] in
- Some new', active, passive, bag
-;;
-
-(** given-clause algorithm with full reduction strategy: NEW implementation *)
-(* here goals is a set of goals in OR *)
-let given_clause
- bag eq_uri ((_,context,_) as env) goals passive active
- goal_steps saturation_steps max_time
-=
- let initial_time = Unix.gettimeofday () in
- let iterations_left iterno =
- let now = Unix.gettimeofday () in
- let time_left = max_time -. now in
- let time_spent_until_now = now -. initial_time in
- let iteration_medium_cost =
- time_spent_until_now /. (float_of_int iterno)
- in
- let iterations_left = time_left /. iteration_medium_cost in
- int_of_float iterations_left
- in
- let rec step bag goals passive active g_iterno s_iterno =
- if g_iterno > goal_steps && s_iterno > saturation_steps then
- (ParamodulationFailure ("No more iterations to spend",active,passive,bag))
- else if Unix.gettimeofday () > max_time then
- (ParamodulationFailure ("No more time to spend",active,passive,bag))
- else
- let _ =
- print_status (max g_iterno s_iterno) goals active passive
-(* Printf.eprintf ".%!"; *)
- in
- (* PRUNING OF PASSIVE THAT WILL NEVER BE PROCESSED *)
- let passive =
- let selection_estimate = iterations_left (max g_iterno s_iterno) in
- let kept = size_of_passive passive in
- if kept > selection_estimate then
- begin
- (*Printf.eprintf "Too many passive equalities: pruning...";
- prune_passive selection_estimate active*) passive
- end
- else
- passive
- in
- kept_clauses := (size_of_passive passive) + (size_of_active active);
- let bag, goals =
- if g_iterno < goal_steps then
- infer_goal_set bag env active goals
- else
- bag, goals
- in
- match check_if_goals_set_is_solved bag env active passive goals with
- | bag, Some p ->
- debug_print (lazy
- (Printf.sprintf "\nFound a proof in: %f\n"
- (Unix.gettimeofday() -. initial_time)));
- ParamodulationSuccess (p,active,passive,bag)
- | bag, None ->
- (* SELECTION *)
- if passive_is_empty passive then
- if no_more_passive_goals goals then
- ParamodulationFailure
- ("No more passive equations/goals",active,passive,bag)
- (*maybe this is a success! *)
- else
- step bag goals passive active (g_iterno+1) (s_iterno+1)
- else
- begin
- (* COLLECTION OF GARBAGED EQUALITIES *)
- let bag =
- if max g_iterno s_iterno mod 40 = 0 then
- (print_status (max g_iterno s_iterno) goals active passive;
- let active = List.map Equality.id_of (fst active) in
- let passive = List.map Equality.id_of (fst3 passive) in
- let goal = ids_of_goal_set goals in
- Equality.collect bag active passive goal)
- else
- bag
- in
- if s_iterno > saturation_steps then
- step bag goals passive active (g_iterno+1) (s_iterno+1)
- (* ParamodulationFailure ("max saturation steps",active,passive,bag) *)
- else
- let current, passive = select env goals passive in
- match add_to_active_aux bag active passive env eq_uri current with
- | None, active, passive, bag ->
- step bag goals passive active (g_iterno+1) (s_iterno+1)
- | Some new', active, passive, bag ->
- let bag, active_goals, passive_goals =
- infer_goal_set_with_current bag env current goals active
- in
- let goals =
- let a,b,_ = build_table new' in
- let rc =
- simplify_goal_set bag env (active_goals,passive_goals) (a,b)
- in
- rc
- in
- step bag goals passive active (g_iterno+1) (s_iterno+1)
- end
- in
- step bag goals passive active 0 0
-;;
-
-let rec saturate_equations bag eq_uri env goal accept_fun passive active =
- elapsed_time := Unix.gettimeofday () -. !start_time;
- if !elapsed_time > !time_limit then
- bag, active, passive
- else
- let current, passive = select env ([goal],[]) passive in
- let bag, res = forward_simplify bag eq_uri env current active in
- match res with
- | None ->
- saturate_equations bag eq_uri env goal accept_fun passive active
- | Some current ->
- Utils.debug_print (lazy (Printf.sprintf "selected: %s"
- (Equality.string_of_equality ~env current)));
- let bag, new' = infer bag eq_uri env current active in
- let active =
- if Equality.is_identity env current then active
- else
- let al, tbl = active in
- al @ [current], Indexing.index tbl current
- in
- (* alla fine new' contiene anche le attive semplificate!
- * quindi le aggiungo alle passive insieme alle new *)
- let rec simplify bag new' active passive =
- let bag, new' = forward_simplify_new bag eq_uri env new' active in
- let bag, active, newa, pruned =
- backward_simplify bag eq_uri env new' active in
- let passive =
- List.fold_left (filter_dependent bag) passive pruned in
- match newa with
- | None -> bag, active, passive, new'
- | Some p -> simplify bag (new' @ p) active passive
- in
- let bag, active, passive, new' = simplify bag new' active passive in
- let _ =
- Utils.debug_print
- (lazy
- (Printf.sprintf "active:\n%s\n"
- (String.concat "\n"
- (List.map
- (fun e -> Equality.string_of_equality ~env e)
- (fst active)))))
- in
- let _ =
- Utils.debug_print
- (lazy
- (Printf.sprintf "new':\n%s\n"
- (String.concat "\n"
- (List.map
- (fun e -> "Negative " ^
- (Equality.string_of_equality ~env e)) new'))))
- in
- let new' = List.filter accept_fun new' in
- let passive = add_to_passive passive new' [] in
- saturate_equations bag eq_uri env goal accept_fun passive active
-;;
-
-let default_depth = !maxdepth
-and default_width = !maxwidth;;
-
-let reset_refs () =
- symbols_counter := 0;
- weight_age_counter := !weight_age_ratio;
- processed_clauses := 0;
- start_time := 0.;
- elapsed_time := 0.;
- maximal_retained_equality := None;
- infer_time := 0.;
- forward_simpl_time := 0.;
- forward_simpl_new_time := 0.;
- backward_simpl_time := 0.;
- passive_maintainance_time := 0.;
- derived_clauses := 0;
- kept_clauses := 0;
-;;
-
-let add_to_active bag active passive env ty term newmetas =
- reset_refs ();
- match LibraryObjects.eq_URI () with
- | None -> active, passive, bag
- | Some eq_uri ->
- try
- let bag, current = Equality.equality_of_term bag term ty newmetas in
- let w,_,_,_,_ = Equality.open_equality current in
- if w > 100 then
- (HLog.debug
- ("skipping giant " ^ CicPp.ppterm term ^ " of weight " ^
- string_of_int w); active, passive, bag)
- else
- let bag, current = Equality.fix_metas bag current in
- match add_to_active_aux bag active passive env eq_uri current with
- | _,a,p,b -> a,p,b
- with
- | Equality.TermIsNotAnEquality -> active, passive, bag
-;;
-
-
-let eq_of_goal = function
- | Cic.Appl [Cic.MutInd(uri,0,_);_;_;_] when LibraryObjects.is_eq_URI uri ->
- uri
- | _ -> raise (ProofEngineTypes.Fail (lazy ("The goal is not an equality ")))
-;;
-
-let eq_and_ty_of_goal = function
- | Cic.Appl [Cic.MutInd(uri,0,_);t;_;_] when LibraryObjects.is_eq_URI uri ->
- uri,t
- | _ -> raise (ProofEngineTypes.Fail (lazy ("The goal is not an equality ")))
-;;
-
-(* fix proof takes in input a term and try to build a metasenv for it *)
-
-let fix_proof metasenv context all_implicits p =
- let rec aux metasenv n p =
- match p with
- | Cic.Meta (i,_) ->
- if all_implicits then
- metasenv,Cic.Implicit None
- else
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- let meta = CicSubstitution.lift n (Cic.Meta (i,irl)) in
- let metasenv =
- try
- let _ = CicUtil.lookup_meta i metasenv in metasenv
- with CicUtil.Meta_not_found _ ->
- debug_print (lazy ("not found: "^(string_of_int i)));
- let metasenv,j = CicMkImplicit.mk_implicit_type metasenv [] context in
- (i,context,Cic.Meta(j,irl))::metasenv
- in
- metasenv,meta
- | Cic.Appl l ->
- let metasenv,l=
- List.fold_right
- (fun a (metasenv,l) ->
- let metasenv,a' = aux metasenv n a in
- metasenv,a'::l)
- l (metasenv,[])
- in metasenv,Cic.Appl l
- | Cic.Lambda(name,s,t) ->
- let metasenv,s = aux metasenv n s in
- let metasenv,t = aux metasenv (n+1) t in
- metasenv,Cic.Lambda(name,s,t)
- | Cic.Prod(name,s,t) ->
- let metasenv,s = aux metasenv n s in
- let metasenv,t = aux metasenv (n+1) t in
- metasenv,Cic.Prod(name,s,t)
- | Cic.LetIn(name,s,ty,t) ->
- let metasenv,s = aux metasenv n s in
- let metasenv,ty = aux metasenv n ty in
- let metasenv,t = aux metasenv (n+1) t in
- metasenv,Cic.LetIn(name,s,ty,t)
- | Cic.Const(uri,ens) ->
- let metasenv,ens =
- List.fold_right
- (fun (v,a) (metasenv,ens) ->
- let metasenv,a' = aux metasenv n a in
- metasenv,(v,a')::ens)
- ens (metasenv,[])
- in
- metasenv,Cic.Const(uri,ens)
- | t -> metasenv,t
- in
- aux metasenv 0 p
-;;
-
-let fix_metasenv context metasenv =
- List.fold_left
- (fun m (i,c,t) ->
- let m,t = fix_proof m context false t in
- let m = List.filter (fun (j,_,_) -> j<>i) m in
- (i,context,t)::m)
- metasenv metasenv
-;;
-
-
-(* status: input proof status
- * goalproof: forward steps on goal
- * newproof: backward steps
- * subsumption_id: the equation used if goal is closed by subsumption
- * (0 if not closed by subsumption) (DEBUGGING: can be safely removed)
- * subsumption_subst: subst to make newproof and goalproof match
- * proof_menv: final metasenv
- *)
-
-let build_proof
- bag status
- goalproof newproof subsumption_id subsumption_subst proof_menv
-=
- if proof_menv = [] then debug_print (lazy "+++++++++++++++VUOTA")
- else debug_print (lazy (CicMetaSubst.ppmetasenv [] proof_menv));
- let proof, goalno = status in
- let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in
- let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in
- let eq_uri = eq_of_goal type_of_goal in
- let names = Utils.names_of_context context in
- debug_print (lazy "Proof:");
- debug_print (lazy
- (Equality.pp_proof bag names goalproof newproof subsumption_subst
- subsumption_id type_of_goal));
-(*
- prerr_endline ("max weight: " ^
- (string_of_int (Equality.max_weight goalproof newproof)));
-*)
- (* generation of the CIC proof *)
- (* let metasenv' = List.filter (fun i,_,_ -> i<>goalno) metasenv in *)
- let side_effects =
- List.filter (fun i -> i <> goalno)
- (ProofEngineHelpers.compare_metasenvs
- ~newmetasenv:metasenv ~oldmetasenv:proof_menv) in
- let goal_proof, side_effects_t =
- let initial = Equality.add_subst subsumption_subst newproof in
- Equality.build_goal_proof bag
- eq_uri goalproof initial type_of_goal side_effects
- context proof_menv
- in
-(* Equality.draw_proof bag names goalproof newproof subsumption_id; *)
- let goal_proof = Subst.apply_subst subsumption_subst goal_proof in
- (* assert (metasenv=[]); *)
- let real_menv = fix_metasenv context (proof_menv@metasenv) in
- let real_menv,goal_proof =
- fix_proof real_menv context false goal_proof in
-(*
- let real_menv,fixed_proof = fix_proof proof_menv context false goal_proof in
- (* prerr_endline ("PROOF: " ^ CicPp.pp goal_proof names); *)
-*)
- let pp_error goal_proof names error exn =
- prerr_endline "THE PROOF DOES NOT TYPECHECK! <begin>";
- prerr_endline (CicPp.pp goal_proof names);
- prerr_endline "THE PROOF DOES NOT TYPECHECK!";
- prerr_endline error;
- prerr_endline "THE PROOF DOES NOT TYPECHECK! <end>";
- raise exn
- in
- let old_insert_coercions = !CicRefine.insert_coercions in
- let goal_proof,goal_ty,real_menv,_ =
- (* prerr_endline ("parte la refine per: " ^ (CicPp.pp goal_proof names)); *)
- try
- debug_print (lazy (CicPp.ppterm goal_proof));
- CicRefine.insert_coercions := false;
- let res =
- CicRefine.type_of_aux'
- real_menv context goal_proof CicUniv.empty_ugraph
- in
- CicRefine.insert_coercions := old_insert_coercions;
- res
- with
- | CicRefine.RefineFailure s
- | CicRefine.Uncertain s
- | CicRefine.AssertFailure s as exn ->
- CicRefine.insert_coercions := old_insert_coercions;
- pp_error goal_proof names (Lazy.force s) exn
- | CicUtil.Meta_not_found i as exn ->
- CicRefine.insert_coercions := old_insert_coercions;
- pp_error goal_proof names ("META NOT FOUND: "^string_of_int i) exn
- | Invalid_argument "list_fold_left2" as exn ->
- CicRefine.insert_coercions := old_insert_coercions;
- pp_error goal_proof names "Invalid_argument: list_fold_left2" exn
- | exn ->
- CicRefine.insert_coercions := old_insert_coercions;
- raise exn
- in
- let subst_side_effects,real_menv,_ =
- try
- CicUnification.fo_unif_subst [] context real_menv
- goal_ty type_of_goal CicUniv.empty_ugraph
- with
- | CicUnification.UnificationFailure s
- | CicUnification.Uncertain s
- | CicUnification.AssertFailure s -> assert false
- (* fail "Maybe the local context of metas in the goal was not an IRL" s *)
- in
- Utils.debug_print (lazy "+++++++++++++ FINE UNIF");
- let final_subst =
- (goalno,(context,goal_proof,type_of_goal))::subst_side_effects
- in
-(*
- let metas_of_proof = Utils.metas_of_term goal_proof in
-*)
- let proof, real_metasenv =
- ProofEngineHelpers.subst_meta_and_metasenv_in_proof
- proof goalno final_subst
- (List.filter (fun i,_,_ -> i<>goalno ) real_menv)
- in
- let open_goals =
- (ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:real_metasenv) in
-(*
- let open_goals =
- List.map (fun i,_,_ -> i) real_metasenv in
-*)
- final_subst, proof, open_goals
-
-
-(*
-
- let metas_still_open_in_proof = Utils.metas_of_term goal_proof in
- (* prerr_endline (CicPp.pp goal_proof names); *)
- let goal_proof = (* Subst.apply_subst subsumption_subst *) goal_proof in
- let side_effects_t =
- List.map (Subst.apply_subst subsumption_subst) side_effects_t
- in
- (* replacing fake mets with real ones *)
- (* prerr_endline "replacing metas..."; *)
- let irl=CicMkImplicit.identity_relocation_list_for_metavariable context in
- CicMetaSubst.ppmetasenv [] proof_menv;
- let what, with_what =
- List.fold_left
- (fun (acc1,acc2) i ->
- (Cic.Meta(i,[]))::acc1, (Cic.Implicit None)::acc2)
- ([],[])
- metas_still_open_in_proof
-(*
- (List.filter
- (fun (i,_,_) ->
- List.mem i metas_still_open_in_proof
- (*&& not(List.mem i metas_still_open_in_goal)*))
- proof_menv)
-*)
- in
- let goal_proof_menv =
- List.filter
- (fun (i,_,_) -> List.mem i metas_still_open_in_proof)
- proof_menv
- in
- let replace where =
- (* we need this fake equality since the metas of the hypothesis may be
- * with a real local context *)
- ProofEngineReduction.replace_lifting
- ~equality:(fun x y ->
- match x,y with Cic.Meta(i,_),Cic.Meta(j,_) -> i=j | _-> false)
- ~what ~with_what ~where
- in
- let goal_proof = replace goal_proof in
- (* ok per le meta libere... ma per quelle che c'erano e sono rimaste?
- * what mi pare buono, sostituisce solo le meta farlocche *)
- let side_effects_t = List.map replace side_effects_t in
- let free_metas =
- List.filter (fun i -> i <> goalno)
- (ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:goal_proof_menv)
- in
- (* prerr_endline
- * ("freemetas: " ^
- * String.concat "," (List.map string_of_int free_metas) ); *)
- (* check/refine/... build the new proof *)
- let replaced_goal =
- ProofEngineReduction.replace
- ~what:side_effects ~with_what:side_effects_t
- ~equality:(fun i t -> match t with Cic.Meta(j,_)->j=i|_->false)
- ~where:type_of_goal
- in
- let goal_proof,goal_ty,real_menv,_ =
- try
- CicRefine.type_of_aux' metasenv context goal_proof
- CicUniv.empty_ugraph
- with
- | CicUtil.Meta_not_found _
- | CicRefine.RefineFailure _
- | CicRefine.Uncertain _
- | CicRefine.AssertFailure _
- | Invalid_argument "list_fold_left2" as exn ->
- prerr_endline "THE PROOF DOES NOT TYPECHECK!";
- prerr_endline (CicPp.pp goal_proof names);
- prerr_endline "THE PROOF DOES NOT TYPECHECK!";
- raise exn
- in
- prerr_endline "+++++++++++++ METASENV";
- prerr_endline
- (CicMetaSubst.ppmetasenv [] real_menv);
- let subst_side_effects,real_menv,_ =
-(*
- prerr_endline ("XX type_of_goal " ^ CicPp.ppterm type_of_goal);
- prerr_endline ("XX replaced_goal " ^ CicPp.ppterm replaced_goal);
- prerr_endline ("XX metasenv " ^
- CicMetaSubst.ppmetasenv [] (metasenv @ free_metas_menv));
-*)
- try
- CicUnification.fo_unif_subst [] context real_menv
- goal_ty type_of_goal CicUniv.empty_ugraph
- with
- | CicUnification.UnificationFailure s
- | CicUnification.Uncertain s
- | CicUnification.AssertFailure s -> assert false
-(* fail "Maybe the local context of metas in the goal was not an IRL" s *)
- in
- let final_subst =
- (goalno,(context,goal_proof,type_of_goal))::subst_side_effects
- in
-(*
- let metas_of_proof = Utils.metas_of_term goal_proof in
-*)
- let proof, real_metasenv =
- ProofEngineHelpers.subst_meta_and_metasenv_in_proof
- proof goalno (CicMetaSubst.apply_subst final_subst)
- (List.filter (fun i,_,_ -> i<>goalno ) real_menv)
- in
- let open_goals =
- List.map (fun i,_,_ -> i) real_metasenv in
-
-(*
- HExtlib.list_uniq (List.sort Pervasives.compare metas_of_proof)
- in *)
-(*
- match free_meta with Some(Cic.Meta(m,_)) when m<>goalno ->[m] | _ ->[]
- in
-*)
-(*
- Printf.eprintf
- "GOALS APERTI: %s\nMETASENV PRIMA:\n%s\nMETASENV DOPO:\n%s\n"
- (String.concat ", " (List.map string_of_int open_goals))
- (CicMetaSubst.ppmetasenv [] metasenv)
- (CicMetaSubst.ppmetasenv [] real_metasenv);
-*)
- final_subst, proof, open_goals
-;;
-*)
-
-(* **************** HERE ENDS THE PARAMODULATION STUFF ******************** *)
-
-(* exported functions *)
-
-let pump_actives context bag active passive saturation_steps max_time =
- reset_refs();
-(*
- let max_l l =
- List.fold_left
- (fun acc e -> let _,_,_,menv,_ = Equality.open_equality e in
- List.fold_left (fun acc (i,_,_) -> max i acc) acc menv)
- 0 l in
-*)
-(* let active_l = fst active in *)
-(* let passive_l = fst passive in *)
-(* let ma = max_l active_l in *)
-(* let mp = max_l passive_l in *)
- match LibraryObjects.eq_URI () with
- | None -> active, passive, bag
- | Some eq_uri ->
- let env = [],context,CicUniv.empty_ugraph in
- (match
- given_clause bag eq_uri env ([],[])
- passive active 0 saturation_steps max_time
- with
- | ParamodulationFailure (_,a,p,b) ->
- a, p, b
- | ParamodulationSuccess _ ->
- assert false)
-;;
-
-let all_subsumed bag status active passive =
- let proof, goalno = status in
- let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in
- let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in
- let env = metasenv,context,CicUniv.empty_ugraph in
- let cleaned_goal = Utils.remove_local_context type_of_goal in
- let canonical_menv,other_menv =
- List.partition (fun (_,c,_) -> c = context) metasenv in
- (* prerr_endline ("other menv = " ^ (CicMetaSubst.ppmetasenv [] other_menv)); *)
- let metasenv = List.map (fun (i,_,ty)-> (i,[],ty)) canonical_menv in
- let goal = [], List.filter (fun (i,_,_)->i<>goalno) metasenv, cleaned_goal in
- debug_print (lazy (string_of_int (List.length (fst active))));
- (* we simplify using both actives passives *)
- let table =
- List.fold_left
- (fun (l,tbl) eq -> eq::l,(Indexing.index tbl eq))
- active (list_of_passive passive) in
- let (_,_,ty) = goal in
- debug_print (lazy ("prima " ^ CicPp.ppterm ty));
- let _,goal = simplify_goal bag env goal table in
- let (_,_,ty) = goal in
- debug_print (lazy ("in mezzo " ^ CicPp.ppterm ty));
- let bag, subsumed = find_all_subsumed bag env (snd table) goal in
- debug_print (lazy ("dopo " ^ CicPp.ppterm ty));
- let subsumed_or_id =
- match (check_if_goal_is_identity env goal) with
- None -> subsumed
- | Some id -> id::subsumed in
- debug_print (lazy "dopo subsumed");
- let res =
- List.map
- (fun
- (goalproof,newproof,subsumption_id,subsumption_subst, proof_menv) ->
- let subst, proof, gl =
- build_proof bag
- status goalproof newproof subsumption_id subsumption_subst proof_menv
- in
- let uri, metasenv, subst, meta_proof, term_to_prove, attrs = proof in
- let newmetasenv =
- other_menv @
- List.filter
- (fun x,_,_ -> not (List.exists (fun y,_,_ -> x=y) other_menv)) metasenv
- in
- let proof = uri, newmetasenv, subst, meta_proof, term_to_prove, attrs in
- (subst, proof,gl)) subsumed_or_id
- in
- res
-;;
-
-
-let given_clause
- bag status active passive goal_steps saturation_steps max_time
-=
- reset_refs();
- let active_l = fst active in
- let proof, goalno = status in
- let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in
- let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in
- let eq_uri = eq_of_goal type_of_goal in
- let cleaned_goal = Utils.remove_local_context type_of_goal in
- let metas_occurring_in_goal = CicUtil.metas_of_term cleaned_goal in
- let canonical_menv,other_menv =
- List.partition (fun (_,c,_) -> c = context) metasenv in
- Utils.set_goal_symbols cleaned_goal; (* DISACTIVATED *)
- let canonical_menv =
- List.map
- (fun (i,_,ty)-> (i,[],Utils.remove_local_context ty)) canonical_menv
- in
- let metasenv' =
- List.filter
- (fun (i,_,_)-> i<>goalno && List.mem_assoc i metas_occurring_in_goal)
- canonical_menv
- in
- let goal = [], metasenv', cleaned_goal in
- let env = metasenv,context,CicUniv.empty_ugraph in
- debug_print (lazy ">>>>>> ACTIVES >>>>>>>>");
- List.iter (fun e -> debug_print (lazy (Equality.string_of_equality ~env e)))
- active_l;
- debug_print (lazy ">>>>>>>>>>>>>>");
- let goals = make_goal_set goal in
- match
- given_clause bag eq_uri env goals passive active
- goal_steps saturation_steps max_time
- with
- | ParamodulationFailure (msg,a,p,b) ->
- if Utils.debug then prerr_endline msg;
- None, a, p, b
- | ParamodulationSuccess
- ((goalproof,newproof,subsumption_id,subsumption_subst, proof_menv),a,p,b) ->
- let subst, proof, gl =
- build_proof b
- status goalproof newproof subsumption_id subsumption_subst proof_menv
- in
- let uri, metasenv, subst, meta_proof, term_to_prove, attrs = proof in
- let proof = uri, other_menv@metasenv, subst, meta_proof, term_to_prove, attrs in
- Some (subst, proof,gl),a,p, b
-;;
-
-let solve_narrowing bag status active passive goal_steps =
- let proof, goalno = status in
- let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in
- let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in
- let cleaned_goal = Utils.remove_local_context type_of_goal in
- let metas_occurring_in_goal = CicUtil.metas_of_term cleaned_goal in
- let canonical_menv,other_menv =
- List.partition (fun (_,c,_) -> c = context) metasenv in
- let canonical_menv =
- List.map
- (fun (i,_,ty)-> (i,[],Utils.remove_local_context ty)) canonical_menv
- in
- let metasenv' =
- List.filter
- (fun (i,_,_)-> i<>goalno && List.mem_assoc i metas_occurring_in_goal)
- canonical_menv
- in
- let goal = [], metasenv', cleaned_goal in
- let env = metasenv,context,CicUniv.empty_ugraph in
- let goals =
- let table = List.fold_left Indexing.index (last passive) (fst active) in
- goal :: Indexing.demodulation_all_goal bag env table goal 4
- in
- let rec aux newactives newpassives bag = function
- | [] -> bag, (newactives, newpassives)
- | hd::tl ->
- let selected = hd in
- let (_,m1,t1) = selected in
- let already_in =
- List.exists (fun (_,_,t) -> Equality.meta_convertibility t t1)
- newactives
- in
- if already_in then
- aux newactives newpassives bag tl
- else
- let bag, newpassives =
- if Utils.metas_of_term t1 = [] then
- bag, newpassives
- else
- let bag, new' =
- Indexing.superposition_left bag env (snd active) selected
- in
- let new' =
- List.map
- (fun x -> let b, x = simplify_goal bag env x active in x)
- new'
- in
- bag, newpassives @ new'
- in
- aux (selected::newactives) newpassives bag tl
- in
- let rec do_n bag ag pg = function
- | 0 -> None, active, passive, bag
- | n ->
- let bag, (ag, pg) = aux [] [] bag (ag @ pg) in
- match check_if_goals_set_is_solved bag env active passive (ag,pg) with
- | bag, None -> do_n bag ag pg (n-1)
- | bag, Some (gproof,newproof,subsumption_id,subsumption_subst,pmenv)->
- let subst, proof, gl =
- build_proof bag
- status gproof newproof subsumption_id subsumption_subst pmenv
- in
- let uri,metasenv,subst,meta_proof,term_to_prove,attrs = proof in
- let proof =
- uri, other_menv@metasenv, subst, meta_proof, term_to_prove, attrs
- in
- Some (subst, proof,gl),active,passive, bag
- in
- do_n bag [] goals goal_steps
-;;
-
-
-let add_to_passive eql passives =
- add_to_passive passives eql eql
-;;
-
-
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-type passive_table
-type active_table = Equality.equality list * Indexing.Index.t
-
-val reset_refs : unit -> unit
-
-val make_active: Equality.equality list -> active_table
-val make_passive: Equality.equality list -> passive_table
-val add_to_passive: Equality.equality list -> passive_table -> passive_table
-val add_to_active:
- Equality.equality_bag ->
- active_table -> passive_table ->
- Utils.environment -> Cic.term (* ty *) -> Cic.term -> Cic.metasenv ->
- active_table * passive_table * Equality.equality_bag
-val list_of_passive: passive_table -> Equality.equality list
-val list_of_active: active_table -> Equality.equality list
-
-val simplify_equalities :
- Equality.equality_bag ->
- UriManager.uri ->
- Utils.environment ->
- Equality.equality list ->
- Equality.equality_bag * Equality.equality list
-val pump_actives :
- Cic.context ->
- Equality.equality_bag ->
- active_table ->
- passive_table ->
- int ->
- float ->
- active_table * passive_table * Equality.equality_bag
-val all_subsumed :
- Equality.equality_bag ->
- ProofEngineTypes.status ->
- active_table ->
- passive_table ->
- (Cic.substitution *
- ProofEngineTypes.proof *
- ProofEngineTypes.goal list) list
-val given_clause:
- Equality.equality_bag ->
- ProofEngineTypes.status ->
- active_table ->
- passive_table ->
- int -> int -> float ->
- (Cic.substitution *
- ProofEngineTypes.proof *
- ProofEngineTypes.goal list) option *
- active_table * passive_table * Equality.equality_bag
-
-val solve_narrowing:
- Equality.equality_bag ->
- ProofEngineTypes.status ->
- active_table ->
- passive_table ->
- int ->
- (Cic.substitution *
- ProofEngineTypes.proof *
- ProofEngineTypes.goal list) option *
- active_table * passive_table * Equality.equality_bag
+++ /dev/null
-(* cOpyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id: inference.ml 6245 2006-04-05 12:07:51Z tassi $ *)
-
-
-(******* CIC substitution ***************************************************)
-
-type cic_substitution = Cic.substitution
-let cic_apply_subst = CicMetaSubst.apply_subst
-let cic_apply_subst_metasenv = CicMetaSubst.apply_subst_metasenv
-let cic_ppsubst = CicMetaSubst.ppsubst
-let cic_buildsubst n context t ty tail = (n,(context,t,ty)) :: tail
-let cic_flatten_subst subst =
- List.map
- (fun (i, (context, term, ty)) ->
- let context = (* cic_apply_subst_context subst*) context in
- let term = cic_apply_subst subst term in
- let ty = cic_apply_subst subst ty in
- (i, (context, term, ty))) subst
-let rec cic_lookup_subst meta subst =
- match meta with
- | Cic.Meta (i, _) -> (
- try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst
- in cic_lookup_subst t subst
- with Not_found -> meta
- )
- | _ -> meta
-;;
-
-let cic_merge_subst_if_possible s1 s2 =
- let already_in = Hashtbl.create 13 in
- let rec aux acc = function
- | ((i,_,x) as s)::tl ->
- (try
- let x' = Hashtbl.find already_in i in
- if x = x' then aux acc tl else None
- with
- | Not_found ->
- Hashtbl.add already_in i x;
- aux (s::acc) tl)
- | [] -> Some acc
- in
- aux [] (s1@s2)
-;;
-
-(******** NAIF substitution **************************************************)
-(*
- * naif version of apply subst; the local context of metas is ignored;
- * we assume the substituted term must be lifted according to the nesting
- * depth of the meta.
- * Alternatively, we could used implicit instead of metas
- *)
-
-type naif_substitution = (int * Cic.term) list
-
-let naif_apply_subst lift subst term =
- let rec aux k t =
- match t with
- Cic.Rel _ -> t
- | Cic.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst
- in
- Cic.Var (uri, exp_named_subst')
- | Cic.Meta (i, l) ->
- (try
- aux k (CicSubstitution.lift (k+lift) (List.assoc i subst))
- with Not_found -> t)
- | Cic.Sort _
- | Cic.Implicit _ -> t
- | Cic.Cast (te,ty) -> Cic.Cast (aux k te, aux k ty)
- | Cic.Prod (n,s,t) -> Cic.Prod (n, aux k s, aux (k+1) t)
- | Cic.Lambda (n,s,t) -> Cic.Lambda (n, aux k s, aux (k+1) t)
- | Cic.LetIn (n,s,ty,t) -> Cic.LetIn (n, aux k s, aux k ty, aux (k+1) t)
- | Cic.Appl [] -> assert false
- | Cic.Appl l -> Cic.Appl (List.map (aux k) l)
- | Cic.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst
- in
- if exp_named_subst' != exp_named_subst then
- Cic.Const (uri, exp_named_subst')
- else
- t (* TODO: provare a mantenere il piu' possibile sharing *)
- | Cic.MutInd (uri,typeno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst
- in
- Cic.MutInd (uri,typeno,exp_named_subst')
- | Cic.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst
- in
- Cic.MutConstruct (uri,typeno,consno,exp_named_subst')
- | Cic.MutCase (sp,i,outty,t,pl) ->
- let pl' = List.map (aux k) pl in
- Cic.MutCase (sp, i, aux k outty, aux k t, pl')
- | Cic.Fix (i, fl) ->
- let len = List.length fl in
- let fl' =
- List.map
- (fun (name, i, ty, bo) -> (name, i, aux k ty, aux (k+len) bo)) fl
- in
- Cic.Fix (i, fl')
- | Cic.CoFix (i, fl) ->
- let len = List.length fl in
- let fl' =
- List.map (fun (name, ty, bo) -> (name, aux k ty, aux (k+len) bo)) fl
- in
- Cic.CoFix (i, fl')
-in
- aux 0 term
-;;
-
-(* naif version of apply_subst_metasenv: we do not apply the
-substitution to the context *)
-
-let naif_apply_subst_metasenv subst metasenv =
- List.map
- (fun (n, context, ty) ->
- (n, context, naif_apply_subst 0 subst ty))
- (List.filter
- (fun (i, _, _) -> not (List.mem_assoc i subst))
- metasenv)
-
-let naif_ppsubst names subst =
- "{" ^ String.concat "; "
- (List.map
- (fun (idx, t) ->
- Printf.sprintf "%d:= %s" idx (CicPp.pp t names))
- subst) ^ "}"
-;;
-
-let naif_buildsubst n context t ty tail = (n,t) :: tail ;;
-
-let naif_flatten_subst subst =
- List.map (fun (i,t) -> i, naif_apply_subst 0 subst t ) subst
-;;
-
-let rec naif_lookup_subst meta subst =
- match meta with
- | Cic.Meta (i, _) ->
- (try
- naif_lookup_subst (List.assoc i subst) subst
- with
- Not_found -> meta)
- | _ -> meta
-;;
-
-let naif_merge_subst_if_possible s1 s2 =
- let already_in = Hashtbl.create 13 in
- let rec aux acc = function
- | ((i,x) as s)::tl ->
- (try
- let x' = Hashtbl.find already_in i in
- if x = x' then aux acc tl else None
- with
- | Not_found ->
- Hashtbl.add already_in i x;
- aux (s::acc) tl)
- | [] -> Some acc
- in
- aux [] (s1@s2)
-;;
-
-(********** ACTUAL SUBSTITUTION IMPLEMENTATION *******************************)
-
-type substitution = naif_substitution
-let apply_subst = naif_apply_subst 0
-let apply_subst_lift = naif_apply_subst
-let apply_subst_metasenv = naif_apply_subst_metasenv
-let ppsubst ?(names=[]) l = naif_ppsubst names l
-let buildsubst = naif_buildsubst
-let flatten_subst = naif_flatten_subst
-let lookup_subst = naif_lookup_subst
-
-(* filter out from metasenv the variables in substs *)
-let filter subst metasenv =
- List.filter
- (fun (m, _, _) ->
- try let _ = List.find (fun (i, _) -> m = i) subst in false
- with Not_found -> true)
- metasenv
-;;
-
-let is_in_subst i subst = List.mem_assoc i subst;;
-
-let merge_subst_if_possible = naif_merge_subst_if_possible;;
-
-let empty_subst = [];;
-
-let concat x y = x @ y;;
-
-
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-type substitution
-
-val empty_subst : substitution
-val apply_subst : substitution -> Cic.term -> Cic.term
-val apply_subst_lift : int -> substitution -> Cic.term -> Cic.term
-val apply_subst_metasenv : substitution -> Cic.metasenv -> Cic.metasenv
-val ppsubst : ?names:(Cic.name option list) -> substitution -> string
-val buildsubst :
- int -> Cic.context -> Cic.term -> Cic.term -> substitution ->
- substitution
-val flatten_subst : substitution -> substitution
-val lookup_subst : Cic.term -> substitution -> Cic.term
-val filter : substitution -> Cic.metasenv -> Cic.metasenv
-val is_in_subst : int -> substitution -> bool
-val merge_subst_if_possible:
- substitution -> substitution ->
- substitution option
-val concat: substitution -> substitution -> substitution
+++ /dev/null
-(* $Id$ *)
-
-open Path_indexing
-
-(*
-let build_equality term =
- let module C = Cic in
- C.Implicit None, (C.Implicit None, term, C.Rel 1, Utils.Gt), [], []
-;;
-
-
-(*
- f = Rel 1
- g = Rel 2
- a = Rel 3
- b = Rel 4
- c = Rel 5
-*)
-let path_indexing_test () =
- let module C = Cic in
- let terms = [
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5];
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])];
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5];
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4];
- C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]
- ] in
- let path_strings = List.map (path_strings_of_term 0) terms in
- let table =
- List.fold_left index PSTrie.empty (List.map build_equality terms) in
- let query =
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in
- let matches = retrieve_generalizations table query in
- let unifications = retrieve_unifiables table query in
- let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])])
- and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in
- let res1 = in_index table eq1
- and res2 = in_index table eq2 in
- let print_results res =
- String.concat "\n"
- (PosEqSet.fold
- (fun (p, e) l ->
- let s =
- "(" ^ (Utils.string_of_pos p) ^ ", " ^
- (Inference.string_of_equality e) ^ ")"
- in
- s::l)
- res [])
- in
- Printf.printf "path_strings:\n%s\n\n"
- (String.concat "\n"
- (List.map
- (fun l ->
- "{" ^ (String.concat "; " (List.map string_of_path_string l)) ^ "}"
- ) path_strings));
- Printf.printf "table:\n%s\n\n" (string_of_pstrie table);
- Printf.printf "matches:\n%s\n\n" (print_results matches);
- Printf.printf "unifications:\n%s\n\n" (print_results unifications);
- Printf.printf "in_index %s: %s\n"
- (Inference.string_of_equality eq1) (string_of_bool res1);
- Printf.printf "in_index %s: %s\n"
- (Inference.string_of_equality eq2) (string_of_bool res2);
-;;
-
-
-let differing () =
- let module C = Cic in
- let t1 =
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]
- and t2 =
- C.Appl [C.Rel 1; C.Appl [C.Rel 5; C.Rel 4; C.Meta (1, [])]; C.Rel 5]
- in
- let res = Inference.extract_differing_subterms t1 t2 in
- match res with
- | None -> prerr_endline "NO DIFFERING SUBTERMS???"
- | Some (t1, t2) ->
- Printf.printf "OK: %s, %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2);
-;;
-
-
-let next_after () =
- let module C = Cic in
- let t =
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]
- in
- let pos1 = Discrimination_tree.next_t [1] t in
- let pos2 = Discrimination_tree.after_t [1] t in
- Printf.printf "next_t 1: %s\nafter_t 1: %s\n"
- (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos1 t))
- (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos2 t));
-;;
-
-
-let discrimination_tree_test () =
- let module C = Cic in
- let terms = [
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5];
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])];
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5];
- C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4];
- C.Appl [C.Rel 10; C.Meta (5, []); C.Rel 11]
- ] in
- let path_strings =
- List.map Discrimination_tree.path_string_of_term terms in
- let table =
- List.fold_left
- Discrimination_tree.index
- Discrimination_tree.DiscriminationTree.empty
- (List.map build_equality terms)
- in
-(* let query = *)
-(* C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in *)
- let query = C.Appl [C.Rel 10; C.Meta (14, []); C.Meta (13, [])] in
- let matches = Discrimination_tree.retrieve_generalizations table query in
- let unifications = Discrimination_tree.retrieve_unifiables table query in
- let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])])
- and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in
- let res1 = Discrimination_tree.in_index table eq1
- and res2 = Discrimination_tree.in_index table eq2 in
- let print_results res =
- String.concat "\n"
- (Discrimination_tree.PosEqSet.fold
- (fun (p, e) l ->
- let s =
- "(" ^ (Utils.string_of_pos p) ^ ", " ^
- (Inference.string_of_equality e) ^ ")"
- in
- s::l)
- res [])
- in
- Printf.printf "path_strings:\n%s\n\n"
- (String.concat "\n"
- (List.map Discrimination_tree.string_of_path_string path_strings));
- Printf.printf "table:\n%s\n\n"
- (Discrimination_tree.string_of_discrimination_tree table);
- Printf.printf "matches:\n%s\n\n" (print_results matches);
- Printf.printf "unifications:\n%s\n\n" (print_results unifications);
- Printf.printf "in_index %s: %s\n"
- (Inference.string_of_equality eq1) (string_of_bool res1);
- Printf.printf "in_index %s: %s\n"
- (Inference.string_of_equality eq2) (string_of_bool res2);
-;;
-
-
-let test_subst () =
- let module C = Cic in
- let module M = CicMetaSubst in
- let term = C.Appl [
- C.Rel 1;
- C.Appl [C.Rel 11;
- C.Meta (43, []);
- C.Appl [C.Rel 15; C.Rel 12; C.Meta (41, [])]];
- C.Appl [C.Rel 11;
- C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])];
- C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (12, [])]]
- ] in
- let subst1 = [
- (43, ([], C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])], C.Rel 16));
- (10, ([], C.Rel 12, C.Rel 16));
- (12, ([], C.Meta (41, []), C.Rel 16))
- ]
- and subst2 = [
- (43, ([], C.Appl [C.Rel 15; C.Rel 12; C.Meta (11, [])], C.Rel 16));
- (10, ([], C.Rel 12, C.Rel 16));
- (12, ([], C.Meta (41, []), C.Rel 16))
- ] in
- let t1 = M.apply_subst subst1 term
- and t2 = M.apply_subst subst2 term in
- Printf.printf "t1 = %s\nt2 = %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2);
-;;
-*)
-
-
-let test_refl () =
- let module C = Cic in
- let context = [
- Some (C.Name "H", C.Decl (
- C.Prod (C.Name "z", C.Rel 3,
- C.Appl [
- C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []);
- C.Rel 4; C.Rel 3; C.Rel 1])));
- Some (C.Name "x", C.Decl (C.Rel 2));
- Some (C.Name "y", C.Decl (C.Rel 1));
- Some (C.Name "A", C.Decl (C.Sort C.Set))
- ]
- in
- let term = C.Appl [
- C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); C.Rel 4;
- C.Rel 2;
- C.Lambda (C.Name "z", C.Rel 4,
- C.Appl [
- C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []);
- C.Rel 5; C.Rel 1; C.Rel 3
- ]);
- C.Appl [C.MutConstruct
- (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); (* reflexivity *)
- C.Rel 4; C.Rel 2];
- C.Rel 3;
-(* C.Appl [C.Const (HelmLibraryObjects.Logic.sym_eq_URI, []); (\* symmetry *\) *)
-(* C.Rel 4; C.Appl [C.Rel 1; C.Rel 2]] *)
- C.Appl [
- C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []);
- C.Rel 4; C.Rel 3;
- C.Lambda (C.Name "z", C.Rel 4,
- C.Appl [
- C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []);
- C.Rel 5; C.Rel 1; C.Rel 4
- ]);
- C.Appl [C.MutConstruct (HelmLibraryObjects.Logic.eq_URI, 0, 1, []);
- C.Rel 4; C.Rel 3];
- C.Rel 2; C.Appl [C.Rel 1; C.Rel 2]
- ]
- ] in
- let ens = [
- (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var",
- C.Rel 4);
- (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var",
- C.Rel 3);
- (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var",
- C.Rel 2);
- ] in
- let term2 = C.Appl [
- C.Const (HelmLibraryObjects.Logic.sym_eq_URI, ens);
- C.Appl [C.Rel 1; C.Rel 2]
- ] in
- let ty, ug =
- CicTypeChecker.type_of_aux' [] context term CicUniv.empty_ugraph
- in
- Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term) (CicPp.ppterm ty);
- let ty, ug =
- CicTypeChecker.type_of_aux' [] context term2 CicUniv.empty_ugraph
- in
- Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term2) (CicPp.ppterm ty);
-;;
-
-
-let test_lib () =
- let uri = Sys.argv.(1) in
- let t = CicUtil.term_of_uri (UriManager.uri_of_string uri) in
- let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
- Printf.printf "Term of %s: %s\n" uri (CicPp.ppterm t);
- Printf.printf "type: %s\n" (CicPp.ppterm ty);
-;;
-
-
-(* differing ();; *)
-(* next_after ();; *)
-(* discrimination_tree_test ();; *)
-(* path_indexing_test ();; *)
-(* test_subst ();; *)
-Helm_registry.load_from "../../matita/matita.conf.xml";
-(* test_refl ();; *)
-test_lib ();;
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let time = false;;
-let debug = false;;
-let debug_metas = false;;
-let debug_res = false;;
-
-let debug_print s = if debug then prerr_endline (Lazy.force s);;
-
-let print_metasenv metasenv =
- String.concat "\n--------------------------\n"
- (List.map (fun (i, context, term) ->
- (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^
- "\n] " ^ (CicPp.ppterm term))
- metasenv)
-;;
-
-
-let print_subst ?(prefix="\n") subst =
- String.concat prefix
- (List.map
- (fun (i, (c, t, ty)) ->
- Printf.sprintf "?%d -> %s : %s" i
- (CicPp.ppterm t) (CicPp.ppterm ty))
- subst)
-;;
-
-type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;;
-
-let string_of_comparison = function
- | Lt -> "<"
- | Le -> "<="
- | Gt -> ">"
- | Ge -> ">="
- | Eq -> "="
- | Incomparable -> "I"
-
-type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph
-
-module OrderedTerm =
-struct
- type t = Cic.term
-
- let compare = Pervasives.compare
-end
-
-module TermSet = Set.Make(OrderedTerm);;
-module TermMap = Map.Make(OrderedTerm);;
-
-let symbols_of_term term =
- let module C = Cic in
- let rec aux map = function
- | C.Meta _ -> map
- | C.Appl l ->
- List.fold_left (fun res t -> (aux res t)) map l
- | t ->
- let map =
- try
- let c = TermMap.find t map in
- TermMap.add t (c+1) map
- with Not_found ->
- TermMap.add t 1 map
- in
- map
- in
- aux TermMap.empty term
-;;
-
-
-let metas_of_term term =
- let module C = Cic in
- let rec aux = function
- | C.Meta _ as t -> TermSet.singleton t
- | C.Appl l ->
- List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l
- | C.Lambda(n,s,t) ->
- TermSet.union (aux s) (aux t)
- | C.Prod(n,s,t) ->
- TermSet.union (aux s) (aux t)
- | C.LetIn(n,s,ty,t) ->
- TermSet.union (aux s) (TermSet.union (aux ty) (aux t))
- | t -> TermSet.empty (* TODO: maybe add other cases? *)
- in
- aux term
-;;
-
-let rec remove_local_context =
- function
- | Cic.Meta (i,_) -> Cic.Meta (i,[])
- | Cic.Appl l ->
- Cic.Appl(List.map remove_local_context l)
- | Cic.Prod (n,s,t) ->
- Cic.Prod (n,remove_local_context s, remove_local_context t)
- | t -> t
-
-
-(************************* rpo ********************************)
-let number = [
- UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)",3;
- UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)",6;
- UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)",9;
- HelmLibraryObjects.Peano.pred_URI, 12;
- HelmLibraryObjects.Peano.plus_URI, 15;
- HelmLibraryObjects.Peano.minus_URI, 18;
- HelmLibraryObjects.Peano.mult_URI, 21;
- UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1)",103;
- UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/1)",106;
- UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/2)",109;
- UriManager.uri_of_string "cic:/matita/nat/nat/pred.con",112;
- UriManager.uri_of_string "cic:/matita/nat/plus/plus.con",115;
- UriManager.uri_of_string "cic:/matita/nat/minus/minus.con",118;
- UriManager.uri_of_string "cic:/matita/nat/times/times.con",121;
- ]
-;;
-
-let atomic t =
- match t with
- Cic.Const _
- | Cic.MutInd _
- | Cic.MutConstruct _
- | Cic.Rel _ -> true
- | _ -> false
-
-let sig_order_const t1 t2 =
- try
- let u1 = CicUtil.uri_of_term t1 in
- let u2 = CicUtil.uri_of_term t2 in
- let n1 = List.assoc u1 number in
- let n2 = List.assoc u2 number in
- if n1 < n2 then Lt
- else if n1 > n2 then Gt
- else
- begin
- prerr_endline ("t1 = "^(CicPp.ppterm t1));
- prerr_endline ("t2 = "^(CicPp.ppterm t2));
- assert false
- end
- with
- Invalid_argument _
- | Not_found -> Incomparable
-
-let sig_order t1 t2 =
- match t1, t2 with
- Cic.Rel n, Cic.Rel m when n < m -> Gt (* inverted order *)
- | Cic.Rel n, Cic.Rel m when n = m -> Incomparable
- | Cic.Rel n, Cic.Rel m when n > m -> Lt
- | Cic.Rel _, _ -> Gt
- | _, Cic.Rel _ -> Lt
- | _,_ -> sig_order_const t1 t2
-
-let rec rpo_lt t1 t2 =
- let module C = Cic in
- let first_trie =
- match t1,t2 with
- C.Meta (_, _), C.Meta (_,_) -> false
- | C.Meta (_,_) , t2 -> TermSet.mem t1 (metas_of_term t2)
- | t1, C.Meta (_,_) -> false
- | C.Appl [h1;a1],C.Appl [h2;a2] when h1=h2 ->
- rpo_lt a1 a2
- | C.Appl (h1::arg1),C.Appl (h2::arg2) when h1=h2 ->
- if lex_lt arg1 arg2 then
- check_lt arg1 t2
- else false
- | C.Appl (h1::arg1),C.Appl (h2::arg2) ->
- (match sig_order h1 h2 with
- | Lt -> check_lt arg1 t2
- | _ -> false)
- | C.Appl (h1::arg1), t2 when atomic t2 ->
- (match sig_order h1 t2 with
- | Lt -> check_lt arg1 t2
- | _ -> false)
- | t1 , C.Appl (h2::arg2) when atomic t1 ->
- (match sig_order t1 h2 with
- | Lt -> true
- | _ -> false )
- | C.Appl [] , _ -> assert false
- | _ , C.Appl [] -> assert false
- | t1, t2 when (atomic t1 && atomic t2 && t1<>t2) ->
- (match sig_order t1 t2 with
- | Lt -> true
- | _ -> false)
- | _,_ -> false
- in
- if first_trie then true else
- match t2 with
- C.Appl (_::args) ->
- List.exists (fun a -> t1 = a || rpo_lt t1 a) args
- | _ -> false
-
-and lex_lt l1 l2 =
- match l1,l2 with
- [],[] -> false
- | [],_ -> assert false
- | _, [] -> assert false
- | a1::l1, a2::l2 when a1 = a2 -> lex_lt l1 l2
- | a1::_, a2::_ -> rpo_lt a1 a2
-
-and check_lt l t =
- List.fold_left
- (fun b a -> b && (rpo_lt a t))
- true l
-;;
-
-let rpo t1 t2 =
- if rpo_lt t2 t1 then Gt
- else if rpo_lt t1 t2 then Lt
- else Incomparable
-
-
-(*********************** fine rpo *****************************)
-
-(* (weight of constants, [(meta, weight_of_meta)]) *)
-type weight = int * (int * int) list;;
-
-let string_of_weight (cw, mw) =
- let s =
- String.concat ", "
- (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw)
- in
- Printf.sprintf "[%d; %s]" cw s
-
-
-let weight_of_term ?(consider_metas=true) ?(count_metas_occurrences=false) term =
- let module C = Cic in
- let vars_dict = Hashtbl.create 5 in
- let rec aux = function
- | C.Meta (metano, _) when consider_metas ->
- (try
- let oldw = Hashtbl.find vars_dict metano in
- Hashtbl.replace vars_dict metano (oldw+1)
- with Not_found ->
- Hashtbl.add vars_dict metano 1);
- if count_metas_occurrences then 1 else 0
- | C.Meta _ -> (* "variables" are lighter than constants and functions...*)
- if count_metas_occurrences then 1 else 0
- | C.Var (_, ens)
- | C.Const (_, ens)
- | C.MutInd (_, _, ens)
- | C.MutConstruct (_, _, _, ens) ->
- List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens
-
- | C.Cast (t1, t2)
- | C.Lambda (_, t1, t2)
- | C.Prod (_, t1, t2)
- | C.LetIn (_, t1, _, t2) ->
- let w1 = aux t1 in
- let w2 = aux t2 in
- w1 + w2 + 1
-
- | C.Appl l -> List.fold_left (+) 0 (List.map aux l)
-
- | C.MutCase (_, _, outt, t, pl) ->
- let w1 = aux outt in
- let w2 = aux t in
- let w3 = List.fold_left (+) 0 (List.map aux pl) in
- w1 + w2 + w3 + 1
-
- | C.Fix (_, fl) ->
- List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl
-
- | C.CoFix (_, fl) ->
- List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl
-
- | _ -> 1
- in
- let w = aux term in
- let l =
- Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in
- let compare w1 w2 =
- match w1, w2 with
- | (m1, _), (m2, _) -> m2 - m1
- in
- (w, List.sort compare l) (* from the biggest meta to the smallest (0) *)
-;;
-
-
-module OrderedInt = struct
- type t = int
-
- let compare = Pervasives.compare
-end
-
-module IntSet = Set.Make(OrderedInt)
-
-let goal_symbols = ref TermSet.empty
-
-let set_of_map m =
- TermMap.fold (fun k _ s -> TermSet.add k s) m TermSet.empty
-;;
-
-let set_goal_symbols term =
- let m = symbols_of_term term in
- goal_symbols := (set_of_map m)
-;;
-
-let symbols_of_eq (ty,left,right,_) =
- let sty = set_of_map (symbols_of_term ty) in
- let sl = set_of_map (symbols_of_term left) in
- let sr = set_of_map (symbols_of_term right) in
- TermSet.union sty (TermSet.union sl sr)
-;;
-
-let distance sgoal seq =
- let s = TermSet.diff seq sgoal in
- TermSet.cardinal s
-;;
-
-let compute_equality_weight (ty,left,right,o) =
- let factor = 2 in
- match o with
- | Lt ->
- let w, m = (weight_of_term
- ~consider_metas:true ~count_metas_occurrences:false right) in
- w + (factor * (List.length m)) ;
- | Le -> assert false
- | Gt ->
- let w, m = (weight_of_term
- ~consider_metas:true ~count_metas_occurrences:false left) in
- w + (factor * (List.length m)) ;
- | Ge -> assert false
- | Eq
- | Incomparable ->
- let w1, m1 = (weight_of_term
- ~consider_metas:true ~count_metas_occurrences:false right) in
- let w2, m2 = (weight_of_term
- ~consider_metas:true ~count_metas_occurrences:false left) in
- w1 + w2 + (factor * (List.length m1)) + (factor * (List.length m2))
-;;
-
-let compute_equality_weight e =
- let w = compute_equality_weight e in
- let d = 0 in (* distance !goal_symbols (symbols_of_eq e) in *)
-(*
- prerr_endline (Printf.sprintf "dist %s --- %s === %d"
- (String.concat ", " (List.map (CicPp.ppterm) (TermSet.elements
- !goal_symbols)))
- (String.concat ", " (List.map (CicPp.ppterm) (TermSet.elements
- (symbols_of_eq e))))
- d
- );
-*)
- w + d
-;;
-
-(* old
-let compute_equality_weight (ty,left,right,o) =
- let metasw = ref 0 in
- let weight_of t =
- let w, m = (weight_of_term
- ~consider_metas:true ~count_metas_occurrences:false t) in
- metasw := !metasw + (1 * (List.length m)) ;
- w
- in
- (* Warning: the following let cannot be expanded since it forces the
- right evaluation order!!!! *)
- let w = (weight_of ty) + (weight_of left) + (weight_of right) in
- (* let w = weight_of (Cic.Appl [ty;left;right]) in *)
- w + !metasw
-;;
-*)
-
-(* returns a "normalized" version of the polynomial weight wl (with type
- * weight list), i.e. a list sorted ascending by meta number,
- * from 0 to maxmeta. wl must be sorted descending by meta number. Example:
- * normalize_weight 5 (3, [(3, 2); (1, 1)]) ->
- * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *)
-let normalize_weight maxmeta (cw, wl) =
- let rec aux = function
- | 0 -> []
- | m -> (m, 0)::(aux (m-1))
- in
- let tmpl = aux maxmeta in
- let wl =
- List.sort
- (fun (m, _) (n, _) -> Pervasives.compare m n)
- (List.fold_left
- (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl)
- in
- (cw, wl)
-;;
-
-
-let normalize_weights (cw1, wl1) (cw2, wl2) =
- let rec aux wl1 wl2 =
- match wl1, wl2 with
- | [], [] -> [], []
- | (m, w)::tl1, (n, w')::tl2 when m = n ->
- let res1, res2 = aux tl1 tl2 in
- (m, w)::res1, (n, w')::res2
- | (m, w)::tl1, ((n, w')::_ as wl2) when m < n ->
- let res1, res2 = aux tl1 wl2 in
- (m, w)::res1, (m, 0)::res2
- | ((m, w)::_ as wl1), (n, w')::tl2 when m > n ->
- let res1, res2 = aux wl1 tl2 in
- (n, 0)::res1, (n, w')::res2
- | [], (n, w)::tl2 ->
- let res1, res2 = aux [] tl2 in
- (n, 0)::res1, (n, w)::res2
- | (m, w)::tl1, [] ->
- let res1, res2 = aux tl1 [] in
- (m, w)::res1, (m, 0)::res2
- | _, _ -> assert false
- in
- let cmp (m, _) (n, _) = compare m n in
- let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in
- (cw1, wl1), (cw2, wl2)
-;;
-
-
-let compare_weights ?(normalize=false)
- ((h1, w1) as weight1) ((h2, w2) as weight2)=
- let (h1, w1), (h2, w2) =
- if normalize then
- normalize_weights weight1 weight2
- else
- (h1, w1), (h2, w2)
- in
- let res, diffs =
- try
- List.fold_left2
- (fun ((lt, eq, gt), diffs) w1 w2 ->
- match w1, w2 with
- | (meta1, w1), (meta2, w2) when meta1 = meta2 ->
- let diffs = (w1 - w2) + diffs in
- let r = compare w1 w2 in
- if r < 0 then (lt+1, eq, gt), diffs
- else if r = 0 then (lt, eq+1, gt), diffs
- else (lt, eq, gt+1), diffs
- | (meta1, w1), (meta2, w2) ->
- debug_print
- (lazy
- (Printf.sprintf "HMMM!!!! %s, %s\n"
- (string_of_weight weight1) (string_of_weight weight2)));
- assert false)
- ((0, 0, 0), 0) w1 w2
- with Invalid_argument _ ->
- debug_print
- (lazy
- (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n"
- (string_of_weight (h1, w1)) (string_of_weight weight1)
- (string_of_weight (h2, w2)) (string_of_weight weight2)
- (string_of_bool normalize)));
- assert false
- in
- let hdiff = h1 - h2 in
- match res with
- | (0, _, 0) ->
- if hdiff < 0 then Lt
- else if hdiff > 0 then Gt
- else Eq (* Incomparable *)
- | (m, _, 0) ->
- if hdiff <= 0 then Lt
- else if (- diffs) >= hdiff then Le else Incomparable
- | (0, _, m) ->
- if hdiff >= 0 then Gt
- else if diffs >= (- hdiff) then Ge else Incomparable
- | (m, _, n) when m > 0 && n > 0 ->
- Incomparable
- | _ -> assert false
-;;
-
-
-let rec aux_ordering ?(recursion=true) t1 t2 =
- let module C = Cic in
- let compare_uris u1 u2 =
- let res =
- compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in
- if res < 0 then Lt
- else if res = 0 then Eq
- else Gt
- in
- match t1, t2 with
- | C.Meta _, _
- | _, C.Meta _ -> Incomparable
-
- | t1, t2 when t1 = t2 -> Eq
-
- | C.Rel n, C.Rel m -> if n > m then Lt else Gt
- | C.Rel _, _ -> Lt
- | _, C.Rel _ -> Gt
-
- | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2
- | C.Const _, _ -> Lt
- | _, C.Const _ -> Gt
-
- | C.MutInd (u1, tno1, _), C.MutInd (u2, tno2, _) ->
- let res = compare_uris u1 u2 in
- if res <> Eq then res
- else
- let res = compare tno1 tno2 in
- if res = 0 then Eq else if res < 0 then Lt else Gt
- | C.MutInd _, _ -> Lt
- | _, C.MutInd _ -> Gt
-
- | C.MutConstruct (u1, tno1, cno1, _), C.MutConstruct (u2, tno2, cno2, _) ->
- let res = compare_uris u1 u2 in
- if res <> Eq then res
- else
- let res = compare (tno1,cno1) (tno2,cno2) in
- if res = 0 then Eq else if res < 0 then Lt else Gt
- | C.MutConstruct _, _ -> Lt
- | _, C.MutConstruct _ -> Gt
-
- | C.Appl l1, C.Appl l2 when recursion ->
- let rec cmp t1 t2 =
- match t1, t2 with
- | [], [] -> Eq
- | _, [] -> Gt
- | [], _ -> Lt
- | hd1::tl1, hd2::tl2 ->
- let o = aux_ordering hd1 hd2 in
- if o = Eq then cmp tl1 tl2
- else o
- in
- cmp l1 l2
- | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion ->
- aux_ordering h1 h2
-
- | t1, t2 ->
- debug_print
- (lazy
- (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n"
- (CicPp.ppterm t1) (CicPp.ppterm t2)));
- Incomparable
-;;
-
-
-(* w1, w2 are the weights, they should already be normalized... *)
-let nonrec_kbo_w (t1, w1) (t2, w2) =
- match compare_weights w1 w2 with
- | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable
- | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable
- | Eq -> aux_ordering t1 t2
- | res -> res
-;;
-
-
-let nonrec_kbo t1 t2 =
- let w1 = weight_of_term t1 in
- let w2 = weight_of_term t2 in
- (*
- prerr_endline ("weight1 :"^(string_of_weight w1));
- prerr_endline ("weight2 :"^(string_of_weight w2));
- *)
- match compare_weights ~normalize:true w1 w2 with
- | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable
- | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable
- | Eq -> aux_ordering t1 t2
- | res -> res
-;;
-
-
-let rec kbo t1 t2 =
- let aux = aux_ordering ~recursion:false in
- let w1 = weight_of_term t1
- and w2 = weight_of_term t2 in
- let rec cmp t1 t2 =
- match t1, t2 with
- | [], [] -> Eq
- | _, [] -> Gt
- | [], _ -> Lt
- | hd1::tl1, hd2::tl2 ->
- let o =
- kbo hd1 hd2
- in
- if o = Eq then cmp tl1 tl2
- else o
- in
- let comparison = compare_weights ~normalize:true w1 w2 in
- match comparison with
- | Le ->
- let r = aux t1 t2 in
- if r = Lt then Lt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Lt then Lt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Ge ->
- let r = aux t1 t2 in
- if r = Gt then Gt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Gt then Gt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Eq ->
- let r = aux t1 t2 in
- if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- cmp tl1 tl2
- | _, _ -> Incomparable
- ) else r
- | res -> res
-;;
-
-let rec ao t1 t2 =
- let get_hd t =
- match t with
- Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno)
- | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) ->
- Some(uri,tyno,cno)
- | _ -> None in
- let aux = aux_ordering ~recursion:false in
- let w1 = weight_of_term t1
- and w2 = weight_of_term t2 in
- let rec cmp t1 t2 =
- match t1, t2 with
- | [], [] -> Eq
- | _, [] -> Gt
- | [], _ -> Lt
- | hd1::tl1, hd2::tl2 ->
- let o =
- ao hd1 hd2
- in
- if o = Eq then cmp tl1 tl2
- else o
- in
- match get_hd t1, get_hd t2 with
- Some(_),None -> Lt
- | None,Some(_) -> Gt
- | _ ->
- let comparison = compare_weights ~normalize:true w1 w2 in
- match comparison with
- | Le ->
- let r = aux t1 t2 in
- if r = Lt then Lt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Lt then Lt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Ge ->
- let r = aux t1 t2 in
- if r = Gt then Gt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Gt then Gt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Eq ->
- let r = aux t1 t2 in
- if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- cmp tl1 tl2
- | _, _ -> Incomparable
- ) else r
- | res -> res
-;;
-
-let names_of_context context =
- List.map
- (function
- | None -> None
- | Some (n, e) -> Some n)
- context
-;;
-
-
-let rec lpo t1 t2 =
- let module C = Cic in
- match t1, t2 with
- | t1, t2 when t1 = t2 -> Eq
- | t1, (C.Meta _ as m) ->
- if TermSet.mem m (metas_of_term t1) then Gt else Incomparable
- | (C.Meta _ as m), t2 ->
- if TermSet.mem m (metas_of_term t2) then Lt else Incomparable
- | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> (
- let res =
- let f o r t =
- if r then true else
- match lpo t o with
- | Gt | Eq -> true
- | _ -> false
- in
- let res1 = List.fold_left (f t2) false tl1 in
- if res1 then Gt
- else let res2 = List.fold_left (f t1) false tl2 in
- if res2 then Lt
- else Incomparable
- in
- if res <> Incomparable then
- res
- else
- let f o r t =
- if not r then false else
- match lpo o t with
- | Gt -> true
- | _ -> false
- in
- match aux_ordering hd1 hd2 with
- | Gt ->
- let res = List.fold_left (f t1) false tl2 in
- if res then Gt
- else Incomparable
- | Lt ->
- let res = List.fold_left (f t2) false tl1 in
- if res then Lt
- else Incomparable
- | Eq -> (
- let lex_res =
- try
- List.fold_left2
- (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2)
- Eq tl1 tl2
- with Invalid_argument _ ->
- Incomparable
- in
- match lex_res with
- | Gt ->
- if List.fold_left (f t1) false tl2 then Gt
- else Incomparable
- | Lt ->
- if List.fold_left (f t2) false tl1 then Lt
- else Incomparable
- | _ -> Incomparable
- )
- | _ -> Incomparable
- )
- | t1, t2 -> aux_ordering t1 t2
-;;
-
-
-(* settable by the user... *)
-let compare_terms = ref nonrec_kbo;;
-(* let compare_terms = ref ao;; *)
-(* let compare_terms = ref rpo;; *)
-
-let guarded_simpl ?(debug=false) context t =
- if !compare_terms == nonrec_kbo then t
- else
- let t' = ProofEngineReduction.simpl context t in
- if t = t' then t else
- begin
- let simpl_order = !compare_terms t t' in
- debug_print (lazy ("comparing "^(CicPp.ppterm t)^(CicPp.ppterm t')));
- if simpl_order = Gt then (if debug then prerr_endline "GT";t')
- else (if debug then prerr_endline "NO_GT";t)
- end
-;;
-
-type pos = Left | Right
-
-let string_of_pos = function
- | Left -> "Left"
- | Right -> "Right"
-;;
-
-let metas_of_term t =
- List.map fst (CicUtil.metas_of_term t)
-;;
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* (weight of constants, [(meta, weight_of_meta)]) *)
-
-val time : bool
-val debug : bool
-val debug_metas: bool
-val debug_res: bool
-
-type weight = int * (int * int) list;;
-
-type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;;
-
-type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph
-
-val print_metasenv: Cic.metasenv -> string
-
-val print_subst: ?prefix:string -> Cic.substitution -> string
-
-val string_of_weight: weight -> string
-
-val weight_of_term:
- ?consider_metas:bool ->
- ?count_metas_occurrences:bool-> Cic.term -> weight
-
-val normalize_weight: int -> weight -> weight
-
-val string_of_comparison: comparison -> string
-
-val compare_weights: ?normalize:bool -> weight -> weight -> comparison
-
-val nonrec_kbo: Cic.term -> Cic.term -> comparison
-
-val rpo: Cic.term -> Cic.term -> comparison
-
-val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison
-
-val names_of_context: Cic.context -> (Cic.name option) list
-
-module TermMap: Map.S with type key = Cic.term
-
-val symbols_of_term: Cic.term -> int TermMap.t
-val set_goal_symbols: Cic.term -> unit
-
-val lpo: Cic.term -> Cic.term -> comparison
-
-val kbo: Cic.term -> Cic.term -> comparison
-
-val ao: Cic.term -> Cic.term -> comparison
-
-(** term-ordering function settable by the user *)
-val compare_terms: (Cic.term -> Cic.term -> comparison) ref
-
-val guarded_simpl: ?debug:bool -> Cic.context -> Cic.term -> Cic.term
-
-type pos = Left | Right
-
-val string_of_pos: pos -> string
-
-val compute_equality_weight: Cic.term * Cic.term * Cic.term * comparison -> int
-
-val debug_print: string Lazy.t -> unit
-
-val metas_of_term: Cic.term -> int list
-
-val remove_local_context: Cic.term -> Cic.term
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple
-exception NotAnInductiveTypeToEliminate
-exception WrongUriToVariable of string
-exception NotAnEliminator
-
-module PET = ProofEngineTypes
-
-(* lambda_abstract newmeta ty *)
-(* returns a triple [bo],[context],[ty'] where *)
-(* [ty] = Pi/LetIn [context].[ty'] ([context] is a vector!) *)
-(* and [bo] = Lambda/LetIn [context].(Meta [newmeta]) *)
-(* So, lambda_abstract is the core of the implementation of *)
-(* the Intros tactic. *)
-(* howmany = -1 means Intros, howmany > 0 means Intros n *)
-let lambda_abstract ?(howmany=(-1)) metasenv context newmeta ty mk_fresh_name =
- let module C = Cic in
- let rec collect_context context howmany do_whd ty =
- match howmany with
- | 0 ->
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- context, ty, (C.Meta (newmeta,irl))
- | _ ->
- match ty with
- C.Cast (te,_) -> collect_context context howmany do_whd te
- | C.Prod (n,s,t) ->
- let n' = mk_fresh_name metasenv context n ~typ:s in
- let (context',ty,bo) =
- let entry = match n' with
- | C.Name _ -> Some (n',(C.Decl s))
- | C.Anonymous -> None
- in
- let ctx = entry :: context in
- collect_context ctx (howmany - 1) do_whd t
- in
- (context',ty,C.Lambda(n',s,bo))
- | C.LetIn (n,s,sty,t) ->
- let (context',ty,bo) =
- collect_context ((Some (n,(C.Def (s,sty))))::context) (howmany - 1) do_whd t
- in
- (context',ty,C.LetIn(n,s,sty,bo))
- | _ as t ->
- if howmany <= 0 then
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- context, t, (C.Meta (newmeta,irl))
- else if do_whd then
- let t = CicReduction.whd ~delta:true context t in
- collect_context context howmany false t
- else
- raise (PET.Fail (lazy "intro(s): not enough products or let-ins"))
- in
- collect_context context howmany true ty
-
-let eta_expand metasenv context t arg =
- let module T = CicTypeChecker in
- let module S = CicSubstitution in
- let module C = Cic in
- let rec aux n =
- function
- t' when t' = S.lift n arg -> C.Rel (1 + n)
- | C.Rel m -> if m <= n then C.Rel m else C.Rel (m+1)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
- C.Var (uri,exp_named_subst')
- | C.Meta (i,l) ->
- let l' =
- List.map (function None -> None | Some t -> Some (aux n t)) l
- in
- C.Meta (i, l')
- | C.Sort _
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (aux n te, aux n ty)
- | C.Prod (nn,s,t) -> C.Prod (nn, aux n s, aux (n+1) t)
- | C.Lambda (nn,s,t) -> C.Lambda (nn, aux n s, aux (n+1) t)
- | C.LetIn (nn,s,ty,t) -> C.LetIn (nn, aux n s, aux n ty, aux (n+1) t)
- | C.Appl l -> C.Appl (List.map (aux n) l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,aux n outt, aux n t,
- List.map (aux n) pl)
- | C.Fix (i,fl) ->
- let tylen = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux n ty, aux (n+tylen) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let tylen = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux n ty, aux (n+tylen) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- and aux_exp_named_subst n =
- List.map (function uri,t -> uri,aux n t)
- in
- let argty,_ =
- T.type_of_aux' metasenv context arg CicUniv.oblivion_ugraph (* TASSI: FIXME *)
- in
- let fresh_name =
- FreshNamesGenerator.mk_fresh_name ~subst:[]
- metasenv context (Cic.Name "Heta") ~typ:argty
- in
- (C.Appl [C.Lambda (fresh_name,argty,aux 0 t) ; arg])
-
-(*CSC: ma serve solamente la prima delle new_uninst e l'unione delle due!!! *)
-let classify_metas newmeta in_subst_domain subst_in metasenv =
- List.fold_right
- (fun (i,canonical_context,ty) (old_uninst,new_uninst) ->
- if in_subst_domain i then
- old_uninst,new_uninst
- else
- let ty' = subst_in canonical_context ty in
- let canonical_context' =
- List.fold_right
- (fun entry canonical_context' ->
- let entry' =
- match entry with
- Some (n,Cic.Decl s) ->
- Some (n,Cic.Decl (subst_in canonical_context' s))
- | None -> None
- | Some (n,Cic.Def (bo,ty)) ->
- Some
- (n,
- Cic.Def
- (subst_in canonical_context' bo,
- subst_in canonical_context' ty))
- in
- entry'::canonical_context'
- ) canonical_context []
- in
- if i < newmeta then
- ((i,canonical_context',ty')::old_uninst),new_uninst
- else
- old_uninst,((i,canonical_context',ty')::new_uninst)
- ) metasenv ([],[])
-
-(* Useful only inside apply_tac *)
-let
- generalize_exp_named_subst_with_fresh_metas context newmeta uri exp_named_subst
-=
- let module C = Cic in
- let params =
- let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- CicUtil.params_of_obj o
- in
- let exp_named_subst_diff,new_fresh_meta,newmetasenvfragment,exp_named_subst'=
- let next_fresh_meta = ref newmeta in
- let newmetasenvfragment = ref [] in
- let exp_named_subst_diff = ref [] in
- let rec aux =
- function
- [],[] -> []
- | uri::tl,[] ->
- let ty =
- let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- match o with
- C.Variable (_,_,ty,_,_) ->
- CicSubstitution.subst_vars !exp_named_subst_diff ty
- | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
- in
-(* CSC: patch to generate ?1 : ?2 : Type in place of ?1 : Type to simulate ?1 :< Type
- (match ty with
- C.Sort (C.Type _) as s -> (* TASSI: ?? *)
- let fresh_meta = !next_fresh_meta in
- let fresh_meta' = fresh_meta + 1 in
- next_fresh_meta := !next_fresh_meta + 2 ;
- let subst_item = uri,C.Meta (fresh_meta',[]) in
- newmetasenvfragment :=
- (fresh_meta,[],C.Sort (C.Type (CicUniv.fresh()))) ::
- (* TASSI: ?? *)
- (fresh_meta',[],C.Meta (fresh_meta,[])) :: !newmetasenvfragment ;
- exp_named_subst_diff := !exp_named_subst_diff @ [subst_item] ;
- subst_item::(aux (tl,[]))
- | _ ->
-*)
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- let subst_item = uri,C.Meta (!next_fresh_meta,irl) in
- newmetasenvfragment :=
- (!next_fresh_meta,context,ty)::!newmetasenvfragment ;
- exp_named_subst_diff := !exp_named_subst_diff @ [subst_item] ;
- incr next_fresh_meta ;
- subst_item::(aux (tl,[]))(*)*)
- | uri::tl1,((uri',_) as s)::tl2 ->
- assert (UriManager.eq uri uri') ;
- s::(aux (tl1,tl2))
- | [],_ -> assert false
- in
- let exp_named_subst' = aux (params,exp_named_subst) in
- !exp_named_subst_diff,!next_fresh_meta,
- List.rev !newmetasenvfragment, exp_named_subst'
- in
- new_fresh_meta,newmetasenvfragment,exp_named_subst',exp_named_subst_diff
-;;
-
-let new_metasenv_and_unify_and_t newmeta' metasenv' subst context term' ty termty goal_arity =
- let (consthead,newmetasenv,arguments,_) =
- TermUtil.saturate_term newmeta' metasenv' context termty
- goal_arity in
- let subst,newmetasenv',_ =
- CicUnification.fo_unif_subst
- subst context newmetasenv consthead ty CicUniv.oblivion_ugraph
- in
- let t =
- if List.length arguments = 0 then term' else Cic.Appl (term'::arguments)
- in
- subst,newmetasenv',t
-
-let rec count_prods subst context ty =
- match CicReduction.whd ~subst context ty with
- Cic.Prod (n,s,t) -> 1 + count_prods subst (Some (n,Cic.Decl s)::context) t
- | _ -> 0
-
-let apply_with_subst ~term ~maxmeta (proof, goal) =
- (* Assumption: The term "term" must be closed in the current context *)
- let module T = CicTypeChecker in
- let module R = CicReduction in
- let module C = Cic in
- let (_,metasenv,subst,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let newmeta = max (CicMkImplicit.new_meta metasenv subst) maxmeta in
- let exp_named_subst_diff,newmeta',newmetasenvfragment,term' =
- match term with
- C.Var (uri,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.Var (uri,exp_named_subst')
- | C.Const (uri,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.MutInd (uri,tyno,exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
- generalize_exp_named_subst_with_fresh_metas context newmeta uri
- exp_named_subst
- in
- exp_named_subst_diff,newmeta',newmetasenvfragment,
- C.MutConstruct (uri,tyno,consno,exp_named_subst')
- | _ -> [],newmeta,[],term
- in
- let metasenv' = metasenv@newmetasenvfragment in
- let termty,_ =
- CicTypeChecker.type_of_aux'
- metasenv' ~subst context term' CicUniv.oblivion_ugraph
- in
- let termty =
- CicSubstitution.subst_vars exp_named_subst_diff termty in
- let goal_arity = count_prods subst context ty in
- let subst,newmetasenv',t =
- let rec add_one_argument n =
- try
- new_metasenv_and_unify_and_t newmeta' metasenv' subst context term' ty
- termty n
- with CicUnification.UnificationFailure _ when n > 0 ->
- add_one_argument (n - 1)
- in
- add_one_argument goal_arity
- in
- let in_subst_domain i = List.exists (function (j,_) -> i=j) subst in
- let apply_subst = CicMetaSubst.apply_subst subst in
- let old_uninstantiatedmetas,new_uninstantiatedmetas =
- (* subst_in doesn't need the context. Hence the underscore. *)
- let subst_in _ = CicMetaSubst.apply_subst subst in
- classify_metas newmeta in_subst_domain subst_in newmetasenv'
- in
- let bo' = apply_subst t in
- let newmetasenv'' = new_uninstantiatedmetas@old_uninstantiatedmetas in
- let subst_in =
- (* if we just apply the subtitution, the type is irrelevant:
- we may use Implicit, since it will be dropped *)
- ((metano,(context,bo',Cic.Implicit None))::subst)
- in
- let (newproof, newmetasenv''') =
- ProofEngineHelpers.subst_meta_and_metasenv_in_proof proof metano subst_in
- newmetasenv''
- in
- let subst = ((metano,(context,bo',ty))::subst) in
- let newproof =
- let u,m,_,p,t,l = newproof in
- u,m,subst,p,t,l
- in
- subst,
- (newproof, List.map (function (i,_,_) -> i) new_uninstantiatedmetas),
- max maxmeta (CicMkImplicit.new_meta newmetasenv''' subst)
-
-
-(* ALB *)
-let apply_with_subst ~term ?(subst=[]) ?(maxmeta=0) status =
- try
- let status =
- if subst <> [] then
- let (u,m,_,p,t,l), g = status in (u,m,subst,p,t,l), g
- else status
- in
- apply_with_subst ~term ~maxmeta status
- with
- | CicUnification.UnificationFailure msg
- | CicTypeChecker.TypeCheckerFailure msg -> raise (PET.Fail msg)
-
-(* ALB *)
-let apply_tac_verbose ~term status =
- let subst, status, _ = apply_with_subst ~term status in
- (CicMetaSubst.apply_subst subst), status
-
-let apply_tac ~term status = snd (apply_tac_verbose ~term status)
-
- (* TODO per implementare i tatticali e' necessario che tutte le tattiche
- sollevino _solamente_ Fail *)
-let apply_tac ~term =
- let apply_tac ~term status =
- try
- apply_tac ~term status
- (* TODO cacciare anche altre eccezioni? *)
- with
- | CicUnification.UnificationFailure msg
- | CicTypeChecker.TypeCheckerFailure msg ->
- raise (PET.Fail msg)
- in
- PET.mk_tactic (apply_tac ~term)
-
-let applyP_tac ~term =
- let applyP_tac status =
- let res = PET.apply_tactic (apply_tac ~term) status in res
- in
- PET.mk_tactic applyP_tac
-
-let intros_tac ?howmany ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) ()=
- let intros_tac (proof, goal)
- =
- let module C = Cic in
- let module R = CicReduction in
- let (_,metasenv,_subst,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in
- let (context',ty',bo') =
- lambda_abstract ?howmany metasenv context newmeta ty mk_fresh_name_callback
- in
- let (newproof, _) =
- ProofEngineHelpers.subst_meta_in_proof proof metano bo'
- [newmeta,context',ty']
- in
- (newproof, [newmeta])
- in
- PET.mk_tactic intros_tac
-
-let cut_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) term =
- let cut_tac
- ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- term (proof, goal)
- =
- let module C = Cic in
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let newmeta1 = ProofEngineHelpers.new_meta_of_proof ~proof in
- let newmeta2 = newmeta1 + 1 in
- let fresh_name =
- mk_fresh_name_callback metasenv context (Cic.Name "Hcut") ~typ:term in
- let context_for_newmeta1 =
- (Some (fresh_name,C.Decl term))::context in
- let irl1 =
- CicMkImplicit.identity_relocation_list_for_metavariable
- context_for_newmeta1
- in
- let irl2 =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- let newmeta1ty = CicSubstitution.lift 1 ty in
- let bo' =
- Cic.LetIn (fresh_name, C.Meta (newmeta2,irl2), term, C.Meta (newmeta1,irl1))
- in
- let (newproof, _) =
- ProofEngineHelpers.subst_meta_in_proof proof metano bo'
- [newmeta2,context,term; newmeta1,context_for_newmeta1,newmeta1ty];
- in
- (newproof, [newmeta1 ; newmeta2])
- in
- PET.mk_tactic (cut_tac ~mk_fresh_name_callback term)
-
-let letin_tac ?(mk_fresh_name_callback=FreshNamesGenerator.mk_fresh_name ~subst:[]) term =
- let letin_tac
- ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- term (proof, goal)
- =
- let module C = Cic in
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- (* occur check *)
- let occur i t =
- let m = CicUtil.metas_of_term t in
- List.exists (fun (j,_) -> i=j) m
- in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- if occur metano term then
- raise
- (ProofEngineTypes.Fail (lazy
- "You can't letin a term containing the current goal"));
- let tty,_ =
- CicTypeChecker.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
- let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in
- let fresh_name =
- mk_fresh_name_callback metasenv context (Cic.Name "Hletin") ~typ:term in
- let context_for_newmeta =
- (Some (fresh_name,C.Def (term,tty)))::context in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable
- context_for_newmeta
- in
- let newmetaty = CicSubstitution.lift 1 ty in
- let bo' = C.LetIn (fresh_name,term,tty,C.Meta (newmeta,irl)) in
- let (newproof, _) =
- ProofEngineHelpers.subst_meta_in_proof
- proof metano bo'[newmeta,context_for_newmeta,newmetaty]
- in
- (newproof, [newmeta])
- in
- PET.mk_tactic (letin_tac ~mk_fresh_name_callback term)
-
-(* FG: exact_tac := apply_tac as in NTactics *)
-let exact_tac ~term = apply_tac ~term
-
-(* not really "primitive" tactics .... *)
-
-module TC = CicTypeChecker
-module UM = UriManager
-module R = CicReduction
-module C = Cic
-module PEH = ProofEngineHelpers
-module PER = ProofEngineReduction
-module MS = CicMetaSubst
-module S = CicSubstitution
-module T = Tacticals
-module RT = ReductionTactics
-
-let rec args_init n f =
- if n <= 0 then [] else f n :: args_init (pred n) f
-
-let mk_predicate_for_elim
- ~context ~metasenv ~subst ~ugraph ~goal ~arg ~using ~cpattern ~args_no
-=
- let instantiated_eliminator =
- let f n = if n = 1 then arg else C.Implicit None in
- C.Appl (using :: args_init args_no f)
- in
- let _actual_arg, iety, _metasenv', _ugraph =
- CicRefine.type_of_aux' metasenv context instantiated_eliminator ugraph
- in
- let _actual_meta, actual_args = match iety with
- | C.Meta (i, _) -> i, []
- | C.Appl (C.Meta (i, _) :: args) -> i, args
- | _ -> assert false
- in
-(* let _, upto = PEH.split_with_whd (List.nth splits pred_pos) in *)
- let rec mk_pred metasenv subst context' pred arg' cpattern' = function
- | [] -> metasenv, subst, pred, arg'
- | arg :: tail ->
-(* FG: we find the predicate for the eliminator as in the rewrite tactic ****)
- let argty, _ = TC.type_of_aux' metasenv ~subst context arg ugraph in
- let argty = CicReduction.whd ~subst context argty in
- let fresh_name =
- FreshNamesGenerator.mk_fresh_name
- ~subst metasenv context' C.Anonymous ~typ:argty in
- let hyp = Some (fresh_name, C.Decl argty) in
- let lazy_term c m u =
- let distance = List.length c - List.length context in
- S.lift distance arg, m, u in
- let pattern = Some lazy_term, [], Some cpattern' in
- let subst, metasenv, _ugraph, _conjecture, selected_terms =
- ProofEngineHelpers.select ~subst ~metasenv ~ugraph
- ~conjecture:(0, context, pred) ~pattern in
- let metasenv = MS.apply_subst_metasenv subst metasenv in
- let map (_context_of_t, t) l = t :: l in
- let what = List.fold_right map selected_terms [] in
- let arg' = MS.apply_subst subst arg' in
- let pred = PER.replace_with_rel_1_from ~equality:(==) ~what 1 pred in
- let pred = MS.apply_subst subst pred in
- let pred = C.Lambda (fresh_name, C.Implicit None, pred) in
- let cpattern' = C.Lambda (C.Anonymous, C.Implicit None, cpattern') in
- mk_pred metasenv subst (hyp :: context') pred arg' cpattern' tail
- in
- let metasenv, subst, pred, arg =
- mk_pred metasenv subst context goal arg cpattern (List.rev actual_args)
- in
- HLog.debug ("PREDICATE CONTEXT:\n" ^ CicPp.ppcontext ~metasenv context);
- HLog.debug ("PREDICATE: " ^ CicPp.ppterm ~metasenv pred ^ " ARGS: " ^ String.concat " " (List.map (CicPp.ppterm ~metasenv) actual_args));
- metasenv, subst, pred, arg, actual_args
-
-let beta_after_elim_tac upto predicate =
- let beta_after_elim_tac status =
- let proof, goal = status in
- let _, metasenv, _subst, _, _, _ = proof in
- let _, _, ty = CicUtil.lookup_meta goal metasenv in
- let mk_pattern ~equality ~upto ~predicate ty =
- (* code adapted from ProceduralConversion.generalize *)
- let meta = C.Implicit None in
- let hole = C.Implicit (Some `Hole) in
- let anon = C.Anonymous in
- let is_meta =
- let map b = function
- | C.Implicit None when b -> b
- | _ -> false
- in
- List.fold_left map true
- in
- let rec gen_fix len k (name, i, ty, bo) =
- name, i, gen_term k ty, gen_term (k + len) bo
- and gen_cofix len k (name, ty, bo) =
- name, gen_term k ty, gen_term (k + len) bo
- and gen_term k = function
- | C.Sort _
- | C.Implicit _
- | C.Const (_, _)
- | C.Var (_, _)
- | C.MutInd (_, _, _)
- | C.MutConstruct (_, _, _, _)
- | C.Meta (_, _)
- | C.Rel _ -> meta
- | C.Appl (hd :: tl) when equality hd (S.lift k predicate) ->
- assert (List.length tl = upto);
- hole
- | C.Appl ts ->
- let ts = List.map (gen_term k) ts in
- if is_meta ts then meta else C.Appl ts
- | C.Cast (te, ty) ->
- let te, ty = gen_term k te, gen_term k ty in
- if is_meta [te; ty] then meta else C.Cast (te, ty)
- | C.MutCase (sp, i, outty, t, pl) ->
- let outty, t, pl = gen_term k outty, gen_term k t, List.map (gen_term k) pl in
- if is_meta (outty :: t :: pl) then meta else hole (* C.MutCase (sp, i, outty, t, pl) *)
- | C.Prod (_, s, t) ->
- let s, t = gen_term k s, gen_term (succ k) t in
- if is_meta [s; t] then meta else C.Prod (anon, s, t)
- | C.Lambda (_, s, t) ->
- let s, t = gen_term k s, gen_term (succ k) t in
- if is_meta [s; t] then meta else C.Lambda (anon, s, t)
- | C.LetIn (_, s, ty, t) ->
- let s,ty,t = gen_term k s, gen_term k ty, gen_term (succ k) t in
- if is_meta [s; t] then meta else C.LetIn (anon, s, ty, t)
- | C.Fix (i, fl) -> C.Fix (i, List.map (gen_fix (List.length fl) k) fl)
- | C.CoFix (i, fl) -> C.CoFix (i, List.map (gen_cofix (List.length fl) k) fl)
- in
- None, [], Some (gen_term 0 ty)
- in
- let equality = CicUtil.alpha_equivalence in
- let pattern = mk_pattern ~equality ~upto ~predicate ty in
- let tactic = RT.head_beta_reduce_tac ~delta:false ~upto ~pattern in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic beta_after_elim_tac
-
-(* ANCORA DA DEBUGGARE *)
-
-exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;;
-exception TheSelectedTermsMustLiveInTheGoalContext
-exception AllSelectedTermsMustBeConvertible;;
-exception GeneralizationInHypothesesNotImplementedYet;;
-
-let generalize_tac
- ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- pattern
- =
- let module PET = ProofEngineTypes in
- let generalize_tac mk_fresh_name_callback
- ~pattern:(term,hyps_pat,_) status
- =
- if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet;
- let (proof, goal) = status in
- let module C = Cic in
- let module T = Tacticals in
- let uri,metasenv,subst,pbo,pty, attrs = proof in
- let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
- let subst,metasenv,u,selected_hyps,terms_with_context =
- ProofEngineHelpers.select ~metasenv ~subst ~ugraph:CicUniv.oblivion_ugraph
- ~conjecture ~pattern in
- let context = CicMetaSubst.apply_subst_context subst context in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let pbo = lazy (CicMetaSubst.apply_subst subst (Lazy.force pbo)) in
- let pty = CicMetaSubst.apply_subst subst pty in
- let term =
- match term with
- None -> None
- | Some term ->
- Some (fun context metasenv ugraph ->
- let term, metasenv, ugraph = term context metasenv ugraph in
- CicMetaSubst.apply_subst subst term,
- CicMetaSubst.apply_subst_metasenv subst metasenv,
- ugraph)
- in
- let u,typ,term, metasenv' =
- let context_of_t, (t, metasenv, u) =
- match terms_with_context, term with
- [], None ->
- raise
- UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly
- | [], Some t -> context, t context metasenv u
- | (context_of_t, _)::_, Some t ->
- context_of_t, t context_of_t metasenv u
- | (context_of_t, t)::_, None -> context_of_t, (t, metasenv, u)
- in
- let t,e_subst,metasenv' =
- try
- CicMetaSubst.delift_rels [] metasenv
- (List.length context_of_t - List.length context) t
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- raise TheSelectedTermsMustLiveInTheGoalContext
- in
- (*CSC: I am not sure about the following two assertions;
- maybe I need to propagate the new subst and metasenv *)
- assert (e_subst = []);
- assert (metasenv' = metasenv);
- let typ,u = CicTypeChecker.type_of_aux' ~subst metasenv context t u in
- u,typ,t,metasenv
- in
- (* We need to check:
- 1. whether they live in the context of the goal;
- if they do they are also well-typed since they are closed subterms
- of a well-typed term in the well-typed context of the well-typed
- term
- 2. whether they are convertible
- *)
- ignore (
- List.fold_left
- (fun u (context_of_t,t) ->
- (* 1 *)
- let t,subst,metasenv'' =
- try
- CicMetaSubst.delift_rels [] metasenv'
- (List.length context_of_t - List.length context) t
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- raise TheSelectedTermsMustLiveInTheGoalContext in
- (*CSC: I am not sure about the following two assertions;
- maybe I need to propagate the new subst and metasenv *)
- assert (subst = []);
- assert (metasenv'' = metasenv');
- (* 2 *)
- let b,u1 = CicReduction.are_convertible ~subst context term t u in
- if not b then
- raise AllSelectedTermsMustBeConvertible
- else
- u1
- ) u terms_with_context) ;
- let status = (uri,metasenv',subst,pbo,pty, attrs),goal in
- let proof,goals =
- PET.apply_tactic
- (T.thens
- ~start:
- (cut_tac
- (C.Prod(
- (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ),
- typ,
- (ProofEngineReduction.replace_lifting_csc 1
- ~equality:(==)
- ~what:(List.map snd terms_with_context)
- ~with_what:(List.map (function _ -> C.Rel 1) terms_with_context)
- ~where:ty)
- )))
- ~continuations:
- [(apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ;
- T.id_tac])
- status
- in
- let _,metasenv'',_,_,_, _ = proof in
- (* CSC: the following is just a bad approximation since a meta
- can be closed and then re-opened! *)
- (proof,
- goals @
- (List.filter
- (fun j -> List.exists (fun (i,_,_) -> i = j) metasenv'')
- (ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv
- ~newmetasenv:metasenv')))
- in
- PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern)
-;;
-
-let generalize_pattern_tac pattern =
- let generalize_pattern_tac (proof,goal) =
- let _,metasenv,_,_,_,_ = proof in
- let conjecture = CicUtil.lookup_meta goal metasenv in
- let _,context,_ = conjecture in
- let generalize_hyps =
- let _,hpatterns,_ = ProofEngineHelpers.sort_pattern_hyps context pattern in
- List.map fst hpatterns in
- let ids_and_patterns =
- List.map
- (fun id ->
- let rel,_ = ProofEngineHelpers.find_hyp id context in
- id,(Some (fun ctx m u -> CicSubstitution.lift (List.length ctx - List.length context) rel,m,u), [], Some (ProofEngineTypes.hole))
- ) generalize_hyps in
- let tactics =
- List.map
- (function (id,pattern) ->
- Tacticals.then_ ~start:(generalize_tac pattern)
- ~continuation:(Tacticals.try_tactic
- (ProofEngineStructuralRules.clear [id]))
- ) ids_and_patterns
- in
- PET.apply_tactic (Tacticals.seq tactics) (proof,goal)
- in
- PET.mk_tactic (generalize_pattern_tac)
-;;
-
-let pattern_after_generalize_pattern_tac (tp, hpatterns, cpattern) =
- let cpattern =
- match cpattern with
- None -> ProofEngineTypes.hole
- | Some t -> t
- in
- let cpattern =
- List.fold_left
- (fun t (_,ty) -> Cic.Prod (Cic.Anonymous, ty, t)) cpattern hpatterns
- in
- tp, [], Some cpattern
-;;
-
-let elim_tac ?using ?(pattern = PET.conclusion_pattern None) term =
- let elim_tac pattern (proof, goal) =
- let ugraph = CicUniv.oblivion_ugraph in
- let curi, metasenv, subst, proofbo, proofty, attrs = proof in
- let conjecture = CicUtil.lookup_meta goal metasenv in
- let metano, context, ty = conjecture in
- let pattern = pattern_after_generalize_pattern_tac pattern in
- let cpattern =
- match pattern with
- | None, [], Some cpattern -> cpattern
- | _ -> raise (PET.Fail (lazy "not implemented")) in
- let termty,_ugraph = TC.type_of_aux' metasenv ~subst context term ugraph in
- let termty = CicReduction.whd ~subst context termty in
- let termty, metasenv', arguments, _fresh_meta =
- TermUtil.saturate_term
- (ProofEngineHelpers.new_meta_of_proof proof) metasenv context termty 0 in
- let term = if arguments = [] then term else Cic.Appl (term::arguments) in
- let uri, exp_named_subst, typeno, _args =
- match termty with
- C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
- | C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::args) ->
- (uri,exp_named_subst,typeno,args)
- | _ -> raise NotAnInductiveTypeToEliminate
- in
- let eliminator_uri =
- let buri = UM.buri_of_uri uri in
- let name =
- let o,_ugraph = CicEnvironment.get_obj ugraph uri in
- match o with
- C.InductiveDefinition (tys,_,_,_) ->
- let (name,_,_,_) = List.nth tys typeno in
- name
- | _ -> assert false
- in
- let ty_ty,_ugraph = TC.type_of_aux' metasenv' ~subst context ty ugraph in
- let ext =
- match ty_ty with
- C.Sort C.Prop -> "_ind"
- | C.Sort C.Set -> "_rec"
- | C.Sort (C.CProp _) -> "_rect"
- | C.Sort (C.Type _)-> "_rect"
- | C.Meta (_,_) -> raise TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple
- | _ -> assert false
- in
- UM.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con")
- in
- let eliminator_ref = match using with
- | None -> C.Const (eliminator_uri, exp_named_subst)
- | Some t -> t
- in
- let ety, _ugraph =
- TC.type_of_aux' metasenv' ~subst context eliminator_ref ugraph in
-(* FG: ADDED PART ***********************************************************)
-(* FG: we can not assume eliminator is the default eliminator ***************)
- let splits, args_no = PEH.split_with_whd (context, ety) in
- let pred_pos = match List.hd splits with
- | _, C.Rel i when i > 1 && i <= args_no -> i
- | _, C.Appl (C.Rel i :: _) when i > 1 && i <= args_no -> i
- | _ -> raise NotAnEliminator
- in
- let metasenv', subst, pred, term, actual_args = match pattern with
- | None, [], Some (C.Implicit (Some `Hole)) ->
- metasenv', subst, C.Implicit None, term, []
- | _ ->
- mk_predicate_for_elim
- ~args_no ~context ~ugraph ~cpattern
- ~metasenv:metasenv' ~subst ~arg:term ~using:eliminator_ref ~goal:ty
- in
-(* FG: END OF ADDED PART ****************************************************)
- let term_to_refine =
- let f n =
- if n = pred_pos then pred else
- if n = 1 then term else C.Implicit None
- in
- C.Appl (eliminator_ref :: args_init args_no f)
- in
- let refined_term,_refined_termty,metasenv'',subst,_ugraph =
- CicRefine.type_of metasenv' subst context term_to_refine ugraph
- in
- let ipred = match refined_term with
- | C.Appl ts -> List.nth ts (List.length ts - pred_pos)
- | _ -> assert false
- in
- let new_goals =
- ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:metasenv''
- in
- let proof' = curi,metasenv'',subst,proofbo,proofty, attrs in
- let proof'', new_goals' =
- PET.apply_tactic (apply_tac ~term:refined_term) (proof',goal)
- in
- (* The apply_tactic can have closed some of the new_goals *)
- let patched_new_goals =
- let (_,metasenv''',_,_,_, _) = proof'' in
- List.filter
- (function i -> List.exists (function (j,_,_) -> j=i) metasenv''')
- new_goals @ new_goals'
- in
- let res = proof'', patched_new_goals in
- let upto = List.length actual_args in
- if upto = 0 then res else
-(* FG: we use ipred (instantiated pred) instead of pred (not instantiated) *)
- let continuation = beta_after_elim_tac upto ipred in
- let dummy_status = proof,goal in
- PET.apply_tactic
- (T.then_ ~start:(PET.mk_tactic (fun _ -> res)) ~continuation)
- dummy_status
- in
- let reorder_pattern ((proof, goal) as status) =
- let _,metasenv,_,_,_,_ = proof in
- let conjecture = CicUtil.lookup_meta goal metasenv in
- let _,context,_ = conjecture in
- let pattern = ProofEngineHelpers.sort_pattern_hyps context pattern in
- PET.apply_tactic
- (Tacticals.then_ ~start:(generalize_pattern_tac pattern)
- ~continuation:(PET.mk_tactic (elim_tac pattern))) status
- in
- PET.mk_tactic reorder_pattern
-;;
-
-let cases_intros_tac ?(howmany=(-1)) ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) ?(pattern = PET.conclusion_pattern None) term =
- let cases_tac pattern (proof, goal) =
- let module TC = CicTypeChecker in
- let module U = UriManager in
- let module R = CicReduction in
- let module C = Cic in
- let (curi,metasenv,_subst, proofbo,proofty, attrs) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let pattern = pattern_after_generalize_pattern_tac pattern in
- let _cpattern =
- match pattern with
- | None, [], Some cpattern ->
- let rec is_hole =
- function
- Cic.Implicit (Some `Hole) -> true
- | Cic.Prod (Cic.Anonymous,so,tgt) -> is_hole so && is_hole tgt
- | _ -> false
- in
- if not (is_hole cpattern) then
- raise (PET.Fail (lazy "not implemented"))
- | _ -> raise (PET.Fail (lazy "not implemented")) in
- let termty,_ = TC.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in
- let termty = CicReduction.whd context termty in
- let (termty,metasenv',arguments,fresh_meta) =
- TermUtil.saturate_term
- (ProofEngineHelpers.new_meta_of_proof proof) metasenv context termty 0 in
- let term = if arguments = [] then term else Cic.Appl (term::arguments) in
- let uri,exp_named_subst,typeno,args =
- match termty with
- | C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
- | C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::args) ->
- (uri,exp_named_subst,typeno,args)
- | _ -> raise NotAnInductiveTypeToEliminate
- in
- let paramsno,itty,patterns,right_args =
- match CicEnvironment.get_obj CicUniv.oblivion_ugraph uri with
- | C.InductiveDefinition (tys,_,paramsno,_),_ ->
- let _,left_parameters,right_args =
- List.fold_right
- (fun x (n,acc1,acc2) ->
- if n > 0 then (n-1,acc1,x::acc2) else (n,x::acc1,acc2))
- args (List.length args - paramsno, [],[])
- in
- let _,_,itty,cl = List.nth tys typeno in
- let rec aux left_parameters context t =
- match left_parameters,CicReduction.whd context t with
- | [],C.Prod (name,source,target) ->
- let fresh_name =
- mk_fresh_name_callback metasenv' context name ~typ:source
- in
- C.Lambda (fresh_name,C.Implicit None,
- aux [] (Some (fresh_name,C.Decl source)::context) target)
- | hd::tl,C.Prod (name,source,target) ->
- (* left parameters instantiation *)
- aux tl context (CicSubstitution.subst hd target)
- | [],_ -> C.Implicit None
- | _ -> assert false
- in
- paramsno,itty,
- List.map (function (_,cty) -> aux left_parameters context cty) cl,
- right_args
- | _ -> assert false
- in
- let outtypes =
- let n_right_args = List.length right_args in
- let n_lambdas = n_right_args + 1 in
- let lifted_ty = CicSubstitution.lift n_lambdas ty in
- let captured_ty =
- let what =
- List.map (CicSubstitution.lift n_lambdas) (right_args)
- in
- let with_what meta =
- let rec mkargs = function
- | 0 -> assert false
- | 1 -> []
- | n ->
- (if meta then Cic.Implicit None else Cic.Rel n)::(mkargs (n-1))
- in
- mkargs n_lambdas
- in
- let replaced = ref false in
- let replace = ProofEngineReduction.replace_lifting
- ~equality:(fun _ a b -> let rc = CicUtil.alpha_equivalence a b in
- if rc then replaced := true; rc)
- ~context:[]
- in
- let captured =
- replace ~what:[CicSubstitution.lift n_lambdas term]
- ~with_what:[Cic.Rel 1] ~where:lifted_ty
- in
- if not !replaced then
- (* this means the matched term is not there,
- * but maybe right params are: we user rels (to right args lambdas) *)
- [replace ~what ~with_what:(with_what false) ~where:captured]
- else
- (* since the matched is there, rights should be inferrable *)
- [replace ~what ~with_what:(with_what false) ~where:captured;
- replace ~what ~with_what:(with_what true) ~where:captured]
- in
- let captured_term_ty =
- let term_ty = CicSubstitution.lift n_right_args termty in
- let rec mkrels = function 0 -> []|n -> (Cic.Rel n)::(mkrels (n-1)) in
- let rec fstn acc l n =
- if n = 0 then acc else fstn (acc@[List.hd l]) (List.tl l) (n-1)
- in
- match term_ty with
- | C.MutInd _ -> term_ty
- | C.Appl ((C.MutInd (a,b,c))::args) ->
- C.Appl ((C.MutInd (a,b,c))::
- fstn [] args paramsno @ mkrels n_right_args)
- | _ -> raise NotAnInductiveTypeToEliminate
- in
- let rec add_lambdas captured_ty = function
- | 0 -> captured_ty
- | 1 ->
- C.Lambda (C.Name "matched", captured_term_ty, (add_lambdas captured_ty 0))
- | n ->
- C.Lambda (C.Name ("right_"^(string_of_int (n-1))),
- C.Implicit None, (add_lambdas captured_ty (n-1)))
- in
- List.map (fun x -> add_lambdas x n_lambdas) captured_ty
- in
- let rec first = (* easier than using tacticals *)
- function
- | [] -> raise (PET.Fail (lazy ("unable to generate a working outtype")))
- | outtype::rest ->
- let term_to_refine = C.MutCase (uri,typeno,outtype,term,patterns) in
- try
- let refined_term,_,metasenv'',_ =
- CicRefine.type_of_aux' metasenv' context term_to_refine
- CicUniv.oblivion_ugraph
- in
- let new_goals =
- ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:metasenv''
- in
- let proof' = curi,metasenv'',_subst,proofbo,proofty, attrs in
- let proof'', new_goals' =
- PET.apply_tactic (apply_tac ~term:refined_term) (proof',goal)
- in
- (* The apply_tactic can have closed some of the new_goals *)
- let patched_new_goals =
- let (_,metasenv''',_subst,_,_,_) = proof'' in
- List.filter
- (function i -> List.exists (function (j,_,_) -> j=i) metasenv''')
- new_goals @ new_goals'
- in
- proof'', patched_new_goals
- with PET.Fail _ | CicRefine.RefineFailure _ | CicRefine.Uncertain _ -> first rest
- in
- first outtypes
- in
- let reorder_pattern ((proof, goal) as status) =
- let _,metasenv,_,_,_,_ = proof in
- let conjecture = CicUtil.lookup_meta goal metasenv in
- let _,context,_ = conjecture in
- let pattern = ProofEngineHelpers.sort_pattern_hyps context pattern in
- PET.apply_tactic
- (Tacticals.then_ ~start:(generalize_pattern_tac pattern)
- ~continuation:(PET.mk_tactic (cases_tac pattern))) status
- in
- PET.mk_tactic reorder_pattern
-;;
-
-
-let elim_intros_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- ?depth ?using ?pattern what =
- Tacticals.then_ ~start:(elim_tac ?using ?pattern what)
- ~continuation:(intros_tac ~mk_fresh_name_callback ?howmany:depth ())
-;;
-
-(* The simplification is performed only on the conclusion *)
-let elim_intros_simpl_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- ?depth ?using ?pattern what =
- Tacticals.then_ ~start:(elim_tac ?using ?pattern what)
- ~continuation:
- (Tacticals.thens
- ~start:(intros_tac ~mk_fresh_name_callback ?howmany:depth ())
- ~continuations:
- [ReductionTactics.simpl_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern None)])
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**** useful only to implement tactics similar to apply ****)
-
-val generalize_exp_named_subst_with_fresh_metas :
- Cic.context ->
- int ->
- UriManager.uri ->
- (UriManager.uri * Cic.term) list ->
- int * Cic.metasenv *
- Cic.term Cic.explicit_named_substitution *
- Cic.term Cic.explicit_named_substitution
-
-val classify_metas :
- Cic.term ->
- (Cic.term -> bool) ->
- (Cic.context -> Cic.term -> Cic.term) ->
- (Cic.term * Cic.context * Cic.term) list ->
- (Cic.term * Cic.context * Cic.term) list *
- (Cic.term * Cic.context * Cic.term) list
-
-(* Not primitive, but useful for elim *)
-
-exception AllSelectedTermsMustBeConvertible;;
-
-val generalize_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ProofEngineTypes.lazy_pattern ->
- ProofEngineTypes.tactic
-
-(* not a real tactic *)
-val apply_tac_verbose :
- term:Cic.term ->
- ProofEngineTypes.proof * int ->
- (Cic.term -> Cic.term) * (ProofEngineTypes.proof * int list)
-
-(* the proof status has a subst now, and apply_tac honors it *)
-val apply_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-val applyP_tac: (* apply for procedural reconstruction *)
- term: Cic.term -> ProofEngineTypes.tactic
-val exact_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-val intros_tac:
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> unit ->
- ProofEngineTypes.tactic
-val cut_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- Cic.term ->
- ProofEngineTypes.tactic
-val letin_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- Cic.term ->
- ProofEngineTypes.tactic
-
-val elim_intros_simpl_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term ->
- ?pattern:ProofEngineTypes.lazy_pattern -> Cic.term ->
- ProofEngineTypes.tactic
-val elim_intros_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term ->
- ?pattern:ProofEngineTypes.lazy_pattern -> Cic.term ->
- ProofEngineTypes.tactic
-
-val cases_intros_tac:
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?pattern:ProofEngineTypes.lazy_pattern -> Cic.term ->
- ProofEngineTypes.tactic
-
-(* FG *)
-
-val mk_predicate_for_elim:
- context:Cic.context -> metasenv:Cic.metasenv -> subst:Cic.substitution ->
- ugraph:CicUniv.universe_graph -> goal:Cic.term ->
- arg:Cic.term -> using:Cic.term -> cpattern:Cic.term -> args_no:int ->
- Cic.metasenv * Cic.substitution * Cic.term * Cic.term * Cic.term list
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-exception Bad_pattern of string Lazy.t
-
-let new_meta_of_proof ~proof:(_, metasenv, subst, _, _, _) =
- CicMkImplicit.new_meta metasenv subst
-
-let subst_meta_in_proof proof meta term newmetasenv =
- let uri,metasenv,initial_subst,bo,ty, attrs = proof in
- (* empty context is ok for term since it wont be used by apply_subst *)
- (* hack: since we do not know the context and the type of term, we
- create a substitution with cc =[] and type = Implicit; they will be
- in any case dropped by apply_subst, but it would be better to rewrite
- the code. Cannot we just use apply_subst_metasenv, etc. ?? *)
- let subst_in = CicMetaSubst.apply_subst [meta,([], term,Cic.Implicit None)] in
- let metasenv' =
- newmetasenv @ (List.filter (function (m,_,_) -> m <> meta) metasenv)
- in
- let metasenv'' =
- List.map
- (function i,canonical_context,ty ->
- let canonical_context' =
- List.map
- (function
- Some (n,Cic.Decl s) -> Some (n,Cic.Decl (subst_in s))
- | None -> None
- | Some (n,Cic.Def (bo,ty)) ->
- Some (n,Cic.Def (subst_in bo,subst_in ty))
- ) canonical_context
- in
- i,canonical_context',(subst_in ty)
- ) metasenv'
- in
- let bo' = lazy (subst_in (Lazy.force bo)) in
- (* Metavariables can appear also in the *statement* of the theorem
- * since the parser does not reject as statements terms with
- * metavariable therein *)
- let ty' = subst_in ty in
- let newproof = uri,metasenv'',initial_subst,bo',ty', attrs in
- (newproof, metasenv'')
-
-(*CSC: commento vecchio *)
-(* refine_meta_with_brand_new_metasenv meta term subst_in newmetasenv *)
-(* This (heavy) function must be called when a tactic can instantiate old *)
-(* metavariables (i.e. existential variables). It substitues the metasenv *)
-(* of the proof with the result of removing [meta] from the domain of *)
-(* [newmetasenv]. Then it replaces Cic.Meta [meta] with [term] everywhere *)
-(* in the current proof. Finally it applies [apply_subst_replacing] to *)
-(* current proof. *)
-(*CSC: A questo punto perche' passare un bo' gia' istantiato, se tanto poi *)
-(*CSC: ci ripasso sopra apply_subst!!! *)
-(*CSC: Attenzione! Ora questa funzione applica anche [subst_in] a *)
-(*CSC: [newmetasenv]. *)
-let subst_meta_and_metasenv_in_proof proof meta subst newmetasenv =
- let (uri,_,initial_subst,bo,ty, attrs) = proof in
- let subst_in = CicMetaSubst.apply_subst subst in
- let bo' = lazy (subst_in (Lazy.force bo)) in
- (* Metavariables can appear also in the *statement* of the theorem
- * since the parser does not reject as statements terms with
- * metavariable therein *)
- let ty' = subst_in ty in
- let metasenv' =
- List.fold_right
- (fun metasenv_entry i ->
- match metasenv_entry with
- (m,canonical_context,ty) when m <> meta ->
- let canonical_context' =
- List.map
- (function
- None -> None
- | Some (i,Cic.Decl t) -> Some (i,Cic.Decl (subst_in t))
- | Some (i,Cic.Def (bo,ty)) ->
- Some (i,Cic.Def (subst_in bo,subst_in ty))
- ) canonical_context
- in
- (m,canonical_context',subst_in ty)::i
- | _ -> i
- ) newmetasenv []
- in
- (* qui da capire se per la fase transitoria si fa initial_subst @ subst
- * oppure subst *)
- let newproof = uri,metasenv',subst,bo',ty', attrs in
- (newproof, metasenv')
-
-let compare_metasenvs ~oldmetasenv ~newmetasenv =
- List.map (function (i,_,_) -> i)
- (List.filter
- (function (i,_,_) ->
- not (List.exists (fun (j,_,_) -> i=j) oldmetasenv)) newmetasenv)
-;;
-
-(** finds the _pointers_ to subterms that are alpha-equivalent to wanted in t *)
-let find_subterms ~subst ~metasenv ~ugraph ~wanted ~context t =
- let rec find subst metasenv ugraph context w t =
- try
- let subst,metasenv,ugraph =
- CicUnification.fo_unif_subst subst context metasenv w t ugraph
- in
- subst,metasenv,ugraph,[context,t]
- with
- CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- match t with
- | Cic.Sort _
- | Cic.Rel _ -> subst,metasenv,ugraph,[]
- | Cic.Meta (_, ctx) ->
- List.fold_left (
- fun (subst,metasenv,ugraph,acc) e ->
- match e with
- | None -> subst,metasenv,ugraph,acc
- | Some t ->
- let subst,metasenv,ugraph,res =
- find subst metasenv ugraph context w t
- in
- subst,metasenv,ugraph, res @ acc
- ) (subst,metasenv,ugraph,[]) ctx
- | Cic.Lambda (name, t1, t2)
- | Cic.Prod (name, t1, t2) ->
- let subst,metasenv,ugraph,rest1 =
- find subst metasenv ugraph context w t1 in
- let subst,metasenv,ugraph,rest2 =
- find subst metasenv ugraph (Some (name, Cic.Decl t1)::context)
- (CicSubstitution.lift 1 w) t2
- in
- subst,metasenv,ugraph,rest1 @ rest2
- | Cic.LetIn (name, t1, t2, t3) ->
- let subst,metasenv,ugraph,rest1 =
- find subst metasenv ugraph context w t1 in
- let subst,metasenv,ugraph,rest2 =
- find subst metasenv ugraph context w t2 in
- let subst,metasenv,ugraph,rest3 =
- find subst metasenv ugraph (Some (name, Cic.Def (t1,t2))::context)
- (CicSubstitution.lift 1 w) t3
- in
- subst,metasenv,ugraph,rest1 @ rest2 @ rest3
- | Cic.Appl l ->
- List.fold_left
- (fun (subst,metasenv,ugraph,acc) t ->
- let subst,metasenv,ugraph,res =
- find subst metasenv ugraph context w t
- in
- subst,metasenv,ugraph,res @ acc)
- (subst,metasenv,ugraph,[]) l
- | Cic.Cast (t, ty) ->
- let subst,metasenv,ugraph,rest =
- find subst metasenv ugraph context w t in
- let subst,metasenv,ugraph,resty =
- find subst metasenv ugraph context w ty
- in
- subst,metasenv,ugraph,rest @ resty
- | Cic.Implicit _ -> assert false
- | Cic.Const (_, esubst)
- | Cic.Var (_, esubst)
- | Cic.MutInd (_, _, esubst)
- | Cic.MutConstruct (_, _, _, esubst) ->
- List.fold_left
- (fun (subst,metasenv,ugraph,acc) (_, t) ->
- let subst,metasenv,ugraph,res =
- find subst metasenv ugraph context w t
- in
- subst,metasenv,ugraph,res @ acc)
- (subst,metasenv,ugraph,[]) esubst
- | Cic.MutCase (_, _, outty, indterm, patterns) ->
- let subst,metasenv,ugraph,resoutty =
- find subst metasenv ugraph context w outty in
- let subst,metasenv,ugraph,resindterm =
- find subst metasenv ugraph context w indterm in
- let subst,metasenv,ugraph,respatterns =
- List.fold_left
- (fun (subst,metasenv,ugraph,acc) p ->
- let subst,metaseng,ugraph,res =
- find subst metasenv ugraph context w p
- in
- subst,metasenv,ugraph,res @ acc
- ) (subst,metasenv,ugraph,[]) patterns
- in
- subst,metasenv,ugraph,resoutty @ resindterm @ respatterns
- | Cic.Fix (_, funl) ->
- let tys =
- List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funl
- in
- List.fold_left (
- fun (subst,metasenv,ugraph,acc) (_, _, ty, bo) ->
- let subst,metasenv,ugraph,resty =
- find subst metasenv ugraph context w ty in
- let subst,metasenv,ugraph,resbo =
- find subst metasenv ugraph (tys @ context) w bo
- in
- subst,metasenv,ugraph, resty @ resbo @ acc
- ) (subst,metasenv,ugraph,[]) funl
- | Cic.CoFix (_, funl) ->
- let tys =
- List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funl
- in
- List.fold_left (
- fun (subst,metasenv,ugraph,acc) (_, ty, bo) ->
- let subst,metasenv,ugraph,resty =
- find subst metasenv ugraph context w ty in
- let subst,metasenv,ugraph,resbo =
- find subst metasenv ugraph (tys @ context) w bo
- in
- subst,metasenv,ugraph, resty @ resbo @ acc
- ) (subst,metasenv,ugraph,[]) funl
- in
- find subst metasenv ugraph context wanted t
-
-let select_in_term
- ~metasenv ~subst ~context ~ugraph ~term ~pattern:(wanted,where)
-=
- let add_ctx context name entry = (Some (name, entry)) :: context in
- let map2 error_msg f l1 l2 =
- try
- List.map2 f l1 l2
- with
- | Invalid_argument _ -> raise (Bad_pattern (lazy error_msg))
- in
- let rec aux context where term =
- match (where, term) with
- | Cic.Implicit (Some `Hole), t -> [context,t]
- | Cic.Implicit (Some `Type), t -> []
- | Cic.Implicit None,_ -> []
- | Cic.Meta (_, ctxt1), Cic.Meta (_, ctxt2) ->
- List.concat
- (map2 "wrong number of argument in explicit substitution"
- (fun t1 t2 ->
- (match (t1, t2) with
- Some t1, Some t2 -> aux context t1 t2
- | _ -> []))
- ctxt1 ctxt2)
- | Cic.Cast (te1, ty1), Cic.Cast (te2, ty2) ->
- aux context te1 te2 @ aux context ty1 ty2
- | Cic.Prod (Cic.Anonymous, s1, t1), Cic.Prod (name, s2, t2)
- | Cic.Lambda (Cic.Anonymous, s1, t1), Cic.Lambda (name, s2, t2) ->
- aux context s1 s2 @ aux (add_ctx context name (Cic.Decl s2)) t1 t2
- | Cic.Prod (Cic.Name n1, s1, t1),
- Cic.Prod ((Cic.Name n2) as name , s2, t2)
- | Cic.Lambda (Cic.Name n1, s1, t1),
- Cic.Lambda ((Cic.Name n2) as name, s2, t2) when n1 = n2->
- aux context s1 s2 @ aux (add_ctx context name (Cic.Decl s2)) t1 t2
- | Cic.Prod (name1, s1, t1), Cic.Prod (name2, s2, t2)
- | Cic.Lambda (name1, s1, t1), Cic.Lambda (name2, s2, t2) -> []
- | Cic.LetIn (Cic.Anonymous, s1, ty1, t1), Cic.LetIn (name, s2, ty2, t2) ->
- aux context s1 s2 @
- aux context ty1 ty2 @
- aux (add_ctx context name (Cic.Def (s2,ty2))) t1 t2
- | Cic.LetIn (Cic.Name n1, s1, ty1, t1),
- Cic.LetIn ((Cic.Name n2) as name, s2, ty2, t2) when n1 = n2->
- aux context s1 s2 @
- aux context ty1 ty2 @
- aux (add_ctx context name (Cic.Def (s2,ty2))) t1 t2
- | Cic.LetIn (name1, s1, ty1, t1), Cic.LetIn (name2, s2, ty2, t2) -> []
- | Cic.Appl terms1, Cic.Appl terms2 -> auxs context terms1 terms2
- | Cic.Var (_, subst1), Cic.Var (_, subst2)
- | Cic.Const (_, subst1), Cic.Const (_, subst2)
- | Cic.MutInd (_, _, subst1), Cic.MutInd (_, _, subst2)
- | Cic.MutConstruct (_, _, _, subst1), Cic.MutConstruct (_, _, _, subst2) ->
- auxs context (List.map snd subst1) (List.map snd subst2)
- | Cic.MutCase (_, _, out1, t1, pat1), Cic.MutCase (_ , _, out2, t2, pat2) ->
- aux context out1 out2 @ aux context t1 t2 @ auxs context pat1 pat2
- | Cic.Fix (_, funs1), Cic.Fix (_, funs2) ->
- let tys =
- List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs2
- in
- List.concat
- (map2 "wrong number of mutually recursive functions"
- (fun (_, _, ty1, bo1) (_, _, ty2, bo2) ->
- aux context ty1 ty2 @ aux (tys @ context) bo1 bo2)
- funs1 funs2)
- | Cic.CoFix (_, funs1), Cic.CoFix (_, funs2) ->
- let tys =
- List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs2
- in
- List.concat
- (map2 "wrong number of mutually co-recursive functions"
- (fun (_, ty1, bo1) (_, ty2, bo2) ->
- aux context ty1 ty2 @ aux (tys @ context) bo1 bo2)
- funs1 funs2)
- | x,y ->
- raise (Bad_pattern
- (lazy (Printf.sprintf "Pattern %s versus term %s"
- (CicPp.ppterm x)
- (CicPp.ppterm y))))
- and auxs context terms1 terms2 = (* as aux for list of terms *)
- List.concat (map2 "wrong number of arguments in application"
- (fun t1 t2 -> aux context t1 t2) terms1 terms2)
- in
- let roots =
- match where with
- | None -> []
- | Some where -> aux context where term
- in
- match wanted with
- None -> subst,metasenv,ugraph,roots
- | Some wanted ->
- let rec find_in_roots subst =
- function
- [] -> subst,metasenv,ugraph,[]
- | (context',where)::tl ->
- let subst,metasenv,ugraph,tl' = find_in_roots subst tl in
- let subst,metasenv,ugraph,found =
- let wanted, metasenv, ugraph = wanted context' metasenv ugraph in
- find_subterms ~subst ~metasenv ~ugraph ~wanted ~context:context'
- where
- in
- subst,metasenv,ugraph,found @ tl'
- in
- find_in_roots subst roots
-;;
-
-(** create a pattern from a term and a list of subterms.
-* the pattern is granted to have a ? for every subterm that has no selected
-* subterms
-* @param equality equality function used while walking the term. Defaults to
-* physical equality (==) *)
-let pattern_of ?(equality=(==)) ~term terms =
- let (===) x y = equality x y in
- let not_found = false, Cic.Implicit None in
- let rec aux t =
- match t with
- | t when List.exists (fun t' -> t === t') terms ->
- true,Cic.Implicit (Some `Hole)
- | Cic.Var (uri, subst) ->
- let b,subst = aux_subst subst in
- if b then
- true,Cic.Var (uri, subst)
- else
- not_found
- | Cic.Meta (i, ctxt) ->
- let b,ctxt =
- List.fold_right
- (fun e (b,ctxt) ->
- match e with
- None -> b,None::ctxt
- | Some t -> let bt,t = aux t in b||bt ,Some t::ctxt
- ) ctxt (false,[])
- in
- if b then
- true,Cic.Meta (i, ctxt)
- else
- not_found
- | Cic.Cast (te, ty) ->
- let b1,te = aux te in
- let b2,ty = aux ty in
- if b1||b2 then true,Cic.Cast (te, ty)
- else
- not_found
- | Cic.Prod (_, s, t) ->
- let b1,s = aux s in
- let b2,t = aux t in
- if b1||b2 then
- true, Cic.Prod (Cic.Anonymous, s, t)
- else
- not_found
- | Cic.Lambda (_, s, t) ->
- let b1,s = aux s in
- let b2,t = aux t in
- if b1||b2 then
- true, Cic.Lambda (Cic.Anonymous, s, t)
- else
- not_found
- | Cic.LetIn (_, s, ty, t) ->
- let b1,s = aux s in
- let b2,ty = aux ty in
- let b3,t = aux t in
- if b1||b2||b3 then
- true, Cic.LetIn (Cic.Anonymous, s, ty, t)
- else
- not_found
- | Cic.Appl terms ->
- let b,terms =
- List.fold_right
- (fun t (b,terms) ->
- let bt,t = aux t in
- b||bt,t::terms
- ) terms (false,[])
- in
- if b then
- true,Cic.Appl terms
- else
- not_found
- | Cic.Const (uri, subst) ->
- let b,subst = aux_subst subst in
- if b then
- true, Cic.Const (uri, subst)
- else
- not_found
- | Cic.MutInd (uri, tyno, subst) ->
- let b,subst = aux_subst subst in
- if b then
- true, Cic.MutInd (uri, tyno, subst)
- else
- not_found
- | Cic.MutConstruct (uri, tyno, consno, subst) ->
- let b,subst = aux_subst subst in
- if b then
- true, Cic.MutConstruct (uri, tyno, consno, subst)
- else
- not_found
- | Cic.MutCase (uri, tyno, outty, t, pat) ->
- let b1,outty = aux outty in
- let b2,t = aux t in
- let b3,pat =
- List.fold_right
- (fun t (b,pat) ->
- let bt,t = aux t in
- bt||b,t::pat
- ) pat (false,[])
- in
- if b1 || b2 || b3 then
- true, Cic.MutCase (uri, tyno, outty, t, pat)
- else
- not_found
- | Cic.Fix (funno, funs) ->
- let b,funs =
- List.fold_right
- (fun (name, i, ty, bo) (b,funs) ->
- let b1,ty = aux ty in
- let b2,bo = aux bo in
- b||b1||b2, (name, i, ty, bo)::funs) funs (false,[])
- in
- if b then
- true, Cic.Fix (funno, funs)
- else
- not_found
- | Cic.CoFix (funno, funs) ->
- let b,funs =
- List.fold_right
- (fun (name, ty, bo) (b,funs) ->
- let b1,ty = aux ty in
- let b2,bo = aux bo in
- b||b1||b2, (name, ty, bo)::funs) funs (false,[])
- in
- if b then
- true, Cic.CoFix (funno, funs)
- else
- not_found
- | Cic.Rel _
- | Cic.Sort _
- | Cic.Implicit _ -> not_found
- and aux_subst subst =
- List.fold_right
- (fun (uri, t) (b,subst) ->
- let b1,t = aux t in
- b||b1,(uri, t)::subst) subst (false,[])
- in
- snd (aux term)
-
-exception Fail of string Lazy.t
-
- (** select metasenv conjecture pattern
- * select all subterms of [conjecture] matching [pattern].
- * It returns the set of matched terms (that can be compared using physical
- * equality to the subterms of [conjecture]) together with their contexts.
- * The representation of the set mimics the ProofEngineTypes.pattern type:
- * a list of hypothesis (names of) together with the list of its matched
- * subterms (and their contexts) + the list of matched subterms of the
- * with their context conclusion. Note: in the result the list of hypothesis
- * has an entry for each entry in the context and in the same order.
- * Of course the list of terms (with their context) associated to the
- * hypothesis name may be empty.
- *
- * @raise Bad_pattern
- * *)
- let select ~metasenv ~subst ~ugraph ~conjecture:(_,context,ty)
- ~(pattern: (Cic.term, Cic.lazy_term) ProofEngineTypes.pattern)
- =
- let what, hyp_patterns, goal_pattern = pattern in
- let find_pattern_for name =
- try Some (snd (List.find (fun (n, pat) -> Cic.Name n = name) hyp_patterns))
- with Not_found -> None in
- (* Multiple hypotheses with the same name can be in the context.
- In this case we need to pick the last one, but we will perform
- a fold_right on the context. Thus we pre-process hyp_patterns. *)
- let full_hyp_pattern =
- let rec aux blacklist =
- function
- [] -> []
- | None::tl -> None::aux blacklist tl
- | Some (name,_)::tl ->
- if List.mem name blacklist then
- None::aux blacklist tl
- else
- find_pattern_for name::aux (name::blacklist) tl
- in
- aux [] context
- in
- let subst,metasenv,ugraph,ty_terms =
- select_in_term ~metasenv ~subst ~context ~ugraph ~term:ty
- ~pattern:(what,goal_pattern)
- in
- let subst,metasenv,ugraph,context_terms =
- let subst,metasenv,ugraph,res,_ =
- (List.fold_right
- (fun (pattern,entry) (subst,metasenv,ugraph,res,context) ->
- match entry with
- None -> subst,metasenv,ugraph,None::res,None::context
- | Some (name,Cic.Decl term) ->
- (match pattern with
- | None ->
- subst,metasenv,ugraph,((Some (`Decl []))::res),(entry::context)
- | Some pat ->
- let subst,metasenv,ugraph,terms =
- select_in_term ~subst ~metasenv ~context ~ugraph ~term
- ~pattern:(what, Some pat)
- in
- subst,metasenv,ugraph,((Some (`Decl terms))::res),
- (entry::context))
- | Some (name,Cic.Def (bo, ty)) ->
- (match pattern with
- | None ->
- let selected_ty = [] in
- subst,metasenv,ugraph,((Some (`Def ([],selected_ty)))::res),
- (entry::context)
- | Some pat ->
- let subst,metasenv,ugraph,terms_bo =
- select_in_term ~subst ~metasenv ~context ~ugraph ~term:bo
- ~pattern:(what, Some pat) in
- let subst,metasenv,ugraph,terms_ty =
- let subst,metasenv,ugraph,res =
- select_in_term ~subst ~metasenv ~context ~ugraph ~term:ty
- ~pattern:(what, Some pat)
- in
- subst,metasenv,ugraph,res
- in
- subst,metasenv,ugraph,((Some (`Def (terms_bo,terms_ty)))::res),
- (entry::context))
- ) (List.combine full_hyp_pattern context) (subst,metasenv,ugraph,[],[]))
- in
- subst,metasenv,ugraph,res
- in
- subst,metasenv,ugraph,context_terms, ty_terms
-;;
-
-(** locate_in_term equality what where context
-* [what] must match a subterm of [where] according to [equality]
-* It returns the matched terms together with their contexts in [where]
-* [equality] defaults to physical equality
-* [context] must be the context of [where]
-*)
-let locate_in_term ?(equality=(fun _ -> (==))) what ~where context =
- let add_ctx context name entry =
- (Some (name, entry)) :: context in
- let rec aux context where =
- if equality context what where then [context,where]
- else
- match where with
- | Cic.Implicit _
- | Cic.Meta _
- | Cic.Rel _
- | Cic.Sort _
- | Cic.Var _
- | Cic.Const _
- | Cic.MutInd _
- | Cic.MutConstruct _ -> []
- | Cic.Cast (te, ty) -> aux context te @ aux context ty
- | Cic.Prod (name, s, t)
- | Cic.Lambda (name, s, t) ->
- aux context s @ aux (add_ctx context name (Cic.Decl s)) t
- | Cic.LetIn (name, s, ty, t) ->
- aux context s @
- aux context ty @
- aux (add_ctx context name (Cic.Def (s,ty))) t
- | Cic.Appl tl -> auxs context tl
- | Cic.MutCase (_, _, out, t, pat) ->
- aux context out @ aux context t @ auxs context pat
- | Cic.Fix (_, funs) ->
- let tys =
- List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs
- in
- List.concat
- (List.map
- (fun (_, _, ty, bo) ->
- aux context ty @ aux (tys @ context) bo)
- funs)
- | Cic.CoFix (_, funs) ->
- let tys =
- List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs
- in
- List.concat
- (List.map
- (fun (_, ty, bo) ->
- aux context ty @ aux (tys @ context) bo)
- funs)
- and auxs context tl = (* as aux for list of terms *)
- List.concat (List.map (fun t -> aux context t) tl)
- in
- aux context where
-
-(** locate_in_conjecture equality what where context
-* [what] must match a subterm of [where] according to [equality]
-* It returns the matched terms together with their contexts in [where]
-* [equality] defaults to physical equality
-* [context] must be the context of [where]
-*)
-let locate_in_conjecture ?(equality=fun _ -> (==)) what (_,context,ty) =
- let context,res =
- List.fold_right
- (fun entry (context,res) ->
- match entry with
- None -> entry::context, res
- | Some (_, Cic.Decl ty) ->
- let res = res @ locate_in_term what ~where:ty context in
- let context' = entry::context in
- context',res
- | Some (_, Cic.Def (bo,ty)) ->
- let res = res @ locate_in_term what ~where:bo context in
- let res = res @ locate_in_term what ~where:ty context in
- let context' = entry::context in
- context',res
- ) context ([],[])
- in
- res @ locate_in_term what ~where:ty context
-
-let lookup_type metasenv context hyp =
- let rec aux p = function
- | Some (Cic.Name name, Cic.Decl t) :: _ when name = hyp -> p, t
- | Some (Cic.Name name, Cic.Def (_,t)) :: _ when name = hyp -> p, t
- | _ :: tail -> aux (succ p) tail
- | [] -> raise (ProofEngineTypes.Fail (lazy "lookup_type: not premise in the current goal"))
- in
- aux 1 context
-
-let find_hyp name =
- let rec find_hyp n =
- function
- [] -> assert false
- | Some (Cic.Name s,Cic.Decl ty)::_ when name = s ->
- Cic.Rel n, CicSubstitution.lift n ty
- | Some (Cic.Name s,Cic.Def _)::_ when name = s -> assert false (*CSC: not implemented yet! But does this make any sense?*)
- | _::tl -> find_hyp (n+1) tl
- in
- find_hyp 1
-;;
-
-(* sort pattern hypotheses from the smallest to the highest Rel *)
-let sort_pattern_hyps context (t,hpatterns,cpattern) =
- let hpatterns =
- List.sort
- (fun (id1,_) (id2,_) ->
- let t1,_ = find_hyp id1 context in
- let t2,_ = find_hyp id2 context in
- match t1,t2 with
- Cic.Rel n1, Cic.Rel n2 -> compare n1 n2
- | _,_ -> assert false) hpatterns
- in
- t,hpatterns,cpattern
-;;
-
-(* FG: **********************************************************************)
-
-let get_name context index =
- try match List.nth context (pred index) with
- | Some (Cic.Name name, _) -> Some name
- | _ -> None
- with Invalid_argument "List.nth" -> None
-
-let get_rel context name =
- let rec aux i = function
- | [] -> None
- | Some (Cic.Name s, _) :: _ when s = name -> Some (Cic.Rel i)
- | _ :: tl -> aux (succ i) tl
- in
- aux 1 context
-
-let split_with_whd (c, t) =
- let add s v c = Some (s, Cic.Decl v) :: c in
- let rec aux whd a n c = function
- | Cic.Prod (s, v, t) -> aux false ((c, v) :: a) (succ n) (add s v c) t
- | v when whd -> (c, v) :: a, n
- | v -> aux true a n c (CicReduction.whd c v)
- in
- aux false [] 0 c t
-
-let split_with_normalize (c, t) =
- let add s v c = Some (s, Cic.Decl v) :: c in
- let rec aux a n c = function
- | Cic.Prod (s, v, t) -> aux ((c, v) :: a) (succ n) (add s v c) t
- | v -> (c, v) :: a, n
- in
- aux [] 0 c (CicReduction.normalize c t)
-
- (* menv sorting *)
-module OT =
- struct
- type t = Cic.conjecture
- let compare (i,_,_) (j,_,_) = Pervasives.compare i j
- end
-module MS = HTopoSort.Make(OT)
-let relations_of_menv m c =
- let i, ctx, ty = c in
- let m = List.filter (fun (j,_,_) -> j <> i) m in
- let m_ty = List.map fst (CicUtil.metas_of_term ty) in
- let m_ctx =
- List.flatten
- (List.map
- (function
- | None -> []
- | Some (_,Cic.Decl t) ->
- List.map fst (CicUtil.metas_of_term ty)
- | Some (_,Cic.Def (t,ty)) ->
- List.map fst (CicUtil.metas_of_term ty) @
- List.map fst (CicUtil.metas_of_term t))
- ctx)
- in
- let metas = HExtlib.list_uniq (List.sort compare (m_ty @ m_ctx)) in
- List.filter (fun (i,_,_) -> List.exists ((=) i) metas) m
-;;
-let sort_metasenv (m : Cic.metasenv) =
- (MS.topological_sort m (relations_of_menv m) : Cic.metasenv)
-;;
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Bad_pattern of string Lazy.t
-
-(* Returns the first meta whose number is above the *)
-(* number of the higher meta. *)
-val new_meta_of_proof : proof:ProofEngineTypes.proof -> int
-
-val subst_meta_in_proof :
- ProofEngineTypes.proof ->
- int -> Cic.term -> Cic.metasenv ->
- ProofEngineTypes.proof * Cic.metasenv
-val subst_meta_and_metasenv_in_proof :
- ProofEngineTypes.proof ->
- int -> Cic.substitution -> Cic.metasenv ->
- ProofEngineTypes.proof * Cic.metasenv
-
-(* returns the list of goals that are in newmetasenv and were not in
- oldmetasenv *)
-val compare_metasenvs :
- oldmetasenv:Cic.metasenv -> newmetasenv:Cic.metasenv -> int list
-
-
-(** { Patterns }
- * A pattern is a Cic term in which Cic.Implicit terms annotated with `Hole
- * appears *)
-
-(** create a pattern from a term and a list of subterms.
-* the pattern is granted to have a ? for every subterm that has no selected
-* subterms
-* @param equality equality function used while walking the term. Defaults to
-* physical equality (==) *)
-val pattern_of:
- ?equality:(Cic.term -> Cic.term -> bool) -> term:Cic.term -> Cic.term list ->
- Cic.term
-
-
-(** select metasenv conjecture pattern
-* select all subterms of [conjecture] matching [pattern].
-* It returns the set of matched terms (that can be compared using physical
-* equality to the subterms of [conjecture]) together with their contexts.
-* The representation of the set mimics the conjecture type (but for the id):
-* a list of (possibly removed) hypothesis (without their names) together with
-* the list of its matched subterms (and their contexts) + the list of matched
-* subterms of the conclusion with their context. Note: in the result the list
-* of hypotheses * has an entry for each entry in the context and in the same
-* order. Of course the list of terms (with their context) associated to one
-* hypothesis may be empty.
-*
-* @raise Bad_pattern
-* *)
-val select:
- metasenv:Cic.metasenv ->
- subst:Cic.substitution ->
- ugraph:CicUniv.universe_graph ->
- conjecture:Cic.conjecture ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.substitution * Cic.metasenv * CicUniv.universe_graph *
- [ `Decl of (Cic.context * Cic.term) list
- | `Def of (Cic.context * Cic.term) list * (Cic.context * Cic.term) list
- ] option list *
- (Cic.context * Cic.term) list
-
-(** locate_in_term equality what where context
-* [what] must match a subterm of [where] according to [equality]
-* It returns the matched terms together with their contexts in [where]
-* [equality] defaults to physical equality
-* [context] must be the context of [where]
-*)
-val locate_in_term:
- ?equality:(Cic.context -> Cic.term -> Cic.term -> bool) ->
- Cic.term -> where:Cic.term -> Cic.context -> (Cic.context * Cic.term) list
-
-(** locate_in_conjecture equality what where context
-* [what] must match a subterm of [where] according to [equality]
-* It returns the matched terms together with their contexts in [where]
-* [equality] defaults to physical equality
-* [context] must be the context of [where]
-*)
-val locate_in_conjecture:
- ?equality:(Cic.context -> Cic.term -> Cic.term -> bool) ->
- Cic.term -> Cic.conjecture -> (Cic.context * Cic.term) list
-
-(* returns the index and the type of a premise in a context *)
-val lookup_type: Cic.metasenv -> Cic.context -> string -> int * Cic.term
-
-(* orders a metasenv w.r.t. dependency among metas *)
-val sort_metasenv: Cic.metasenv -> Cic.metasenv
-
-(* finds an hypothesis by name in the context *)
-val find_hyp: string -> Cic.context -> Cic.term * Cic.term
-
-(* sort pattern hypotheses from the smallest to the highest Rel *)
-val sort_pattern_hyps:
- Cic.context -> ProofEngineTypes.lazy_pattern -> ProofEngineTypes.lazy_pattern
-
-
-(* FG: some helper functions ************************************************)
-
-val get_name: Cic.context -> int -> string option
-
-val get_rel: Cic.context -> string -> Cic.term option
-
-(* split_with_whd (c, t) takes a type t typed in the context c and returns
- [(c_0, t_0); (c_1, t_1); ...; (c_n, t_n)], n where t_0 is the conclusion of
- t and t_i is the premise of t accessed by Rel i in t_0.
- Performes a whd on the conclusion before giving up.
- Each t_i is returned with a context c_i in wich it is typed
- split_with_normalize (c, t) normalizes t before operating the split
- whd is useless here
-*)
-val split_with_whd: Cic.context * Cic.term ->
- (Cic.context * Cic.term) list * int
-val split_with_normalize: Cic.context * Cic.term ->
- (Cic.context * Cic.term) list * int
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 12/04/2002 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-(* $Id$ *)
-
-(* The code of this module is derived from the code of CicReduction *)
-
-exception Impossible of int;;
-exception ReferenceToConstant;;
-exception ReferenceToVariable;;
-exception ReferenceToCurrentProof;;
-exception ReferenceToInductiveDefinition;;
-exception WrongUriToInductiveDefinition;;
-exception WrongUriToConstant;;
-exception RelToHiddenHypothesis;;
-
-module C = Cic
-module S = CicSubstitution
-
-let debug = false
-let prerr_endline =
- if debug then prerr_endline else (fun x -> ())
-;;
-
-exception WhatAndWithWhatDoNotHaveTheSameLength;;
-
-(* Replaces "textually" in "where" every term in "what" with the corresponding
- term in "with_what". The terms in "what" ARE NOT lifted when binders are
- crossed. The terms in "with_what" ARE NOT lifted when binders are crossed.
- Every free variable in "where" IS NOT lifted by nnn.
-*)
-let replace ~equality ~what ~with_what ~where =
- let find_image t =
- let rec find_image_aux =
- function
- [],[] -> raise Not_found
- | what::tl1,with_what::tl2 ->
- if equality what t then with_what else find_image_aux (tl1,tl2)
- | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
- in
- find_image_aux (what,with_what)
- in
- let rec aux t =
- try
- find_image t
- with Not_found ->
- match t with
- C.Rel _ -> t
- | C.Var (uri,exp_named_subst) ->
- C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.Meta _ -> t
- | C.Sort _ -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
- | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
- | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
- | C.LetIn (n,s,ty,t) -> C.LetIn (n, aux s, aux ty, aux t)
- | C.Appl l ->
- (* Invariant enforced: no application of an application *)
- (match List.map aux l with
- (C.Appl l')::tl -> C.Appl (l'@tl)
- | l' -> C.Appl l')
- | C.Const (uri,exp_named_subst) ->
- C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.MutInd (uri,i,exp_named_subst) ->
- C.MutInd
- (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- C.MutConstruct
- (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
- | C.Fix (i,fl) ->
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux ty, aux bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- aux where
-;;
-
-(* Replaces in "where" every term in "what" with the corresponding
- term in "with_what". The terms in "what" ARE lifted when binders are
- crossed. The terms in "with_what" ARE lifted when binders are crossed.
- Every free variable in "where" IS NOT lifted by nnn.
- Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the
- inverse of subst up to the fact that free variables in "where" are NOT
- lifted. *)
-let replace_lifting ~equality ~context ~what ~with_what ~where =
- let find_image ctx what t =
- let rec find_image_aux =
- function
- [],[] -> raise Not_found
- | what::tl1,with_what::tl2 ->
- if equality ctx what t then with_what else find_image_aux (tl1,tl2)
- | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
- in
- find_image_aux (what,with_what)
- in
- let add_ctx ctx n s = (Some (n, Cic.Decl s))::ctx in
- let add_ctx1 ctx n s ty = (Some (n, Cic.Def (s,ty)))::ctx in
- let rec substaux k ctx what t =
- try
- S.lift (k-1) (find_image ctx what t)
- with Not_found ->
- match t with
- C.Rel n as t -> t
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k ctx what t) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i, l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k ctx what t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k ctx what te, substaux k ctx what ty)
- | C.Prod (n,s,t) ->
- C.Prod
- (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (S.lift 1) what) t)
- | C.Lambda (n,s,t) ->
- C.Lambda
- (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (S.lift 1) what) t)
- | C.LetIn (n,s,ty,t) ->
- C.LetIn
- (n, substaux k ctx what s, substaux k ctx what ty, substaux (k + 1) (add_ctx1 ctx n s ty) (List.map (S.lift 1) what) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k ctx what) tl in
- begin
- match substaux k ctx what he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k ctx what t) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k ctx what t) exp_named_subst
- in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k ctx what t) exp_named_subst
- in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,substaux k ctx what outt, substaux k ctx what t,
- List.map (substaux k ctx what) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (* WRONG CTX *)
- (name, i, substaux k ctx what ty,
- substaux (k+len) ctx (List.map (S.lift len) what) bo)
- ) fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (* WRONG CTX *)
- (name, substaux k ctx what ty,
- substaux (k+len) ctx (List.map (S.lift len) what) bo)
- ) fl
- in
- C.CoFix (i, substitutedfl)
- in
- substaux 1 context what where
-;;
-
-(* Replaces in "where" every term in "what" with the corresponding
- term in "with_what". The terms in "what" ARE NOT lifted when binders are
- crossed. The terms in "with_what" ARE lifted when binders are crossed.
- Every free variable in "where" IS lifted by nnn.
- Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the
- inverse of subst up to the fact that "what" terms are NOT lifted. *)
-let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
- let find_image t =
- let rec find_image_aux =
- function
- [],[] -> raise Not_found
- | what::tl1,with_what::tl2 ->
- if equality what t then with_what else find_image_aux (tl1,tl2)
- | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
- in
- find_image_aux (what,with_what)
- in
- let rec substaux k t =
- try
- S.lift (k-1) (find_image t)
- with Not_found ->
- match t with
- C.Rel n ->
- if n < k then C.Rel n else C.Rel (n + nnn)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i, l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
- | C.Prod (n,s,t) ->
- C.Prod (n, substaux k s, substaux (k + 1) t)
- | C.Lambda (n,s,t) ->
- C.Lambda (n, substaux k s, substaux (k + 1) t)
- | C.LetIn (n,s,ty,t) ->
- C.LetIn (n, substaux k s, substaux k ty, substaux (k + 1) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k) tl in
- begin
- match substaux k he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,substaux k outt, substaux k t,
- List.map (substaux k) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) ->
- (name, i, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) ->
- (name, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- substaux 1 where
-;;
-
-(* This is like "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]"
- up to the fact that the index to start from can be specified *)
-let replace_with_rel_1_from ~equality ~what =
- let rec find_image t = function
- | [] -> false
- | hd :: tl -> equality t hd || find_image t tl
- in
- let rec subst_term k t =
- if find_image t what then C.Rel k else inspect_term k t
- and inspect_term k = function
- | C.Rel i -> if i < k then C.Rel i else C.Rel (succ i)
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Var (uri, enss) ->
- let enss = List.map (subst_ens k) enss in
- C.Var (uri, enss)
- | C.Const (uri ,enss) ->
- let enss = List.map (subst_ens k) enss in
- C.Const (uri, enss)
- | C.MutInd (uri, tyno, enss) ->
- let enss = List.map (subst_ens k) enss in
- C.MutInd (uri, tyno, enss)
- | C.MutConstruct (uri, tyno, consno, enss) ->
- let enss = List.map (subst_ens k) enss in
- C.MutConstruct (uri, tyno, consno, enss)
- | C.Meta (i, mss) ->
- let mss = List.map (subst_ms k) mss in
- C.Meta(i, mss)
- | C.Cast (t, v) -> C.Cast (subst_term k t, subst_term k v)
- | C.Appl ts ->
- let ts = List.map (subst_term k) ts in
- C.Appl ts
- | C.MutCase (uri, tyno, outty, t, cases) ->
- let cases = List.map (subst_term k) cases in
- C.MutCase (uri, tyno, subst_term k outty, subst_term k t, cases)
- | C.Prod (n, v, t) ->
- C.Prod (n, subst_term k v, subst_term (succ k) t)
- | C.Lambda (n, v, t) ->
- C.Lambda (n, subst_term k v, subst_term (succ k) t)
- | C.LetIn (n, v, ty, t) ->
- C.LetIn (n, subst_term k v, subst_term k ty, subst_term (succ k) t)
- | C.Fix (i, fixes) ->
- let fixesno = List.length fixes in
- let fixes = List.map (subst_fix fixesno k) fixes in
- C.Fix (i, fixes)
- | C.CoFix (i, cofixes) ->
- let cofixesno = List.length cofixes in
- let cofixes = List.map (subst_cofix cofixesno k) cofixes in
- C.CoFix (i, cofixes)
- and subst_ens k (uri, t) = uri, subst_term k t
- and subst_ms k = function
- | None -> None
- | Some t -> Some (subst_term k t)
- and subst_fix fixesno k (n, ind, ty, bo) =
- n, ind, subst_term k ty, subst_term (k + fixesno) bo
- and subst_cofix cofixesno k (n, ty, bo) =
- n, subst_term k ty, subst_term (k + cofixesno) bo
-in
-subst_term
-
-let unfold ?what context where =
- let contextlen = List.length context in
- let first_is_the_expandable_head_of_second context' t1 t2 =
- match t1,t2 with
- Cic.Const (uri,_), Cic.Const (uri',_)
- | Cic.Var (uri,_), Cic.Var (uri',_)
- | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_)
- | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri'
- | Cic.Const _, _
- | Cic.Var _, _ -> false
- | Cic.Rel n, Cic.Rel m
- | Cic.Rel n, Cic.Appl (Cic.Rel m::_) ->
- n + (List.length context' - contextlen) = m
- | Cic.Rel _, _ -> false
- | _,_ ->
- raise
- (ProofEngineTypes.Fail
- (lazy "The term to unfold is not a constant, a variable or a bound variable "))
- in
- let appl he tl =
- if tl = [] then he else Cic.Appl (he::tl) in
- let cannot_delta_expand t =
- raise
- (ProofEngineTypes.Fail
- (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in
- let rec hd_delta_beta context tl =
- function
- Cic.Rel n as t ->
- (try
- match List.nth context (n-1) with
- Some (_,Cic.Decl _) -> cannot_delta_expand t
- | Some (_,Cic.Def (bo,_)) ->
- CicReduction.head_beta_reduce
- (appl (CicSubstitution.lift n bo) tl)
- | None -> raise RelToHiddenHypothesis
- with
- Failure _ -> assert false)
- | Cic.Const (uri,exp_named_subst) as t ->
- let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- (match o with
- Cic.Constant (_,Some body,_,_,_) ->
- CicReduction.head_beta_reduce
- (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
- | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t
- | Cic.Variable _ -> raise ReferenceToVariable
- | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
- | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | Cic.Var (uri,exp_named_subst) as t ->
- let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- (match o with
- Cic.Constant _ -> raise ReferenceToConstant
- | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
- | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | Cic.Variable (_,Some body,_,_,_) ->
- CicReduction.head_beta_reduce
- (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
- | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t
- )
- | Cic.Appl [] -> assert false
- | Cic.Appl (he::tl) -> hd_delta_beta context tl he
- | t -> cannot_delta_expand t
- in
- let context_and_matched_term_list =
- match what with
- None -> [context, where]
- | Some what ->
- let res =
- ProofEngineHelpers.locate_in_term
- ~equality:first_is_the_expandable_head_of_second
- what ~where context
- in
- if res = [] then
- raise
- (ProofEngineTypes.Fail
- (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where)))
- else
- res
- in
- let reduced_terms =
- List.map
- (function (context,where) -> hd_delta_beta context [] where)
- context_and_matched_term_list in
- let whats = List.map snd context_and_matched_term_list in
- replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where
-;;
-
-exception WrongShape;;
-exception AlreadySimplified;;
-
-(* Takes a well-typed term and *)
-(* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
-(* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
-(* w.r.t. zero or more variables and if the Fix can be reductaed, than it*)
-(* is reduced, the delta-reduction is succesfull and the whole algorithm *)
-(* is applied again to the new redex; Step 3.1) is applied to the result *)
-(* of the recursive simplification. Otherwise, if the Fix can not be *)
-(* reduced, than the delta-reductions fails and the delta-redex is *)
-(* not reduced. Otherwise, if the delta-residual is not the *)
-(* lambda-abstraction of a Fix, then it performs step 3.2). *)
-(* 3.1) Folds the application of the constant to the arguments that did not *)
-(* change in every iteration, i.e. to the actual arguments for the *)
-(* lambda-abstractions that precede the Fix. *)
-(* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *)
-(* reductions. If the reduction cannot be performed, it returns the *)
-(* original term (not the head beta-zeta normal form of the definiendum) *)
-(*CSC: It does not perform simplification in a Case *)
-
-let simpl context =
- (* a simplified term is active if it can create a redex when used as an *)
- (* actual parameter *)
- let rec is_active =
- function
- C.Lambda _
- | C.MutConstruct _
- | C.Appl (C.MutConstruct _::_)
- | C.CoFix _ -> true
- | C.Cast (bo,_) -> is_active bo
- | C.LetIn _ -> assert false
- | _ -> false
- in
- (* reduceaux is equal to the reduceaux locally defined inside *)
- (* reduce, but for the const case. *)
- (**** Step 1 ****)
- let rec reduceaux context l =
- function
- C.Rel n as t ->
- (* we never perform delta expansion automatically *)
- if l = [] then t else C.Appl (t::l)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- (let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_,_,_) ->
- let t' = C.Var (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Variable (_,Some body,_,_,_) ->
- reduceaux context l
- (CicSubstitution.subst_vars exp_named_subst' body)
- )
- | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
- | C.Sort _ as t -> t (* l should be empty *)
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) ->
- C.Cast (reduceaux context l te, reduceaux context [] ty)
- | C.Prod (name,s,t) ->
- assert (l = []) ;
- C.Prod (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | C.Lambda (name,s,t) ->
- (match l with
- [] ->
- C.Lambda (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | he::tl -> reduceaux context tl (S.subst he t)
- (* when name is Anonimous the substitution should be superfluous *)
- )
- | C.LetIn (n,s,ty,t) ->
- reduceaux context l (S.subst (reduceaux context [] s) t)
- | C.Appl (he::tl) ->
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context (tl'@l) he
- | C.Appl [] -> raise (Impossible 1)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- (let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in
- match o with
- C.Constant (_,Some body,_,_,_) ->
- if List.exists is_active l then
- try_delta_expansion context l
- (C.Const (uri,exp_named_subst'))
- (CicSubstitution.subst_vars exp_named_subst' body)
- else
- let t' = C.Const (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Constant (_,None,_,_,_) ->
- let t' = C.Const (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_,_,_) -> reduceaux context l body
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- let t' = C.MutInd (uri,i,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.MutCase (mutind,i,outtype,term,pl) ->
- let decofix =
- function
- C.CoFix (i,fl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduceaux context [] body'
- | C.Appl (C.CoFix (i,fl) :: tl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context tl' body'
- | t -> t
- in
- (match decofix (reduceaux context [] term) (*(CicReduction.whd context term)*) with
- C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
- | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
- let (arity, r) =
- let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph mutind in
- match o with
- C.InductiveDefinition (tl,ingredients,r,_) ->
- let (_,_,arity,_) = List.nth tl i in
- (arity,r)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (r,tl)
- in
- reduceaux context (ts@l) (List.nth pl (j-1))
- | C.Cast _ | C.Implicit _ ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ ->
- let outtype' = reduceaux context [] outtype in
- let term' = reduceaux context [] term in
- let pl' = List.map (reduceaux context []) pl in
- let res =
- C.MutCase (mutind,i,outtype',term',pl')
- in
- if l = [] then res else C.Appl (res::l)
- )
- | C.Fix (i,fl) ->
- let tys,_ =
- List.fold_left
- (fun (types,len) (n,_,ty,_) ->
- (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
- len+1)
- ) ([],0) fl
- in
- let t' () =
- let fl' =
- List.map
- (function (n,recindex,ty,bo) ->
- (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.Fix (i, fl')
- in
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (List.nth l recindex)
- with
- _ -> None
- in
- (match recparam with
- Some recparam ->
- (match reduceaux context [] recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
- fl
- body
- in
- (* Possible optimization: substituting whd recparam in l*)
- reduceaux context l body'
- | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | None -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | C.CoFix (i,fl) ->
- let tys,_ =
- List.fold_left
- (fun (types,len) (n,ty,_) ->
- (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
- len+1)
- ) ([],0) fl
- in
- let t' =
- let fl' =
- List.map
- (function (n,ty,bo) ->
- (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.CoFix (i, fl')
- in
- if l = [] then t' else C.Appl (t'::l)
- and reduceaux_exp_named_subst context l =
- List.map (function uri,t -> uri,reduceaux context [] t)
- (**** Step 2 ****)
- and reduce_with_no_hope_to_fold_back t l =
- prerr_endline "reduce_with_no_hope_to_fold_back";
- let simplified = reduceaux context l t in
- let t' = if l = [] then t else C.Appl (t::l) in
- if t' = simplified then
- raise AlreadySimplified
- else
- simplified
-
- and try_delta_expansion context l term body =
- try
- let res,constant_args =
- let rec aux rev_constant_args l =
- function
- C.Lambda (name,s,t) ->
- begin
- match l with
- [] -> raise WrongShape
- | he::tl ->
- (* when name is Anonimous the substitution should *)
- (* be superfluous *)
- aux (he::rev_constant_args) tl (S.subst he t)
- end
- | C.LetIn (_,s,_,t) ->
- aux rev_constant_args l (S.subst s t)
- | C.Fix (i,fl) ->
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- List.nth l recindex
- with
- _ -> raise AlreadySimplified
- in
- (match reduceaux context [] recparam (*CicReduction.whd context recparam*) with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (function _ ->
- decr counter ; S.subst (C.Fix (!counter,fl))
- ) fl body
- in
- (* Possible optimization: substituting whd *)
- (* recparam in l *)
- reduceaux context l body',
- List.rev rev_constant_args
- | _ -> raise AlreadySimplified
- )
- | _ -> raise WrongShape
- in
- aux [] l body
- in
- (**** Step 3.1 ****)
- let term_to_fold, delta_expanded_term_to_fold =
- match constant_args with
- [] -> term,body
- | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
- in
- let simplified_term_to_fold =
- reduceaux context [] delta_expanded_term_to_fold
- in
- replace_lifting ~equality:(fun _ x y -> x = y) ~context
- ~what:[simplified_term_to_fold] ~with_what:[term_to_fold] ~where:res
- with
- WrongShape ->
- let rec skip_lambda n = function
- | Cic.Lambda (_,_,t) -> skip_lambda (n+1) t | t -> t, n
- in
- let is_fix uri =
- match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with
- | Cic.Constant (_,Some bo, _, _,_) ->
- (let t, _ = skip_lambda 0 bo in
- match t with | Cic.Fix _ -> true | _ -> false)
- | _ -> false
- in
- let guess_recno uri =
- prerr_endline ("GUESS: " ^ UriManager.string_of_uri uri);
- match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with
- | Cic.Constant (_,Some bo, _, _,_ ) ->
- let t, n = skip_lambda 0 bo in
- (match t with
- | Cic.Fix (i,fl) ->
- let _,recno,_,_ = List.nth fl i in
- prerr_endline ("GUESSED: " ^ string_of_int recno ^ " after " ^
- string_of_int n ^ " lambdas");
- recno + n
- | _ -> assert false)
- | _ -> assert false
- in
- let original_args = l in
- (**** Step 3.2 ****)
- let rec aux l =
- function
- | C.Lambda (name,s,t) ->
- (match l with
- | [] -> raise AlreadySimplified
- | he::tl ->
- (* when name is Anonimous the substitution should *)
- (* be superfluous *)
- aux tl (S.subst he t))
- | C.LetIn (_,s,_,t) -> aux l (S.subst s t)
- | Cic.Appl (Cic.Const (uri,_) :: args) as t when is_fix uri ->
- let recno =
- prerr_endline ("cerco : " ^ string_of_int (guess_recno uri)
- ^ " in: " ^ String.concat " "
- (List.map (fun x -> CicPp.ppterm x) args));
- prerr_endline ("e piglio il rispettivo in :"^String.concat " "
- (List.map (fun x -> CicPp.ppterm x) original_args));
- (* look for args[regno] in saved_args *)
- let wanted = List.nth (args@l) (guess_recno uri) in
- let rec aux n = function
- | [] -> n (* DA CAPIRE *)
- | t::_ when t = wanted -> n
- | _::tl -> aux (n+1) tl
- in
- aux 0 original_args
- in
- if recno = List.length original_args then
- reduce_with_no_hope_to_fold_back t l
- else
- let simplified = reduceaux context l t in
- let rec mk_implicits = function
- | n,_::tl when n = recno ->
- Cic.Implicit None :: (mk_implicits (n+1,tl))
- | n,arg::tl -> arg :: (mk_implicits (n+1,tl))
- | _,[] -> []
- in
- (* we try to fold back constant that do not expand to Fix *)
- let _ = prerr_endline
- ("INIZIO (" ^ string_of_int recno ^ ") : " ^ CicPp.ppterm
- simplified) in
- let term_to_fold =
- Cic.Appl (term:: mk_implicits (0,original_args))
- in
- (try
- let term_to_fold, _, metasenv, _ =
- CicRefine.type_of_aux' [] context term_to_fold
- CicUniv.oblivion_ugraph
- in
- let _ =
- prerr_endline ("RAFFINA: "^CicPp.ppterm term_to_fold) in
- let _ =
- prerr_endline
- ("RAFFINA: "^CicMetaSubst.ppmetasenv [] metasenv) in
- let simplified_term_to_fold = unfold context term_to_fold in
- let _ =
- prerr_endline ("SEMPLIFICA: " ^
- CicPp.ppterm simplified_term_to_fold)
- in
- let rec do_n f t =
- let t1 = f t in
- if t1 = t then t else do_n f t1
- in
- do_n
- (fun simplified ->
- let subst = ref [] in
- let myunif ctx t1 t2 =
- if !subst <> [] then false
- else
- try
- prerr_endline "MUNIF";
- prerr_endline (CicPp.ppterm t1);
- prerr_endline "VS";
- prerr_endline (CicPp.ppterm t2 ^ "\n");
- let subst1, _, _ =
- CicUnification.fo_unif metasenv ctx t1 t2
- CicUniv.oblivion_ugraph
- in
- prerr_endline "UNIFICANO\n\n\n";
- subst := subst1;
- true
- with
- | CicUnification.UnificationFailure s
- | CicUnification.Uncertain s
- | CicUnification.AssertFailure s ->
- prerr_endline (Lazy.force s); false
- | CicUtil.Meta_not_found _ -> false
- (*
- | _ as exn ->
- prerr_endline (Printexc.to_string exn);
- false*)
- in
- let t =
- replace_lifting myunif context
- [simplified_term_to_fold] [term_to_fold] simplified
- in
- let _ = prerr_endline "UNIFICA" in
- if List.length metasenv <> List.length !subst then
- let _ = prerr_endline ("SUBST CORTA " ^
- CicMetaSubst.ppsubst !subst ~metasenv)
- in
- simplified
- else
- if t = simplified then
- let _ = prerr_endline "NULLA DI FATTO" in
- simplified
- else
- let t = CicMetaSubst.apply_subst !subst t in
- prerr_endline ("ECCO: " ^ CicPp.ppterm t); t)
- simplified
- with
- | CicRefine.RefineFailure s
- | CicRefine.Uncertain s
- | CicRefine.AssertFailure s ->
- prerr_endline (Lazy.force s); simplified
- (*| exn -> prerr_endline (Printexc.to_string exn); simplified*))
- | t -> reduce_with_no_hope_to_fold_back t l
- in
- (try aux l body
- with
- AlreadySimplified ->
- if l = [] then term else C.Appl (term::l))
- | AlreadySimplified ->
- (* If we performed delta-reduction, we would find a Fix *)
- (* not applied to a constructor. So, we refuse to perform *)
- (* delta-reduction. *)
- if l = [] then term else C.Appl (term::l)
- in
- reduceaux context []
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Impossible of int
-exception ReferenceToConstant
-exception ReferenceToVariable
-exception ReferenceToCurrentProof
-exception ReferenceToInductiveDefinition
-exception WrongUriToInductiveDefinition
-exception RelToHiddenHypothesis
-exception WrongShape
-exception AlreadySimplified
-exception WhatAndWithWhatDoNotHaveTheSameLength;;
-
-(* Replaces "textually" in "where" every term in "what" with the corresponding
- term in "with_what". The terms in "what" ARE NOT lifted when binders are
- crossed. The terms in "with_what" ARE NOT lifted when binders are crossed.
- Every free variable in "where" IS NOT lifted by nnn. *)
-val replace :
- equality:('a -> Cic.term -> bool) ->
- what:'a list -> with_what:Cic.term list -> where:Cic.term -> Cic.term
-
-(* Replaces in "where" every term in "what" with the corresponding
- term in "with_what". The terms in "what" ARE lifted when binders are
- crossed. The terms in "with_what" ARE lifted when binders are crossed.
- Every free variable in "where" IS NOT lifted by nnn.
- Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the
- inverse of subst up to the fact that free variables in "where" are NOT
- lifted. *)
-val replace_lifting :
- equality:(Cic.context -> Cic.term -> Cic.term -> bool) ->
- context:Cic.context ->
- what:Cic.term list -> with_what:Cic.term list -> where:Cic.term -> Cic.term
-
-(* Replaces in "where" every term in "what" with the corresponding
- term in "with_what". The terms in "what" ARE NOT lifted when binders are
- crossed. The terms in "with_what" ARE lifted when binders are crossed.
- Every free variable in "where" IS lifted by nnn.
- Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the
- inverse of subst up to the fact that "what" terms are NOT lifted. *)
-val replace_lifting_csc :
- int -> equality:(Cic.term -> Cic.term -> bool) ->
- what:Cic.term list -> with_what:Cic.term list -> where:Cic.term -> Cic.term
-
-(* This is like "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]"
- up to the fact that the index to start from can be specified *)
-val replace_with_rel_1_from :
- equality:(Cic.term -> Cic.term -> bool) ->
- what:Cic.term list -> int -> Cic.term -> Cic.term
-val simpl : Cic.context -> Cic.term -> Cic.term
-val unfold : ?what:Cic.term -> Cic.context -> Cic.term -> Cic.term
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module PET = ProofEngineTypes
-module C = Cic
-
-let clearbody ~hyp =
- let clearbody (proof, goal) =
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,_,_ = CicUtil.lookup_meta goal metasenv in
- let string_of_name =
- function
- C.Name n -> n
- | C.Anonymous -> "_"
- in
- let metasenv' =
- List.map
- (function
- (m,canonical_context,ty) when m = metano ->
- let canonical_context' =
- List.fold_right
- (fun entry context ->
- match entry with
- Some (C.Name hyp',C.Def (term,ty)) when hyp = hyp' ->
- let cleared_entry = Some (C.Name hyp, Cic.Decl ty) in
- cleared_entry::context
- | None -> None::context
- | Some (n,C.Decl t) ->
- let _,_ =
- try
- CicTypeChecker.type_of_aux' metasenv context t
- CicUniv.oblivion_ugraph (* TASSI: FIXME *)
- with
- _ ->
- raise
- (PET.Fail
- (lazy ("The correctness of hypothesis " ^
- string_of_name n ^
- " relies on the body of " ^ hyp)
- ))
- in
- entry::context
- | Some (n,Cic.Def (te,ty)) ->
- (try
- ignore
- (CicTypeChecker.type_of_aux' metasenv context te
- CicUniv.oblivion_ugraph (* TASSI: FIXME *));
- ignore
- (CicTypeChecker.type_of_aux' metasenv context ty
- CicUniv.oblivion_ugraph (* TASSI: FIXME *));
- with
- _ ->
- raise
- (PET.Fail
- (lazy ("The correctness of hypothesis " ^
- string_of_name n ^
- " relies on the body of " ^ hyp)
- )));
- entry::context
- ) canonical_context []
- in
- let _,_ =
- try
- CicTypeChecker.type_of_aux' metasenv canonical_context' ty
- CicUniv.oblivion_ugraph (* TASSI: FIXME *)
- with
- _ ->
- raise
- (PET.Fail
- (lazy ("The correctness of the goal relies on the body of " ^
- hyp)))
- in
- m,canonical_context',ty
- | t -> t
- ) metasenv
- in
- (curi,metasenv',_subst,pbo,pty, attrs), [goal]
- in
- PET.mk_tactic clearbody
-
-let clear_one ~hyp =
- let clear_one (proof, goal) =
- let curi,metasenv,_subst,pbo,pty, attrs = proof in
- let metano,context,ty =
- CicUtil.lookup_meta goal metasenv
- in
- let string_of_name =
- function
- C.Name n -> n
- | C.Anonymous -> "_"
- in
- let metasenv' =
- List.map
- (function
- (m,canonical_context,ty) when m = metano ->
- let context_changed, canonical_context' =
- List.fold_right
- (fun entry (b, context) ->
- match entry with
- Some (Cic.Name hyp',_) when hyp' = hyp ->
- (true, None::context)
- | None -> (b, None::context)
- | Some (n,C.Decl t)
- | Some (n,Cic.Def (t,_)) ->
- if b then
- let _,_ =
- try
- CicTypeChecker.type_of_aux' metasenv context t
- CicUniv.oblivion_ugraph
- with _ ->
- raise
- (PET.Fail
- (lazy ("Hypothesis " ^ string_of_name n ^
- " uses hypothesis " ^ hyp)))
- in
- (b, entry::context)
- else
- (b, entry::context)
- ) canonical_context (false, [])
- in
- if not context_changed then
- raise (PET.Fail (lazy ("Hypothesis " ^ hyp ^ " does not exist")));
- let _,_ =
- try
- CicTypeChecker.type_of_aux' metasenv canonical_context' ty
- CicUniv.oblivion_ugraph
- with _ ->
- raise (PET.Fail (lazy ("Hypothesis " ^ hyp ^ " occurs in the goal")))
- in
- m,canonical_context',ty
- | t -> t
- ) metasenv
- in
- (curi,metasenv',_subst,pbo,pty, attrs), [goal]
- in
- PET.mk_tactic clear_one
-
-let clear ~hyps =
- let clear status =
- let aux status hyp =
- match PET.apply_tactic (clear_one ~hyp) status with
- | proof, [g] -> proof, g
- | _ -> raise (PET.Fail (lazy "clear: internal error"))
- in
- let proof, g = List.fold_left aux status hyps in
- proof, [g]
- in
- PET.mk_tactic clear
-
-(* Warning: this tactic has no effect on the proof term.
- It just changes the name of an hypothesis in the current sequent *)
-let rename ~froms ~tos =
- let rename (proof, goal) =
- let error = "rename: lists of different length" in
- let assocs =
- try List.combine froms tos
- with Invalid_argument _ -> raise (PET.Fail (lazy error))
- in
- let curi, metasenv, _subst, pbo, pty, attrs = proof in
- let metano, _, _ = CicUtil.lookup_meta goal metasenv in
- let rename_map = function
- | Some (Cic.Name hyp, decl_or_def) as entry ->
- begin try Some (Cic.Name (List.assoc hyp assocs), decl_or_def)
- with Not_found -> entry end
- | entry -> entry
- in
- let map = function
- | m, canonical_context, ty when m = metano ->
- let canonical_context = List.map rename_map canonical_context in
- m, canonical_context, ty
- | conjecture -> conjecture
- in
- let metasenv = List.map map metasenv in
- (curi, metasenv, _subst, pbo, pty, attrs), [goal]
- in
- PET.mk_tactic rename
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val clearbody: hyp:string -> ProofEngineTypes.tactic
-val clear: hyps:string list -> ProofEngineTypes.tactic
-
-(* Warning: this tactic has no effect on the proof term.
- It just changes the name of an hypothesis in the current sequent *)
-val rename: froms:string list -> tos:string list -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
- (**
- current proof (proof uri * metas * (in)complete proof * term to be prooved)
- *)
-type proof =
- UriManager.uri option * Cic.metasenv * Cic.substitution * Cic.term Lazy.t * Cic.term * Cic.attribute list
- (** current goal, integer index *)
-type goal = int
-type status = proof * goal
-
-let initial_status ty metasenv attrs =
- let rec aux max = function
- | [] -> max + 1
- | (idx, _, _) :: tl ->
- if idx > max then
- aux idx tl
- else
- aux max tl
- in
- let newmeta_idx = aux 0 metasenv in
- let _subst = [] in
- let proof =
- None, (newmeta_idx, [], ty) :: metasenv, _subst,
- lazy (Cic.Meta (newmeta_idx, [])), ty, attrs
- in
- (proof, newmeta_idx)
-
- (**
- a tactic: make a transition from one status to another one or, usually,
- raise a "Fail" (@see Fail) exception in case of failure
- *)
- (** an unfinished proof with the optional current goal *)
-type tactic = status -> proof * goal list
-
- (** creates an opaque tactic from a status->proof*goal list function *)
-let mk_tactic t = t
-
-type reduction = Cic.context -> Cic.term -> Cic.term
-
-let const_lazy_term t =
- (fun _ metasenv ugraph -> t, metasenv, ugraph)
-
-type lazy_reduction =
- Cic.context -> Cic.metasenv -> CicUniv.universe_graph ->
- reduction * Cic.metasenv * CicUniv.universe_graph
-
-let const_lazy_reduction red =
- (fun _ metasenv ugraph -> red, metasenv, ugraph)
-
-type ('term, 'lazy_term) pattern =
- 'lazy_term option * (string * 'term) list * 'term option
-
-type lazy_pattern = (Cic.term, Cic.lazy_term) pattern
-
-let hole = Cic.Implicit (Some `Hole)
-
-let conclusion_pattern t =
- let t' =
- match t with
- | None -> None
- | Some t -> Some (const_lazy_term t)
- in
- t',[], Some hole
-
- (** tactic failure *)
-exception Fail of string Lazy.t
-
- (**
- calls the opaque tactic on the status
- *)
-let apply_tactic t status =
- let (uri,metasenv,subst,bo,ty, attrs), gl = t status in
- match
- CicRefine.pack_coercion_obj
- (Cic.CurrentProof ("",metasenv,Cic.Rel ~-1,ty,[],attrs))
- with
- | Cic.CurrentProof (_,metasenv,_,ty,_, attrs) ->
- (uri,metasenv,subst,bo,ty, attrs), gl
- | _ -> assert false
-;;
-
- (** constraint: the returned value will always be constructed by Cic.Name **)
-type mk_fresh_name_type =
- Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name
-
-let goals_of_proof (_,metasenv,_subst,_,_,_) = List.map (fun (g,_,_) -> g) metasenv
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
- (**
- current proof (proof uri * metas * (in)complete proof * term to be prooved)
- *)
-type proof =
- UriManager.uri option * Cic.metasenv * Cic.substitution * Cic.term Lazy.t * Cic.term * Cic.attribute list
- (** current goal, integer index *)
-type goal = int
-type status = proof * goal
-
- (** @param goal
- * @param goal's metasenv
- * @return initial proof status for the given goal *)
-val initial_status: Cic.term -> Cic.metasenv -> Cic.attribute list -> status
-
- (**
- a tactic: make a transition from one status to another one or, usually,
- raise a "Fail" (@see Fail) exception in case of failure
- *)
- (** an unfinished proof with the optional current goal *)
-type tactic
-val mk_tactic: (status -> proof * goal list) -> tactic
-
-type reduction = Cic.context -> Cic.term -> Cic.term
-
-val const_lazy_term: Cic.term -> Cic.lazy_term
-
-type lazy_reduction =
- Cic.context -> Cic.metasenv -> CicUniv.universe_graph ->
- reduction * Cic.metasenv * CicUniv.universe_graph
-
-val const_lazy_reduction: reduction -> lazy_reduction
-
- (** what, hypothesis patterns, conclusion pattern *)
-type ('term, 'lazy_term) pattern =
- 'lazy_term option * (string * 'term) list * 'term option
-
-type lazy_pattern = (Cic.term, Cic.lazy_term) pattern
-
- (** conclusion_pattern [t] returns the pattern (t,[],%) *)
-val conclusion_pattern : Cic.term option -> lazy_pattern
-
- (** tactic failure *)
-exception Fail of string Lazy.t
-
-val apply_tactic: tactic -> status -> proof * goal list
-
- (** constraint: the returned value will always be constructed by Cic.Name **)
-type mk_fresh_name_type =
- Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name
-
-val goals_of_proof: proof -> goal list
-
-val hole: Cic.term
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open ProofEngineTypes
-
-(* Note: this code is almost identical to change_tac and
-* it could be unified by making the change function a callback *)
-let reduction_tac ~reduction ~pattern (proof,goal) =
- let curi,metasenv,subst,pbo,pty, attrs = proof in
- let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
- let change subst where terms metasenv ugraph =
- if terms = [] then where, metasenv, ugraph
- else
- let pairs, metasenv, ugraph =
- List.fold_left
- (fun (pairs, metasenv, ugraph) (context, t) ->
- let reduction, metasenv, ugraph = reduction context metasenv ugraph in
- ((t, reduction context t) :: pairs), metasenv, ugraph)
- ([], metasenv, ugraph)
- terms
- in
- let terms, terms' = List.split pairs in
- let where' =
- ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms'
- ~where:where
- in
- CicMetaSubst.apply_subst subst where', metasenv, ugraph
- in
- let (subst,metasenv,ugraph,selected_context,selected_ty) =
- ProofEngineHelpers.select ~subst ~metasenv ~ugraph:CicUniv.oblivion_ugraph
- ~conjecture ~pattern
- in
- let ty', metasenv, ugraph = change subst ty selected_ty metasenv ugraph in
- let context', metasenv, ugraph =
- List.fold_right2
- (fun entry selected_entry (context', metasenv, ugraph) ->
- match entry,selected_entry with
- None,None -> None::context', metasenv, ugraph
- | Some (name,Cic.Decl ty),Some (`Decl selected_ty) ->
- let ty', metasenv, ugraph =
- change subst ty selected_ty metasenv ugraph
- in
- Some (name,Cic.Decl ty')::context', metasenv, ugraph
- | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) ->
- let bo', metasenv, ugraph =
- change subst bo selected_bo metasenv ugraph in
- let ty', metasenv, ugraph =
- change subst ty selected_ty metasenv ugraph
- in
- (Some (name,Cic.Def (bo',ty'))::context'), metasenv, ugraph
- | _,_ -> assert false
- ) context selected_context ([], metasenv, ugraph) in
- let metasenv' =
- List.map (function
- | (n,_,_) when n = metano -> (metano,context',ty')
- | _ as t -> t
- ) metasenv
- in
- (curi,metasenv',subst,pbo,pty, attrs), [metano]
-;;
-
-let simpl_tac ~pattern =
- mk_tactic (reduction_tac
- ~reduction:(const_lazy_reduction ProofEngineReduction.simpl) ~pattern)
-
-let unfold_tac what ~pattern =
- let reduction =
- match what with
- | None -> const_lazy_reduction (ProofEngineReduction.unfold ?what:None)
- | Some lazy_term ->
- (fun context metasenv ugraph ->
- let what, metasenv, ugraph = lazy_term context metasenv ugraph in
- let unfold ctx t =
- try
- ProofEngineReduction.unfold ~what ctx t
- with
- (* Not what we would like to have; however, this is required
- right now for the case of a definition in the context:
- if it works only in the body (or only in the type), that should
- be accepted *)
- ProofEngineTypes.Fail _ -> t
- in
- unfold, metasenv, ugraph)
- in
- mk_tactic (reduction_tac ~reduction ~pattern)
-
-let whd_tac ~pattern =
- mk_tactic (reduction_tac
- ~reduction:(const_lazy_reduction CicReduction.whd) ~pattern)
-
-let normalize_tac ~pattern =
- mk_tactic (reduction_tac
- ~reduction:(const_lazy_reduction CicReduction.normalize) ~pattern)
-
-let head_beta_reduce_tac ?delta ?upto ~pattern =
- mk_tactic (reduction_tac
- ~reduction:
- (const_lazy_reduction
- (fun _context -> CicReduction.head_beta_reduce ?delta ?upto)) ~pattern)
-
-exception NotConvertible
-
-(* Note: this code is almost identical to reduction_tac and
-* it could be unified by making the change function a callback *)
-(* CSC: with_what is parsed in the context of the goal, but it should replace
- something that lives in a completely different context. Thus we
- perform a delift + lift phase to move it in the right context. However,
- in this way the tactic is less powerful than expected: with_what cannot
- reference variables that are local to the term that is going to be
- replaced. To fix this we should parse with_what in the context of the
- term(s) to be replaced. *)
-let change_tac ?(with_cast=false) ~pattern with_what =
- let change_tac ~pattern ~with_what (proof, goal) =
- let curi,metasenv,subst,pbo,pty, attrs = proof in
- let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
- let change subst where terms metasenv ugraph =
- if terms = [] then where, metasenv, ugraph
- else
- let pairs, metasenv, ugraph =
- List.fold_left
- (fun (pairs, metasenv, ugraph) (context_of_t, t) ->
- let with_what, metasenv, ugraph =
- with_what context_of_t metasenv ugraph
- in
- let _,u =
- CicTypeChecker.type_of_aux'
- metasenv ~subst context_of_t with_what ugraph
- in
- let b,_ =
- CicReduction.are_convertible
- ~metasenv ~subst context_of_t t with_what u
- in
- if b then
- ((t, with_what) :: pairs), metasenv, ugraph
- else
- raise NotConvertible)
- ([], metasenv, ugraph)
- terms
- in
- let terms, terms' = List.split pairs in
- let where' =
- ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms'
- ~where:where
- in
- CicMetaSubst.apply_subst subst where', metasenv, ugraph
- in
- let (subst,metasenv,ugraph,selected_context,selected_ty) =
- ProofEngineHelpers.select
- ~metasenv ~subst ~ugraph:CicUniv.oblivion_ugraph ~conjecture ~pattern
- in
- let ty', metasenv, ugraph = change subst ty selected_ty metasenv ugraph in
- let context', metasenv, ugraph =
- List.fold_right2
- (fun entry selected_entry (context', metasenv, ugraph) ->
- match entry,selected_entry with
- None,None -> (None::context'), metasenv, ugraph
- | Some (name,Cic.Decl ty),Some (`Decl selected_ty) ->
- let ty', metasenv, ugraph =
- change subst ty selected_ty metasenv ugraph
- in
- (Some (name,Cic.Decl ty')::context'), metasenv, ugraph
- | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) ->
- let bo', metasenv, ugraph =
- change subst bo selected_bo metasenv ugraph in
- let ty', metasenv, ugraph =
- change subst ty selected_ty metasenv ugraph
- in
- (Some (name,Cic.Def (bo',ty'))::context'), metasenv, ugraph
- | _,_ -> assert false
- ) context selected_context ([], metasenv, ugraph) in
- let metasenv' =
- List.map
- (function
- | (n,_,_) when n = metano -> (metano,context',ty')
- | _ as t -> t)
- metasenv
- in
- let proof,goal = (curi,metasenv',subst,pbo,pty, attrs), metano in
- if with_cast then
- let metano' = ProofEngineHelpers.new_meta_of_proof ~proof in
- let (newproof,_) =
- let irl= CicMkImplicit.identity_relocation_list_for_metavariable context'
- in
- ProofEngineHelpers.subst_meta_in_proof
- proof metano
- (Cic.Cast (Cic.Meta(metano',irl),ty')) [metano',context',ty']
- in
- newproof, [metano']
- else
- proof,[goal]
- in
- mk_tactic (change_tac ~pattern ~with_what)
-;;
-
-let fold_tac ~reduction ~term ~pattern =
- let fold_tac ~reduction ~term ~pattern:(wanted,hyps_pat,concl_pat) status =
- assert (wanted = None); (* this should be checked syntactically *)
- let reduced_term =
- (fun context metasenv ugraph ->
- let term, metasenv, ugraph = term context metasenv ugraph in
- let reduction, metasenv, ugraph = reduction context metasenv ugraph in
- reduction context term, metasenv, ugraph)
- in
- apply_tactic
- (change_tac ~pattern:(Some reduced_term,hyps_pat,concl_pat) term) status
- in
- mk_tactic (fold_tac ~reduction ~term ~pattern)
-;;
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val simpl_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val whd_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val normalize_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val head_beta_reduce_tac: ?delta:bool -> ?upto:int -> pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-
-(* The default of term is the thesis of the goal to be prooved *)
-val unfold_tac:
- Cic.lazy_term option ->
- pattern:ProofEngineTypes.lazy_pattern ->
- ProofEngineTypes.tactic
-
-val change_tac:
- ?with_cast:bool ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.lazy_term ->
- ProofEngineTypes.tactic
-
-val fold_tac:
- reduction:ProofEngineTypes.lazy_reduction ->
- term:Cic.lazy_term ->
- pattern:ProofEngineTypes.lazy_pattern ->
- ProofEngineTypes.tactic
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open CicReduction
-open PrimitiveTactics
-open ProofEngineTypes
-open UriManager
-
-(** DEBUGGING *)
-
- (** perform debugging output? *)
-let debug = false
-let debug_print = fun _ -> ()
-
- (** debugging print *)
-let warn s = debug_print (lazy ("RING WARNING: " ^ (Lazy.force s)))
-
-(** CIC URIS *)
-
-(**
- Note: For constructors URIs aren't really URIs but rather triples of
- the form (uri, typeno, consno). This discrepancy is to preserver an
- uniformity of invocation of "mkXXX" functions.
-*)
-
-let equality_is_a_congruence_A =
- uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var"
-let equality_is_a_congruence_x =
- uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var"
-let equality_is_a_congruence_y =
- uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var"
-
-let apolynomial_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial.ind"
-let apvar_uri = (apolynomial_uri, 0, 1)
-let ap0_uri = (apolynomial_uri, 0, 2)
-let ap1_uri = (apolynomial_uri, 0, 3)
-let applus_uri = (apolynomial_uri, 0, 4)
-let apmult_uri = (apolynomial_uri, 0, 5)
-let apopp_uri = (apolynomial_uri, 0, 6)
-
-let quote_varmap_A_uri = uri_of_string "cic:/Coq/ring/Quote/variables_map/A.var"
-let varmap_uri = uri_of_string "cic:/Coq/ring/Quote/varmap.ind"
-let empty_vm_uri = (varmap_uri, 0, 1)
-let node_vm_uri = (varmap_uri, 0, 2)
-let varmap_find_uri = uri_of_string "cic:/Coq/ring/Quote/varmap_find.con"
-let index_uri = uri_of_string "cic:/Coq/ring/Quote/index.ind"
-let left_idx_uri = (index_uri, 0, 1)
-let right_idx_uri = (index_uri, 0, 2)
-let end_idx_uri = (index_uri, 0, 3)
-
-let abstract_rings_A_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/A.var"
-let abstract_rings_Aplus_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aplus.var"
-let abstract_rings_Amult_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Amult.var"
-let abstract_rings_Aone_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aone.var"
-let abstract_rings_Azero_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Azero.var"
-let abstract_rings_Aopp_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aopp.var"
-let abstract_rings_Aeq_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aeq.var"
-let abstract_rings_vm_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/vm.var"
-let abstract_rings_T_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/T.var"
-let interp_ap_uri = uri_of_string "cic:/Coq/ring/Ring_abstract/interp_ap.con"
-let interp_sacs_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/interp_sacs.con"
-let apolynomial_normalize_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial_normalize.con"
-let apolynomial_normalize_ok_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial_normalize_ok.con"
-
-(** CIC PREDICATES *)
-
- (**
- check whether a term is a constant or not, if argument "uri" is given and is
- not "None" also check if the constant correspond to the given one or not
- *)
-let cic_is_const ?(uri: uri option = None) term =
- match uri with
- | None ->
- (match term with
- | Cic.Const _ -> true
- | _ -> false)
- | Some realuri ->
- (match term with
- | Cic.Const (u, _) when (eq u realuri) -> true
- | _ -> false)
-
-(** PROOF AND GOAL ACCESSORS *)
-
- (**
- @param proof a proof
- @return the uri of a given proof
- *)
-let uri_of_proof ~proof:(uri, _, _, _, _, _) = uri
-
- (**
- @param status current proof engine status
- @raise Failure if proof is None
- @return current goal's metasenv
- *)
-let metasenv_of_status ((_,m,_,_,_, _), _) = m
-
- (**
- @param status a proof engine status
- @raise Failure when proof or goal are None
- @return context corresponding to current goal
- *)
-let context_of_status status =
- let (proof, goal) = status in
- let metasenv = metasenv_of_status status in
- let _, context, _ = CicUtil.lookup_meta goal metasenv in
- context
-
-(** CIC TERM CONSTRUCTORS *)
-
- (**
- Create a Cic term consisting of a constant
- @param uri URI of the constant
- @proof current proof
- @exp_named_subst explicit named substitution
- *)
-let mkConst ~uri ~exp_named_subst =
- Cic.Const (uri, exp_named_subst)
-
- (**
- Create a Cic term consisting of a constructor
- @param uri triple <uri, typeno, consno> where uri is the uri of an inductive
- type, typeno is the type number in a mutind structure (0 based), consno is
- the constructor number (1 based)
- @exp_named_subst explicit named substitution
- *)
-let mkCtor ~uri:(uri, typeno, consno) ~exp_named_subst =
- Cic.MutConstruct (uri, typeno, consno, exp_named_subst)
-
- (**
- Create a Cic term consisting of a type member of a mutual induction
- @param uri pair <uri, typeno> where uri is the uri of a mutual inductive
- type and typeno is the type number (0 based) in the mutual induction
- @exp_named_subst explicit named substitution
- *)
-let mkMutInd ~uri:(uri, typeno) ~exp_named_subst =
- Cic.MutInd (uri, typeno, exp_named_subst)
-
-(** EXCEPTIONS *)
-
- (**
- raised when the current goal is not ringable; a goal is ringable when is an
- equality on reals (@see r_uri)
- *)
-exception GoalUnringable
-
-(** RING's FUNCTIONS LIBRARY *)
-
- (**
- Check whether the ring tactic can be applied on a given term (i.e. that is
- an equality on reals)
- @param term to be tested
- @return true if the term is ringable, false otherwise
- *)
-let ringable =
- let is_equality = function
- | Cic.MutInd (uri, 0, []) when (eq uri HelmLibraryObjects.Logic.eq_URI) -> true
- | _ -> false
- in
- let is_real = function
- | Cic.Const (uri, _) when (eq uri HelmLibraryObjects.Reals.r_URI) -> true
- | _ -> false
- in
- function
- | Cic.Appl (app::set::_::_::[]) when (is_equality app && is_real set) ->
- warn (lazy "Goal Ringable!");
- true
- | _ ->
- warn (lazy "Goal Not Ringable :-((");
- false
-
- (**
- split an equality goal of the form "t1 = t2" in its two subterms t1 and t2
- after checking that the goal is ringable
- @param goal the current goal
- @return a pair (t1,t2) that are two sides of the equality goal
- @raise GoalUnringable if the goal isn't ringable
- *)
-let split_eq = function
- | (Cic.Appl (_::_::t1::t2::[])) as term when ringable term ->
- warn (lazy ("<term1>" ^ (CicPp.ppterm t1) ^ "</term1>"));
- warn (lazy ("<term2>" ^ (CicPp.ppterm t2) ^ "</term2>"));
- (t1, t2)
- | _ -> raise GoalUnringable
-
- (**
- @param i an integer index representing a 1 based number of node in a binary
- search tree counted in a fbs manner (i.e.: 1 is the root, 2 is the left
- child of the root (if any), 3 is the right child of the root (if any), 4 is
- the left child of the left child of the root (if any), ....)
- @param proof the current proof
- @return an index representing the same node in a varmap (@see varmap_uri),
- the returned index is as defined in index (@see index_uri)
- *)
-let path_of_int n =
- let rec digits_of_int n =
- if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1))
- in
- List.fold_right
- (fun digit path ->
- Cic.Appl [
- mkCtor (if (digit = true) then right_idx_uri else left_idx_uri) [];
- path])
- (List.rev (digits_of_int n)) (* remove leading true (i.e. digit 1) *)
- (mkCtor end_idx_uri [])
-
- (**
- Build a variable map (@see varmap_uri) from a variables array.
- A variable map is almost a binary tree so this function receiving a var list
- like [v;w;x;y;z] will build a varmap of shape: v
- / \
- w x
- / \
- y z
- @param vars variables array
- @return a cic term representing the variable map containing vars variables
- *)
-let btree_of_array ~vars =
- let r = HelmLibraryObjects.Reals.r in
- let empty_vm_r = mkCtor empty_vm_uri [quote_varmap_A_uri,r] in
- let node_vm_r = mkCtor node_vm_uri [quote_varmap_A_uri,r] in
- let size = Array.length vars in
- let halfsize = size lsr 1 in
- let rec aux n = (* build the btree starting from position n *)
- (*
- n is the position in the vars array _1_based_ in order to access
- left and right child using (n*2, n*2+1) trick
- *)
- if n > size then
- empty_vm_r
- else if n > halfsize then (* no more children *)
- Cic.Appl [node_vm_r; vars.(n-1); empty_vm_r; empty_vm_r]
- else (* still children *)
- Cic.Appl [node_vm_r; vars.(n-1); aux (n*2); aux (n*2+1)]
- in
- aux 1
-
- (**
- abstraction function:
- concrete polynoms -----> (abstract polynoms, varmap)
- @param terms list of conrete polynoms
- @return a pair <aterms, varmap> where aterms is a list of abstract polynoms
- and varmap is the variable map needed to interpret them
- *)
-let abstract_poly ~terms =
- let varhash = Hashtbl.create 19 in (* vars hash, to speed up lookup *)
- let varlist = ref [] in (* vars list in reverse order *)
- let counter = ref 1 in (* index of next new variable *)
- let rec aux = function (* TODO not tail recursive *)
- (* "bop" -> binary operator | "uop" -> unary operator *)
- | Cic.Appl (bop::t1::t2::[])
- when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.rplus_URI) bop) -> (* +. *)
- Cic.Appl [mkCtor applus_uri []; aux t1; aux t2]
- | Cic.Appl (bop::t1::t2::[])
- when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.rmult_URI) bop) -> (* *. *)
- Cic.Appl [mkCtor apmult_uri []; aux t1; aux t2]
- | Cic.Appl (uop::t::[])
- when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.ropp_URI) uop) -> (* ~-. *)
- Cic.Appl [mkCtor apopp_uri []; aux t]
- | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.r0_URI) t) -> (* 0. *)
- mkCtor ap0_uri []
- | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.r1_URI) t) -> (* 1. *)
- mkCtor ap1_uri []
- | t -> (* variable *)
- try
- Hashtbl.find varhash t (* use an old var *)
- with Not_found -> begin (* create a new var *)
- let newvar =
- Cic.Appl [mkCtor apvar_uri []; path_of_int !counter]
- in
- incr counter;
- varlist := t :: !varlist;
- Hashtbl.add varhash t newvar;
- newvar
- end
- in
- let aterms = List.map aux terms in (* abstract vars *)
- let varmap = (* build varmap *)
- btree_of_array ~vars:(Array.of_list (List.rev !varlist))
- in
- (aterms, varmap)
-
- (**
- given a list of abstract terms (i.e. apolynomials) build the ring "segments"
- that is triples like (t', t'', t''') where
- t' = interp_ap(varmap, at)
- t'' = interp_sacs(varmap, (apolynomial_normalize at))
- t''' = apolynomial_normalize_ok(varmap, at)
- at is the abstract term built from t, t is a single member of aterms
- *)
-let build_segments ~terms =
- let theory_args_subst varmap =
- [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ;
- abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ;
- abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ;
- abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ;
- abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ;
- abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.ropp ;
- abstract_rings_vm_uri, varmap] in
- let theory_args_subst' eq varmap t =
- [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ;
- abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ;
- abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ;
- abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ;
- abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ;
- abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.ropp ;
- abstract_rings_Aeq_uri, eq ;
- abstract_rings_vm_uri, varmap ;
- abstract_rings_T_uri, t] in
- let interp_ap varmap =
- mkConst interp_ap_uri (theory_args_subst varmap) in
- let interp_sacs varmap =
- mkConst interp_sacs_uri (theory_args_subst varmap) in
- let apolynomial_normalize = mkConst apolynomial_normalize_uri [] in
- let apolynomial_normalize_ok eq varmap t =
- mkConst apolynomial_normalize_ok_uri (theory_args_subst' eq varmap t) in
- let lxy_false = (** Cic funcion "fun (x,y):R -> false" *)
- Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r,
- Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, HelmLibraryObjects.Datatypes.falseb))
- in
- let (aterms, varmap) = abstract_poly ~terms in (* abstract polys *)
- List.map (* build ring segments *)
- (fun t ->
- Cic.Appl [interp_ap varmap ; t],
- Cic.Appl (
- [interp_sacs varmap ; Cic.Appl [apolynomial_normalize; t]]),
- Cic.Appl [apolynomial_normalize_ok lxy_false varmap HelmLibraryObjects.Reals.rtheory ; t]
- ) aterms
-
-
-let status_of_single_goal_tactic_result =
- function
- proof,[goal] -> proof,goal
- | _ ->
- raise (Fail (lazy "status_of_single_goal_tactic_result: the tactic did not produce exactly a new goal"))
-
-(* Galla: spostata in variousTactics.ml
- (**
- auxiliary tactic "elim_type"
- @param status current proof engine status
- @param term term to cut
- *)
-let elim_type_tac ~term status =
- warn (lazy "in Ring.elim_type_tac");
- Tacticals.thens ~start:(cut_tac ~term)
- ~continuations:[elim_simpl_intros_tac ~term:(Cic.Rel 1) ; Tacticals.id_tac] status
-*)
-
- (**
- auxiliary tactic, use elim_type and try to close 2nd subgoal using proof
- @param status current proof engine status
- @param term term to cut
- @param proof term used to prove second subgoal generated by elim_type
- *)
-(* FG: METTERE I NOMI ANCHE QUI? *)
-let elim_type2_tac ~term ~proof =
- let elim_type2_tac ~term ~proof status =
- let module E = EliminationTactics in
- warn (lazy "in Ring.elim_type2");
- ProofEngineTypes.apply_tactic
- (Tacticals.thens ~start:(E.elim_type_tac term)
- ~continuations:[Tacticals.id_tac ; exact_tac ~term:proof]) status
- in
- ProofEngineTypes.mk_tactic (elim_type2_tac ~term ~proof)
-
-(* Galla: spostata in variousTactics.ml
- (**
- Reflexivity tactic, try to solve current goal using "refl_eqT"
- Warning: this isn't equale to the coq's Reflexivity because this one tries
- only refl_eqT, coq's one also try "refl_equal"
- @param status current proof engine status
- *)
-let reflexivity_tac (proof, goal) =
- warn (lazy "in Ring.reflexivity_tac");
- let refl_eqt = mkCtor ~uri:refl_eqt_uri ~exp_named_subst:[] in
- try
- apply_tac (proof, goal) ~term:refl_eqt
- with (Fail _) as e ->
- let e_str = Printexc.to_string e in
- raise (Fail ("Reflexivity failed with exception: " ^ e_str))
-*)
-
- (** lift an 8-uple of debrujins indexes of n *)
-let lift ~n (a,b,c,d,e,f,g,h) =
- match (List.map (CicSubstitution.lift n) [a;b;c;d;e;f;g;h]) with
- | [a;b;c;d;e;f;g;h] -> (a,b,c,d,e,f,g,h)
- | _ -> assert false
-
- (**
- remove hypothesis from a given status starting from the last one
- @param count number of hypotheses to remove
- @param status current proof engine status
- *)
-let purge_hyps_tac ~count =
- let purge_hyps_tac ~count status =
- let module S = ProofEngineStructuralRules in
- let (proof, goal) = status in
- let rec aux n context status =
- assert(n>=0);
- match (n, context) with
- | (0, _) -> status
- | (n, hd::tl) ->
- let name_of_hyp =
- match hd with
- None
- | Some (Cic.Anonymous,_) -> assert false
- | Some (Cic.Name name,_) -> name
- in
- aux (n-1) tl
- (status_of_single_goal_tactic_result
- (ProofEngineTypes.apply_tactic (S.clear ~hyps:[name_of_hyp]) status))
- | (_, []) -> failwith "Ring.purge_hyps_tac: no hypotheses left"
- in
- let (_, metasenv, _subst, _, _, _) = proof in
- let (_, context, _) = CicUtil.lookup_meta goal metasenv in
- let proof',goal' = aux count context status in
- assert (goal = goal') ;
- proof',[goal']
- in
- ProofEngineTypes.mk_tactic (purge_hyps_tac ~count)
-
-(** THE TACTIC! *)
-
- (**
- Ring tactic, does associative and commutative rewritings in Reals ring
- @param status current proof engine status
- *)
-
-let ring_tac status =
- let (proof, goal) = status in
- warn (lazy "in Ring tactic");
- let eqt = mkMutInd (HelmLibraryObjects.Logic.eq_URI, 0) [] in
- let r = HelmLibraryObjects.Reals.r in
- let metasenv = metasenv_of_status status in
- let (metano, context, ty) = CicUtil.lookup_meta goal metasenv in
- let (t1, t2) = split_eq ty in (* goal like t1 = t2 *)
- match (build_segments ~terms:[t1; t2]) with
- | (t1', t1'', t1'_eq_t1'')::(t2', t2'', t2'_eq_t2'')::[] -> begin
- if debug then
- List.iter (* debugging, feel free to remove *)
- (fun (descr, term) ->
- warn (lazy (descr ^ " " ^ (CicPp.ppterm term))))
- (List.combine
- ["t1"; "t1'"; "t1''"; "t1'_eq_t1''";
- "t2"; "t2'"; "t2''"; "t2'_eq_t2''"]
- [t1; t1'; t1''; t1'_eq_t1'';
- t2; t2'; t2''; t2'_eq_t2'']);
- try
- let new_hyps = ref 0 in (* number of new hypotheses created *)
- ProofEngineTypes.apply_tactic
- (Tacticals.first
- ~tactics:[
- EqualityTactics.reflexivity_tac ;
- exact_tac ~term:t1'_eq_t1'' ;
- exact_tac ~term:t2'_eq_t2'' ;
- exact_tac
- ~term:(
- Cic.Appl
- [mkConst HelmLibraryObjects.Logic.sym_eq_URI
- [equality_is_a_congruence_A, HelmLibraryObjects.Reals.r;
- equality_is_a_congruence_x, t1'' ;
- equality_is_a_congruence_y, t1
- ] ;
- t1'_eq_t1''
- ]) ;
- ProofEngineTypes.mk_tactic (fun status ->
- let status' = (* status after 1st elim_type use *)
- let context = context_of_status status in
- let b,_ = (*TASSI : FIXME*)
- are_convertible context t1'' t1 CicUniv.oblivion_ugraph in
- if not b then begin
- warn (lazy "t1'' and t1 are NOT CONVERTIBLE");
- let newstatus =
- ProofEngineTypes.apply_tactic
- (elim_type2_tac (* 1st elim_type use *)
- ~proof:t1'_eq_t1''
- ~term:(Cic.Appl [eqt; r; t1''; t1]))
- status
- in
- incr new_hyps; (* elim_type add an hyp *)
- match newstatus with
- (proof,[goal]) -> proof,goal
- | _ -> assert false
- end else begin
- warn (lazy "t1'' and t1 are CONVERTIBLE");
- status
- end
- in
- let (t1,t1',t1'',t1'_eq_t1'',t2,t2',t2'',t2'_eq_t2'') =
- lift 1 (t1,t1',t1'',t1'_eq_t1'', t2,t2',t2'',t2'_eq_t2'')
- in
- let status'' =
- ProofEngineTypes.apply_tactic
- (Tacticals.first (* try to solve 1st subgoal *)
- ~tactics:[
- exact_tac ~term:t2'_eq_t2'';
- exact_tac
- ~term:(
- Cic.Appl
- [mkConst HelmLibraryObjects.Logic.sym_eq_URI
- [equality_is_a_congruence_A, HelmLibraryObjects.Reals.r;
- equality_is_a_congruence_x, t2'' ;
- equality_is_a_congruence_y, t2
- ] ;
- t2'_eq_t2''
- ]) ;
- ProofEngineTypes.mk_tactic (fun status ->
- let status' =
- let context = context_of_status status in
- let b,_ = (* TASSI:FIXME *)
- are_convertible context t2'' t2
- CicUniv.oblivion_ugraph
- in
- if not b then begin
- warn (lazy "t2'' and t2 are NOT CONVERTIBLE");
- let newstatus =
- ProofEngineTypes.apply_tactic
- (elim_type2_tac (* 2nd elim_type use *)
- ~proof:t2'_eq_t2''
- ~term:(Cic.Appl [eqt; r; t2''; t2]))
- status
- in
- incr new_hyps; (* elim_type add an hyp *)
- match newstatus with
- (proof,[goal]) -> proof,goal
- | _ -> assert false
- end else begin
- warn (lazy "t2'' and t2 are CONVERTIBLE");
- status
- end
- in
- try (* try to solve main goal *)
- warn (lazy "trying reflexivity ....");
- ProofEngineTypes.apply_tactic
- EqualityTactics.reflexivity_tac status'
- with (Fail _) -> (* leave conclusion to the user *)
- warn (lazy "reflexivity failed, solution's left as an ex :-)");
- ProofEngineTypes.apply_tactic
- (purge_hyps_tac ~count:!new_hyps) status')])
- status'
- in
- status'')])
- status
- with (Fail s) ->
- raise (Fail (lazy ("Ring failure: " ^ Lazy.force s)))
- end
- | _ -> (* impossible: we are applying ring exacty to 2 terms *)
- assert false
-
- (* wrap ring_tac catching GoalUnringable and raising Fail *)
-
-let ring_tac status =
- try
- ring_tac status
- with GoalUnringable ->
- raise (Fail (lazy "goal unringable"))
-
-let ring_tac = ProofEngineTypes.mk_tactic ring_tac
-
+++ /dev/null
-
- (* ring tactics *)
-val ring_tac: ProofEngineTypes.tactic
-
-(*Galla: spostata in variuosTactics.ml
- (* auxiliary tactics *)
-val elim_type_tac: term: Cic.term -> ProofEngineTypes.tactic
-*)
-
-(* spostata in variousTactics.ml
-val reflexivity_tac: ProofEngineTypes.tactic
-*)
+++ /dev/null
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* $Id: setoid_replace.ml 8900 2006-06-06 14:40:27Z letouzey $ *)
-
-module T = Tacticals
-module RT = ReductionTactics
-module PET = ProofEngineTypes
-
-let default_eq () =
- match LibraryObjects.eq_URI () with
- Some uri -> uri
- | None ->
- raise (ProofEngineTypes.Fail (lazy "You need to register the default equality first. Please use the \"default\" command"))
-
-let replace = ref (fun _ _ -> assert false)
-let register_replace f = replace := f
-
-let general_rewrite = ref (fun _ _ -> assert false)
-let register_general_rewrite f = general_rewrite := f
-
-let prlist_with_sepi sep elem =
- let rec aux n =
- function
- | [] -> ""
- | [h] -> elem n h
- | h::t ->
- let e = elem n h and r = aux (n+1) t in
- e ^ sep ^ r
- in
- aux 1
-
-type relation =
- { rel_a: Cic.term ;
- rel_aeq: Cic.term;
- rel_refl: Cic.term option;
- rel_sym: Cic.term option;
- rel_trans : Cic.term option;
- rel_quantifiers_no: int (* it helps unification *);
- rel_X_relation_class: Cic.term;
- rel_Xreflexive_relation_class: Cic.term
- }
-
-type 'a relation_class =
- Relation of 'a (* the rel_aeq of the relation or the relation *)
- | Leibniz of Cic.term option (* the carrier (if eq is partially instantiated)*)
-
-type 'a morphism =
- { args : (bool option * 'a relation_class) list;
- output : 'a relation_class;
- lem : Cic.term;
- morphism_theory : Cic.term
- }
-
-type funct =
- { f_args : Cic.term list;
- f_output : Cic.term
- }
-
-type morphism_class =
- ACMorphism of relation morphism
- | ACFunction of funct
-
-let constr_relation_class_of_relation_relation_class =
- function
- Relation relation -> Relation relation.rel_aeq
- | Leibniz t -> Leibniz t
-
-
-(*COQ
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-*)
-
-(*COQ
-let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s
-*) let constant dir s = Cic.Implicit None
-(*COQ
-let gen_constant dir s = Coqlib.gen_constant "Setoid_replace" dir s
-*) let gen_constant dir s = Cic.Implicit None
-(*COQ
-let reference dir s = Coqlib.gen_reference "Setoid_replace" ("Setoids"::dir) s
-let eval_reference dir s = EvalConstRef (destConst (constant dir s))
-*) let eval_reference dir s = Cic.Implicit None
-(*COQ
-let eval_init_reference dir s = EvalConstRef (destConst (gen_constant ("Init"::dir) s))
-*)
-
-(*COQ
-let current_constant id =
- try
- global_reference id
- with Not_found ->
- anomaly ("Setoid: cannot find " ^ id)
-*) let current_constant id = assert false
-
-(* From Setoid.v *)
-
-let coq_reflexive =
- (gen_constant ["Relations"; "Relation_Definitions"] "reflexive")
-let coq_symmetric =
- (gen_constant ["Relations"; "Relation_Definitions"] "symmetric")
-let coq_transitive =
- (gen_constant ["Relations"; "Relation_Definitions"] "transitive")
-let coq_relation =
- (gen_constant ["Relations"; "Relation_Definitions"] "relation")
-
-let coq_Relation_Class = (constant ["Setoid"] "Relation_Class")
-let coq_Argument_Class = (constant ["Setoid"] "Argument_Class")
-let coq_Setoid_Theory = (constant ["Setoid"] "Setoid_Theory")
-let coq_Morphism_Theory = (constant ["Setoid"] "Morphism_Theory")
-let coq_Build_Morphism_Theory= (constant ["Setoid"] "Build_Morphism_Theory")
-let coq_Compat = (constant ["Setoid"] "Compat")
-
-let coq_AsymmetricReflexive = (constant ["Setoid"] "AsymmetricReflexive")
-let coq_SymmetricReflexive = (constant ["Setoid"] "SymmetricReflexive")
-let coq_SymmetricAreflexive = (constant ["Setoid"] "SymmetricAreflexive")
-let coq_AsymmetricAreflexive = (constant ["Setoid"] "AsymmetricAreflexive")
-let coq_Leibniz = (constant ["Setoid"] "Leibniz")
-
-let coq_RAsymmetric = (constant ["Setoid"] "RAsymmetric")
-let coq_RSymmetric = (constant ["Setoid"] "RSymmetric")
-let coq_RLeibniz = (constant ["Setoid"] "RLeibniz")
-
-let coq_ASymmetric = (constant ["Setoid"] "ASymmetric")
-let coq_AAsymmetric = (constant ["Setoid"] "AAsymmetric")
-
-let coq_seq_refl = (constant ["Setoid"] "Seq_refl")
-let coq_seq_sym = (constant ["Setoid"] "Seq_sym")
-let coq_seq_trans = (constant ["Setoid"] "Seq_trans")
-
-let coq_variance = (constant ["Setoid"] "variance")
-let coq_Covariant = (constant ["Setoid"] "Covariant")
-let coq_Contravariant = (constant ["Setoid"] "Contravariant")
-let coq_Left2Right = (constant ["Setoid"] "Left2Right")
-let coq_Right2Left = (constant ["Setoid"] "Right2Left")
-let coq_MSNone = (constant ["Setoid"] "MSNone")
-let coq_MSCovariant = (constant ["Setoid"] "MSCovariant")
-let coq_MSContravariant = (constant ["Setoid"] "MSContravariant")
-
-let coq_singl = (constant ["Setoid"] "singl")
-let coq_cons = (constant ["Setoid"] "cons")
-
-let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation =
- (constant ["Setoid"]
- "equality_morphism_of_asymmetric_areflexive_transitive_relation")
-let coq_equality_morphism_of_symmetric_areflexive_transitive_relation =
- (constant ["Setoid"]
- "equality_morphism_of_symmetric_areflexive_transitive_relation")
-let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation =
- (constant ["Setoid"]
- "equality_morphism_of_asymmetric_reflexive_transitive_relation")
-let coq_equality_morphism_of_symmetric_reflexive_transitive_relation =
- (constant ["Setoid"]
- "equality_morphism_of_symmetric_reflexive_transitive_relation")
-let coq_make_compatibility_goal =
- (constant ["Setoid"] "make_compatibility_goal")
-let coq_make_compatibility_goal_eval_ref =
- (eval_reference ["Setoid"] "make_compatibility_goal")
-let coq_make_compatibility_goal_aux_eval_ref =
- (eval_reference ["Setoid"] "make_compatibility_goal_aux")
-
-let coq_App = (constant ["Setoid"] "App")
-let coq_ToReplace = (constant ["Setoid"] "ToReplace")
-let coq_ToKeep = (constant ["Setoid"] "ToKeep")
-let coq_ProperElementToKeep = (constant ["Setoid"] "ProperElementToKeep")
-let coq_fcl_singl = (constant ["Setoid"] "fcl_singl")
-let coq_fcl_cons = (constant ["Setoid"] "fcl_cons")
-
-let coq_setoid_rewrite = (constant ["Setoid"] "setoid_rewrite")
-let coq_proj1 = (gen_constant ["Init"; "Logic"] "proj1")
-let coq_proj2 = (gen_constant ["Init"; "Logic"] "proj2")
-let coq_unit = (gen_constant ["Init"; "Datatypes"] "unit")
-let coq_tt = (gen_constant ["Init"; "Datatypes"] "tt")
-let coq_eq = (gen_constant ["Init"; "Logic"] "eq")
-
-let coq_morphism_theory_of_function =
- (constant ["Setoid"] "morphism_theory_of_function")
-let coq_morphism_theory_of_predicate =
- (constant ["Setoid"] "morphism_theory_of_predicate")
-let coq_relation_of_relation_class =
- (eval_reference ["Setoid"] "relation_of_relation_class")
-let coq_directed_relation_of_relation_class =
- (eval_reference ["Setoid"] "directed_relation_of_relation_class")
-let coq_interp = (eval_reference ["Setoid"] "interp")
-let coq_Morphism_Context_rect2 =
- (eval_reference ["Setoid"] "Morphism_Context_rect2")
-let coq_iff = (gen_constant ["Init";"Logic"] "iff")
-let coq_impl = (constant ["Setoid"] "impl")
-
-
-(************************* Table of declared relations **********************)
-
-
-(* Relations are stored in a table which is synchronised with the Reset mechanism. *)
-
-module Gmap =
- Map.Make(struct type t = Cic.term let compare = Pervasives.compare end);;
-
-let relation_table = ref Gmap.empty
-
-let relation_table_add (s,th) = relation_table := Gmap.add s th !relation_table
-let relation_table_find s = Gmap.find s !relation_table
-let relation_table_mem s = Gmap.mem s !relation_table
-
-let prrelation s =
- "(" ^ CicPp.ppterm s.rel_a ^ "," ^ CicPp.ppterm s.rel_aeq ^ ")"
-
-let prrelation_class =
- function
- Relation eq ->
- (try prrelation (relation_table_find eq)
- with Not_found ->
- "[[ Error: " ^ CicPp.ppterm eq ^
- " is not registered as a relation ]]")
- | Leibniz (Some ty) -> CicPp.ppterm ty
- | Leibniz None -> "_"
-
-let prmorphism_argument_gen prrelation (variance,rel) =
- prrelation rel ^
- match variance with
- None -> " ==> "
- | Some true -> " ++> "
- | Some false -> " --> "
-
-let prargument_class = prmorphism_argument_gen prrelation_class
-
-let pr_morphism_signature (l,c) =
- String.concat "" (List.map (prmorphism_argument_gen CicPp.ppterm) l) ^
- CicPp.ppterm c
-
-let prmorphism k m =
- CicPp.ppterm k ^ ": " ^
- String.concat "" (List.map prargument_class m.args) ^
- prrelation_class m.output
-
-(* A function that gives back the only relation_class on a given carrier *)
-(*CSC: this implementation is really inefficient. I should define a new
- map to make it efficient. However, is this really worth of? *)
-let default_relation_for_carrier ?(filter=fun _ -> true) a =
- let rng = Gmap.fold (fun _ y acc -> y::acc) !relation_table [] in
- match List.filter (fun ({rel_a=rel_a} as r) -> rel_a = a && filter r) rng with
- [] -> Leibniz (Some a)
- | relation::tl ->
-(*COQ
- if tl <> [] then
- prerr_endline
- ("Warning: There are several relations on the carrier \"" ^
- CicPp.ppterm a ^ "\". The relation " ^ prrelation relation ^
- " is chosen.") ;
-*)
- Relation relation
-
-let find_relation_class rel =
- try Relation (relation_table_find rel)
- with
- Not_found ->
- let default_eq = default_eq () in
- match CicReduction.whd [] rel with
- Cic.Appl [Cic.MutInd(uri,0,[]);ty]
- when UriManager.eq uri default_eq -> Leibniz (Some ty)
- | Cic.MutInd(uri,0,[]) when UriManager.eq uri default_eq -> Leibniz None
- | _ -> raise Not_found
-
-(*COQ
-let coq_iff_relation = lazy (find_relation_class (Lazy.force coq_iff))
-let coq_impl_relation = lazy (find_relation_class (Lazy.force coq_impl))
-*) let coq_iff_relation = Obj.magic 0 let coq_impl_relation = Obj.magic 0
-
-let relation_morphism_of_constr_morphism =
- let relation_relation_class_of_constr_relation_class =
- function
- Leibniz t -> Leibniz t
- | Relation aeq ->
- Relation (try relation_table_find aeq with Not_found -> assert false)
- in
- function mor ->
- let args' =
- List.map
- (fun (variance,rel) ->
- variance, relation_relation_class_of_constr_relation_class rel
- ) mor.args in
- let output' = relation_relation_class_of_constr_relation_class mor.output in
- {mor with args=args' ; output=output'}
-
-let equiv_list () =
- Gmap.fold (fun _ y acc -> y.rel_aeq::acc) !relation_table []
-
-(* Declare a new type of object in the environment : "relation-theory". *)
-
-let relation_to_obj (s, th) =
- let th' =
- if relation_table_mem s then
- begin
- let old_relation = relation_table_find s in
- let th' =
- {th with rel_sym =
- match th.rel_sym with
- None -> old_relation.rel_sym
- | Some t -> Some t}
- in
- prerr_endline
- ("Warning: The relation " ^ prrelation th' ^
- " is redeclared. The new declaration" ^
- (match th'.rel_refl with
- None -> ""
- | Some t -> " (reflevity proved by " ^ CicPp.ppterm t) ^
- (match th'.rel_sym with
- None -> ""
- | Some t ->
- (if th'.rel_refl = None then " (" else " and ") ^
- "symmetry proved by " ^ CicPp.ppterm t) ^
- (if th'.rel_refl <> None && th'.rel_sym <> None then
- ")" else "") ^
- " replaces the old declaration" ^
- (match old_relation.rel_refl with
- None -> ""
- | Some t -> " (reflevity proved by " ^ CicPp.ppterm t) ^
- (match old_relation.rel_sym with
- None -> ""
- | Some t ->
- (if old_relation.rel_refl = None then
- " (" else " and ") ^
- "symmetry proved by " ^ CicPp.ppterm t) ^
- (if old_relation.rel_refl <> None && old_relation.rel_sym <> None
- then ")" else "") ^
- ".");
- th'
- end
- else
- th
- in
- relation_table_add (s,th')
-
-(******************************* Table of declared morphisms ********************)
-
-(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
-
-let morphism_table = ref Gmap.empty
-
-let morphism_table_find m = Gmap.find m !morphism_table
-let morphism_table_add (m,c) =
- let old =
- try
- morphism_table_find m
- with
- Not_found -> []
- in
- try
-(*COQ
- let old_morph =
- List.find
- (function mor -> mor.args = c.args && mor.output = c.output) old
- in
- prerr_endline
- ("Warning: The morphism " ^ prmorphism m old_morph ^
- " is redeclared. " ^
- "The new declaration whose compatibility is proved by " ^
- CicPp.ppterm c.lem ^ " replaces the old declaration whose" ^
- " compatibility was proved by " ^
- CicPp.ppterm old_morph.lem ^ ".")
-*) ()
- with
- Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table
-
-let default_morphism ?(filter=fun _ -> true) m =
- match List.filter filter (morphism_table_find m) with
- [] -> raise Not_found
- | m1::ml ->
-(*COQ
- if ml <> [] then
- prerr_endline
- ("Warning: There are several morphisms associated to \"" ^
- CicPp.ppterm m ^ "\". Morphism " ^ prmorphism m m1 ^
- " is randomly chosen.");
-*)
- relation_morphism_of_constr_morphism m1
-
-(************************** Printing relations and morphisms **********************)
-
-let print_setoids () =
- Gmap.iter
- (fun k relation ->
- assert (k=relation.rel_aeq) ;
- prerr_endline ("Relation " ^ prrelation relation ^ ";" ^
- (match relation.rel_refl with
- None -> ""
- | Some t -> " reflexivity proved by " ^ CicPp.ppterm t) ^
- (match relation.rel_sym with
- None -> ""
- | Some t -> " symmetry proved by " ^ CicPp.ppterm t) ^
- (match relation.rel_trans with
- None -> ""
- | Some t -> " transitivity proved by " ^ CicPp.ppterm t)))
- !relation_table ;
- Gmap.iter
- (fun k l ->
- List.iter
- (fun ({lem=lem} as mor) ->
- prerr_endline ("Morphism " ^ prmorphism k mor ^
- ". Compatibility proved by " ^
- CicPp.ppterm lem ^ "."))
- l) !morphism_table
-;;
-
-(***************** Adding a morphism to the database ****************************)
-
-(* We maintain a table of the currently edited proofs of morphism lemma
- in order to add them in the morphism_table when the user does Save *)
-
-let edited = ref Gmap.empty
-
-let new_edited id m =
- edited := Gmap.add id m !edited
-
-let is_edited id =
- Gmap.mem id !edited
-
-let no_more_edited id =
- edited := Gmap.remove id !edited
-
-let what_edited id =
- Gmap.find id !edited
-
-let list_chop n l =
- let rec chop_aux acc = function
- | (0, l2) -> (List.rev acc, l2)
- | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
- | (_, []) -> assert false
- in
- chop_aux [] (n,l)
-
-let compose_thing f l b =
- let rec aux =
- function
- (0, env, b) -> b
- | (n, ((v,t)::l), b) -> aux (n-1, l, f v t b)
- | _ -> assert false
- in
- aux (List.length l,l,b)
-
-let compose_prod = compose_thing (fun v t b -> Cic.Prod (v,t,b))
-let compose_lambda = compose_thing (fun v t b -> Cic.Lambda (v,t,b))
-
-(* also returns the triple (args_ty_quantifiers_rev,real_args_ty,real_output)
- where the args_ty and the output are delifted *)
-let check_is_dependent n args_ty output =
- let m = List.length args_ty - n in
- let args_ty_quantifiers, args_ty = list_chop n args_ty in
- let rec aux m t =
- match t with
- Cic.Prod (n,s,t) when m > 0 ->
- let t' = CicSubstitution.subst (Cic.Implicit None) (* dummy *) t in
- if t' <> t then
- let args,out = aux (m - 1) t' in s::args,out
- else
- raise (ProofEngineTypes.Fail (lazy
- "The morphism is not a quantified non dependent product."))
- | _ -> [],t
- in
- let ty = compose_prod (List.rev args_ty) output in
- let args_ty, output = aux m ty in
- List.rev args_ty_quantifiers, args_ty, output
-
-let cic_relation_class_of_X_relation typ value =
- function
- {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} ->
- Cic.Appl [coq_AsymmetricReflexive ; typ ; value ; rel_a ; rel_aeq; refl]
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} ->
- Cic.Appl [coq_SymmetricReflexive ; typ ; rel_a ; rel_aeq; sym ; refl]
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} ->
- Cic.Appl [coq_AsymmetricAreflexive ; typ ; value ; rel_a ; rel_aeq]
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} ->
- Cic.Appl [coq_SymmetricAreflexive ; typ ; rel_a ; rel_aeq; sym]
-
-let cic_relation_class_of_X_relation_class typ value =
- function
- Relation {rel_X_relation_class=x_relation_class} ->
- Cic.Appl [x_relation_class ; typ ; value]
- | Leibniz (Some t) ->
- Cic.Appl [coq_Leibniz ; typ ; t]
- | Leibniz None -> assert false
-
-
-let cic_precise_relation_class_of_relation =
- function
- {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} ->
- Cic.Appl [coq_RAsymmetric ; rel_a ; rel_aeq; refl]
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} ->
- Cic.Appl [coq_RSymmetric ; rel_a ; rel_aeq; sym ; refl]
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} ->
- Cic.Appl [coq_AAsymmetric ; rel_a ; rel_aeq]
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} ->
- Cic.Appl [coq_ASymmetric ; rel_a ; rel_aeq; sym]
-
-let cic_precise_relation_class_of_relation_class =
- function
- Relation
- {rel_aeq=rel_aeq; rel_Xreflexive_relation_class=lem; rel_refl=rel_refl }
- ->
- rel_aeq,lem,not(rel_refl=None)
- | Leibniz (Some t) ->
- Cic.Appl [coq_eq ; t], Cic.Appl [coq_RLeibniz ; t], true
- | Leibniz None -> assert false
-
-let cic_relation_class_of_relation_class rel =
- cic_relation_class_of_X_relation_class
- coq_unit coq_tt rel
-
-let cic_argument_class_of_argument_class (variance,arg) =
- let coq_variant_value =
- match variance with
- None -> coq_Covariant (* dummy value, it won't be used *)
- | Some true -> coq_Covariant
- | Some false -> coq_Contravariant
- in
- cic_relation_class_of_X_relation_class coq_variance
- coq_variant_value arg
-
-let cic_arguments_of_argument_class_list args =
- let rec aux =
- function
- [] -> assert false
- | [last] ->
- Cic.Appl [coq_singl ; coq_Argument_Class ; last]
- | he::tl ->
- Cic.Appl [coq_cons ; coq_Argument_Class ; he ; aux tl]
- in
- aux (List.map cic_argument_class_of_argument_class args)
-
-let gen_compat_lemma_statement quantifiers_rev output args m =
- let output = cic_relation_class_of_relation_class output in
- let args = cic_arguments_of_argument_class_list args in
- args, output,
- compose_prod quantifiers_rev
- (Cic.Appl [coq_make_compatibility_goal ; args ; output ; m])
-
-let morphism_theory_id_of_morphism_proof_id id =
- id ^ "_morphism_theory"
-
-let list_map_i f =
- let rec map_i_rec i = function
- | [] -> []
- | x::l -> let v = f i x in v :: map_i_rec (i+1) l
- in
- map_i_rec
-
-(* apply_to_rels c [l1 ; ... ; ln] returns (c Rel1 ... reln) *)
-let apply_to_rels c l =
- if l = [] then c
- else
- let len = List.length l in
- Cic.Appl (c::(list_map_i (fun i _ -> Cic.Rel (len - i)) 0 l))
-
-let apply_to_relation subst rel =
- if subst = [] then rel
- else
- let new_quantifiers_no = rel.rel_quantifiers_no - List.length subst in
- assert (new_quantifiers_no >= 0) ;
- { rel_a = Cic.Appl (rel.rel_a :: subst) ;
- rel_aeq = Cic.Appl (rel.rel_aeq :: subst) ;
- rel_refl = HExtlib.map_option (fun c -> Cic.Appl (c::subst)) rel.rel_refl ;
- rel_sym = HExtlib.map_option (fun c -> Cic.Appl (c::subst)) rel.rel_sym;
- rel_trans = HExtlib.map_option (fun c -> Cic.Appl (c::subst)) rel.rel_trans;
- rel_quantifiers_no = new_quantifiers_no;
- rel_X_relation_class = Cic.Appl (rel.rel_X_relation_class::subst);
- rel_Xreflexive_relation_class =
- Cic.Appl (rel.rel_Xreflexive_relation_class::subst) }
-
-let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) =
- let lem =
- match lemma_infos with
- None ->
- (* the Morphism_Theory object has already been created *)
- let applied_args =
- let len = List.length quantifiers_rev in
- let subst =
- list_map_i (fun i _ -> Cic.Rel (len - i)) 0 quantifiers_rev
- in
- List.map
- (fun (v,rel) ->
- match rel with
- Leibniz (Some t) ->
- assert (subst=[]);
- v, Leibniz (Some t)
- | Leibniz None ->
- (match subst with
- [e] -> v, Leibniz (Some e)
- | _ -> assert false)
- | Relation rel -> v, Relation (apply_to_relation subst rel)) args
- in
- compose_lambda quantifiers_rev
- (Cic.Appl
- [coq_Compat ;
- cic_arguments_of_argument_class_list applied_args;
- cic_relation_class_of_relation_class output;
- apply_to_rels (current_constant mor_name) quantifiers_rev])
- | Some (lem_name,argsconstr,outputconstr) ->
- (* only the compatibility has been proved; we need to declare the
- Morphism_Theory object *)
- let mext = current_constant lem_name in
-(*COQ
- ignore (
- Declare.declare_internal_constant mor_name
- (DefinitionEntry
- {const_entry_body =
- compose_lambda quantifiers_rev
- (Cic.Appl
- [coq_Build_Morphism_Theory;
- argsconstr; outputconstr; apply_to_rels m quantifiers_rev ;
- apply_to_rels mext quantifiers_rev]);
- const_entry_boxed = Options.boxed_definitions()},
- IsDefinition Definition)) ;
-*)ignore (assert false);
- mext
- in
- let mmor = current_constant mor_name in
- let args_constr =
- List.map
- (fun (variance,arg) ->
- variance, constr_relation_class_of_relation_relation_class arg) args in
- let output_constr = constr_relation_class_of_relation_relation_class output in
-(*COQ
- Lib.add_anonymous_leaf
- (morphism_to_obj (m,
- { args = args_constr;
- output = output_constr;
- lem = lem;
- morphism_theory = mmor }));
-*)let _ = mmor,args_constr,output_constr,lem in ignore (assert false);
- (*COQ Options.if_verbose prerr_endline (CicPp.ppterm m ^ " is registered as a morphism") *) ()
-
-let list_sub _ _ _ = assert false
-
-(* first order matching with a bit of conversion *)
-let unify_relation_carrier_with_type env rel t =
- let raise_error quantifiers_no =
- raise (ProofEngineTypes.Fail (lazy
- ("One morphism argument or its output has type " ^ CicPp.ppterm t ^
- " but the signature requires an argument of type \"" ^
- CicPp.ppterm rel.rel_a ^ " " ^ String.concat " " (List.map (fun _ -> "?")
- (Array.to_list (Array.make quantifiers_no 0))) ^ "\""))) in
- let args =
- match t with
- Cic.Appl (he'::args') ->
- let argsno = List.length args' - rel.rel_quantifiers_no in
- let args1 = list_sub args' 0 argsno in
- let args2 = list_sub args' argsno rel.rel_quantifiers_no in
- if fst (CicReduction.are_convertible [] rel.rel_a (Cic.Appl (he'::args1))
- CicUniv.oblivion_ugraph) then
- args2
- else
- raise_error rel.rel_quantifiers_no
- | _ ->
- if rel.rel_quantifiers_no = 0 && fst (CicReduction.are_convertible []
- rel.rel_a t CicUniv.oblivion_ugraph) then
- []
- else
- begin
-(*COQ
- let evars,args,instantiated_rel_a =
- let ty = CicTypeChecker.type_of_aux' [] [] rel.rel_a
- CicUniv.oblivion_ugraph in
- let evd = Evd.create_evar_defs Evd.empty in
- let evars,args,concl =
- Clenv.clenv_environments_evars env evd
- (Some rel.rel_quantifiers_no) ty
- in
- evars, args,
- nf_betaiota
- (match args with [] -> rel.rel_a | _ -> applist (rel.rel_a,args))
- in
- let evars' =
- w_unify true (*??? or false? *) env Reduction.CONV (*??? or cumul? *)
- ~mod_delta:true (*??? or true? *) t instantiated_rel_a evars in
- let args' =
- List.map (Reductionops.nf_evar (Evd.evars_of evars')) args
- in
- args'
-*) assert false
- end
- in
- apply_to_relation args rel
-
-let unify_relation_class_carrier_with_type env rel t =
- match rel with
- Leibniz (Some t') ->
- if fst (CicReduction.are_convertible [] t t' CicUniv.oblivion_ugraph) then
- rel
- else
- raise (ProofEngineTypes.Fail (lazy
- ("One morphism argument or its output has type " ^ CicPp.ppterm t ^
- " but the signature requires an argument of type " ^
- CicPp.ppterm t')))
- | Leibniz None -> Leibniz (Some t)
- | Relation rel -> Relation (unify_relation_carrier_with_type env rel t)
-
-exception Impossible
-
-(*COQ
-(* first order matching with a bit of conversion *)
-(* Note: the type checking operations performed by the function could *)
-(* be done once and for all abstracting the morphism structure using *)
-(* the quantifiers. Would the new structure be more suited than the *)
-(* existent one for other tasks to? (e.g. pretty printing would expose *)
-(* much more information: is it ok or is it too much information?) *)
-let unify_morphism_with_arguments gl (c,al)
- {args=args; output=output; lem=lem; morphism_theory=morphism_theory} t
-=
- let allen = List.length al in
- let argsno = List.length args in
- if allen < argsno then raise Impossible; (* partial application *)
- let quantifiers,al' = Util.list_chop (allen - argsno) al in
- let c' = Cic.Appl (c::quantifiers) in
- if dependent t c' then raise Impossible;
- (* these are pf_type_of we could avoid *)
- let al'_type = List.map (Tacmach.pf_type_of gl) al' in
- let args' =
- List.map2
- (fun (var,rel) ty ->
- var,unify_relation_class_carrier_with_type (pf_env gl) rel ty)
- args al'_type in
- (* this is another pf_type_of we could avoid *)
- let ty = Tacmach.pf_type_of gl (Cic.Appl (c::al)) in
- let output' = unify_relation_class_carrier_with_type (pf_env gl) output ty in
- let lem' = Cic.Appl (lem::quantifiers) in
- let morphism_theory' = Cic.Appl (morphism_theory::quantifiers) in
- ({args=args'; output=output'; lem=lem'; morphism_theory=morphism_theory'},
- c',al')
-*) let unify_morphism_with_arguments _ _ _ _ = assert false
-
-let new_morphism m signature id hook =
-(*COQ
- if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
- raise (ProofEngineTypes.Fail (lazy (pr_id id ^ " already exists")))
- else
- let env = Global.env() in
- let typeofm = Typing.type_of env Evd.empty m in
- let typ = clos_norm_flags Closure.betaiotazeta empty_env Evd.empty typeofm in
- let argsrev, output =
- match signature with
- None -> decompose_prod typ
- | Some (_,output') ->
- (* the carrier of the relation output' can be a Prod ==>
- we must uncurry on the fly output.
- E.g: A -> B -> C vs A -> (B -> C)
- args output args output
- *)
- let rel = find_relation_class output' in
- let rel_a,rel_quantifiers_no =
- match rel with
- Relation rel -> rel.rel_a, rel.rel_quantifiers_no
- | Leibniz (Some t) -> t, 0
- | Leibniz None -> assert false in
- let rel_a_n =
- clos_norm_flags Closure.betaiotazeta empty_env Evd.empty rel_a in
- try
- let _,output_rel_a_n = decompose_lam_n rel_quantifiers_no rel_a_n in
- let argsrev,_ = decompose_prod output_rel_a_n in
- let n = List.length argsrev in
- let argsrev',_ = decompose_prod typ in
- let m = List.length argsrev' in
- decompose_prod_n (m - n) typ
- with UserError(_,_) ->
- (* decompose_lam_n failed. This may happen when rel_a is an axiom,
- a constructor, an inductive type, etc. *)
- decompose_prod typ
- in
- let args_ty = List.rev argsrev in
- let args_ty_len = List.length (args_ty) in
- let args_ty_quantifiers_rev,args,args_instance,output,output_instance =
- match signature with
- None ->
- if args_ty = [] then
- raise (ProofEngineTypes.Fail (lazy
- ("The term " ^ CicPp.ppterm m ^ " has type " ^
- CicPp.ppterm typeofm ^ " that is not a product."))) ;
- ignore (check_is_dependent 0 args_ty output) ;
- let args =
- List.map
- (fun (_,ty) -> None,default_relation_for_carrier ty) args_ty in
- let output = default_relation_for_carrier output in
- [],args,args,output,output
- | Some (args,output') ->
- assert (args <> []);
- let number_of_arguments = List.length args in
- let number_of_quantifiers = args_ty_len - number_of_arguments in
- if number_of_quantifiers < 0 then
- raise (ProofEngineTypes.Fail (lazy
- ("The morphism " ^ CicPp.ppterm m ^ " has type " ^
- CicPp.ppterm typeofm ^ " that attends at most " ^ int args_ty_len ^
- " arguments. The signature that you specified requires " ^
- int number_of_arguments ^ " arguments.")))
- else
- begin
- (* the real_args_ty returned are already delifted *)
- let args_ty_quantifiers_rev, real_args_ty, real_output =
- check_is_dependent number_of_quantifiers args_ty output in
- let quantifiers_rel_context =
- List.map (fun (n,t) -> n,None,t) args_ty_quantifiers_rev in
- let env = push_rel_context quantifiers_rel_context env in
- let find_relation_class t real_t =
- try
- let rel = find_relation_class t in
- rel, unify_relation_class_carrier_with_type env rel real_t
- with Not_found ->
- raise (ProofEngineTypes.Fail (lazy
- ("Not a valid signature: " ^ CicPp.ppterm t ^
- " is neither a registered relation nor the Leibniz " ^
- " equality.")))
- in
- let find_relation_class_v (variance,t) real_t =
- let relation,relation_instance = find_relation_class t real_t in
- match relation, variance with
- Leibniz _, None
- | Relation {rel_sym = Some _}, None
- | Relation {rel_sym = None}, Some _ ->
- (variance, relation), (variance, relation_instance)
- | Relation {rel_sym = None},None ->
- raise (ProofEngineTypes.Fail (lazy
- ("You must specify the variance in each argument " ^
- "whose relation is asymmetric.")))
- | Leibniz _, Some _
- | Relation {rel_sym = Some _}, Some _ ->
- raise (ProofEngineTypes.Fail (lazy
- ("You cannot specify the variance of an argument " ^
- "whose relation is symmetric.")))
- in
- let args, args_instance =
- List.split
- (List.map2 find_relation_class_v args real_args_ty) in
- let output,output_instance= find_relation_class output' real_output in
- args_ty_quantifiers_rev, args, args_instance, output, output_instance
- end
- in
- let argsconstr,outputconstr,lem =
- gen_compat_lemma_statement args_ty_quantifiers_rev output_instance
- args_instance (apply_to_rels m args_ty_quantifiers_rev) in
- (* "unfold make_compatibility_goal" *)
- let lem =
- Reductionops.clos_norm_flags
- (Closure.unfold_red (coq_make_compatibility_goal_eval_ref))
- env Evd.empty lem in
- (* "unfold make_compatibility_goal_aux" *)
- let lem =
- Reductionops.clos_norm_flags
- (Closure.unfold_red(coq_make_compatibility_goal_aux_eval_ref))
- env Evd.empty lem in
- (* "simpl" *)
- let lem = Tacred.nf env Evd.empty lem in
- if Lib.is_modtype () then
- begin
- ignore
- (Declare.declare_internal_constant id
- (ParameterEntry lem, IsAssumption Logical)) ;
- let mor_name = morphism_theory_id_of_morphism_proof_id id in
- let lemma_infos = Some (id,argsconstr,outputconstr) in
- add_morphism lemma_infos mor_name
- (m,args_ty_quantifiers_rev,args,output)
- end
- else
- begin
- new_edited id
- (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr);
- Pfedit.start_proof id (Global, Proof Lemma)
- (Declare.clear_proofs (Global.named_context ()))
- lem hook;
- Options.if_verbose msg (Printer.pr_open_subgoals ());
- end
-*) assert false
-
-let morphism_hook _ ref =
-(*COQ
- let pf_id = id_of_global ref in
- let mor_id = morphism_theory_id_of_morphism_proof_id pf_id in
- let (m,quantifiers_rev,args,argsconstr,output,outputconstr) =
- what_edited pf_id in
- if (is_edited pf_id)
- then
- begin
- add_morphism (Some (pf_id,argsconstr,outputconstr)) mor_id
- (m,quantifiers_rev,args,output) ;
- no_more_edited pf_id
- end
-*) assert false
-
-type morphism_signature =
- (bool option * Cic.term) list * Cic.term
-
-let new_named_morphism id m sign =
- new_morphism m sign id morphism_hook
-
-(************************** Adding a relation to the database *********************)
-
-let check_a a =
-(*COQ
- let typ = Typing.type_of env Evd.empty a in
- let a_quantifiers_rev,_ = Reduction.dest_arity env typ in
- a_quantifiers_rev
-*) assert false
-
-let check_eq a_quantifiers_rev a aeq =
-(*COQ
- let typ =
- Sign.it_mkProd_or_LetIn
- (Cic.Appl [coq_relation ; apply_to_rels a a_quantifiers_rev])
- a_quantifiers_rev in
- if
- not
- (is_conv env Evd.empty (Typing.type_of env Evd.empty aeq) typ)
- then
- raise (ProofEngineTypes.Fail (lazy
- (CicPp.ppterm aeq ^ " should have type (" ^ CicPp.ppterm typ ^ ")")))
-*) (assert false : unit)
-
-let check_property a_quantifiers_rev a aeq strprop coq_prop t =
-(*COQ
- if
- not
- (is_conv env Evd.empty (Typing.type_of env Evd.empty t)
- (Sign.it_mkProd_or_LetIn
- (Cic.Appl
- [coq_prop ;
- apply_to_rels a a_quantifiers_rev ;
- apply_to_rels aeq a_quantifiers_rev]) a_quantifiers_rev))
- then
- raise (ProofEngineTypes.Fail (lazy
- ("Not a valid proof of " ^ strprop ^ ".")))
-*) assert false
-
-let check_refl a_quantifiers_rev a aeq refl =
- check_property a_quantifiers_rev a aeq "reflexivity" coq_reflexive refl
-
-let check_sym a_quantifiers_rev a aeq sym =
- check_property a_quantifiers_rev a aeq "symmetry" coq_symmetric sym
-
-let check_trans a_quantifiers_rev a aeq trans =
- check_property a_quantifiers_rev a aeq "transitivity" coq_transitive trans
-;;
-
-let int_add_relation id a aeq refl sym trans =
-(*COQ
- let env = Global.env () in
-*)
- let a_quantifiers_rev = check_a a in
- check_eq a_quantifiers_rev a aeq ;
- HExtlib.iter_option (check_refl a_quantifiers_rev a aeq) refl ;
- HExtlib.iter_option (check_sym a_quantifiers_rev a aeq) sym ;
- HExtlib.iter_option (check_trans a_quantifiers_rev a aeq) trans ;
- let quantifiers_no = List.length a_quantifiers_rev in
- let aeq_rel =
- { rel_a = a;
- rel_aeq = aeq;
- rel_refl = refl;
- rel_sym = sym;
- rel_trans = trans;
- rel_quantifiers_no = quantifiers_no;
- rel_X_relation_class = Cic.Sort Cic.Prop; (* dummy value, overwritten below *)
- rel_Xreflexive_relation_class = Cic.Sort Cic.Prop (* dummy value, overwritten below *)
- } in
- let _x_relation_class =
- let subst =
- let len = List.length a_quantifiers_rev in
- list_map_i (fun i _ -> Cic.Rel (len - i + 2)) 0 a_quantifiers_rev in
- cic_relation_class_of_X_relation
- (Cic.Rel 2) (Cic.Rel 1) (apply_to_relation subst aeq_rel) in
- let _ =
-(*COQ
- Declare.declare_internal_constant id
- (DefinitionEntry
- {const_entry_body =
- Sign.it_mkLambda_or_LetIn x_relation_class
- ([ Name "v",None,Cic.Rel 1;
- Name "X",None,Cic.Sort (Cic.Type (CicUniv.fresh ()))] @
- a_quantifiers_rev);
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Options.boxed_definitions()},
- IsDefinition Definition) in
-*) () in
- let id_precise = id ^ "_precise_relation_class" in
- let _xreflexive_relation_class =
- let subst =
- let len = List.length a_quantifiers_rev in
- list_map_i (fun i _ -> Cic.Rel (len - i)) 0 a_quantifiers_rev
- in
- cic_precise_relation_class_of_relation (apply_to_relation subst aeq_rel) in
- let _ =
-(*COQ
- Declare.declare_internal_constant id_precise
- (DefinitionEntry
- {const_entry_body =
- Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev;
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Options.boxed_definitions() },
- IsDefinition Definition) in
-*) () in
- let aeq_rel =
- { aeq_rel with
- rel_X_relation_class = current_constant id;
- rel_Xreflexive_relation_class = current_constant id_precise } in
- relation_to_obj (aeq, aeq_rel) ;
- prerr_endline (CicPp.ppterm aeq ^ " is registered as a relation");
- match trans with
- None -> ()
- | Some trans ->
- let mor_name = id ^ "_morphism" in
- let a_instance = apply_to_rels a a_quantifiers_rev in
- let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
- let sym_instance =
- HExtlib.map_option (fun x -> apply_to_rels x a_quantifiers_rev) sym in
- let refl_instance =
- HExtlib.map_option (fun x -> apply_to_rels x a_quantifiers_rev) refl in
- let trans_instance = apply_to_rels trans a_quantifiers_rev in
- let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output =
- match sym_instance, refl_instance with
- None, None ->
- (Some false, Relation aeq_rel),
- (Some true, Relation aeq_rel),
- Cic.Appl
- [coq_equality_morphism_of_asymmetric_areflexive_transitive_relation;
- a_instance ; aeq_instance ; trans_instance],
- coq_impl_relation
- | None, Some refl_instance ->
- (Some false, Relation aeq_rel),
- (Some true, Relation aeq_rel),
- Cic.Appl
- [coq_equality_morphism_of_asymmetric_reflexive_transitive_relation;
- a_instance ; aeq_instance ; refl_instance ; trans_instance],
- coq_impl_relation
- | Some sym_instance, None ->
- (None, Relation aeq_rel),
- (None, Relation aeq_rel),
- Cic.Appl
- [coq_equality_morphism_of_symmetric_areflexive_transitive_relation;
- a_instance ; aeq_instance ; sym_instance ; trans_instance],
- coq_iff_relation
- | Some sym_instance, Some refl_instance ->
- (None, Relation aeq_rel),
- (None, Relation aeq_rel),
- Cic.Appl
- [coq_equality_morphism_of_symmetric_reflexive_transitive_relation;
- a_instance ; aeq_instance ; refl_instance ; sym_instance ;
- trans_instance],
- coq_iff_relation in
- let _ =
-(*COQ
- Declare.declare_internal_constant mor_name
- (DefinitionEntry
- {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev;
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Options.boxed_definitions()},
- IsDefinition Definition)
-*) ()
- in
- let a_quantifiers_rev =
- List.map (fun (n,b,t) -> assert (b = None); n,t) a_quantifiers_rev in
- add_morphism None mor_name
- (aeq,a_quantifiers_rev,[aeq_rel_class_and_var1; aeq_rel_class_and_var2],
- output)
-
-(* The vernac command "Add Relation ..." *)
-let add_relation id a aeq refl sym trans =
- int_add_relation id a aeq refl sym trans
-
-(****************************** The tactic itself *******************************)
-
-type direction =
- Left2Right
- | Right2Left
-
-let prdirection =
- function
- Left2Right -> "->"
- | Right2Left -> "<-"
-
-type constr_with_marks =
- | MApp of Cic.term * morphism_class * constr_with_marks list * direction
- | ToReplace
- | ToKeep of Cic.term * relation relation_class * direction
-
-let is_to_replace = function
- | ToKeep _ -> false
- | ToReplace -> true
- | MApp _ -> true
-
-let get_mark a =
- List.fold_left (||) false (List.map is_to_replace a)
-
-let cic_direction_of_direction =
- function
- Left2Right -> coq_Left2Right
- | Right2Left -> coq_Right2Left
-
-let opposite_direction =
- function
- Left2Right -> Right2Left
- | Right2Left -> Left2Right
-
-let direction_of_constr_with_marks hole_direction =
- function
- MApp (_,_,_,dir) -> cic_direction_of_direction dir
- | ToReplace -> hole_direction
- | ToKeep (_,_,dir) -> cic_direction_of_direction dir
-
-type argument =
- Toapply of Cic.term (* apply the function to the argument *)
- | Toexpand of Cic.name * Cic.term (* beta-expand the function w.r.t. an argument
- of this type *)
-let beta_expand c args_rev =
- let rec to_expand =
- function
- [] -> []
- | (Toapply _)::tl -> to_expand tl
- | (Toexpand (name,s))::tl -> (name,s)::(to_expand tl) in
- let rec aux n =
- function
- [] -> []
- | (Toapply arg)::tl -> arg::(aux n tl)
- | (Toexpand _)::tl -> (Cic.Rel n)::(aux (n + 1) tl)
- in
- compose_lambda (to_expand args_rev)
- (Cic.Appl (c :: List.rev (aux 1 args_rev)))
-
-exception Optimize (* used to fall-back on the tactic for Leibniz equality *)
-
-let rec list_sep_last = function
- | [] -> assert false
- | hd::[] -> (hd,[])
- | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
-
-let relation_class_that_matches_a_constr caller_name new_goals hypt =
- let heq, hargs =
- match hypt with
- Cic.Appl (heq::hargs) -> heq,hargs
- | _ -> hypt,[]
- in
- let rec get_all_but_last_two =
- function
- []
- | [_] ->
- raise (ProofEngineTypes.Fail (lazy (CicPp.ppterm hypt ^
- " is not a registered relation.")))
- | [_;_] -> []
- | he::tl -> he::(get_all_but_last_two tl) in
- let all_aeq_args = get_all_but_last_two hargs in
- let rec find_relation l subst =
- let aeq = Cic.Appl (heq::l) in
- try
- let rel = find_relation_class aeq in
- match rel,new_goals with
- Leibniz _,[] ->
- assert (subst = []);
- raise Optimize (* let's optimize the proof term size *)
- | Leibniz (Some _), _ ->
- assert (subst = []);
- rel
- | Leibniz None, _ ->
- (* for well-typedness reasons it should have been catched by the
- previous guard in the previous iteration. *)
- assert false
- | Relation rel,_ -> Relation (apply_to_relation subst rel)
- with Not_found ->
- if l = [] then
- raise (ProofEngineTypes.Fail (lazy
- (CicPp.ppterm (Cic.Appl (aeq::all_aeq_args)) ^
- " is not a registered relation.")))
- else
- let last,others = list_sep_last l in
- find_relation others (last::subst)
- in
- find_relation all_aeq_args []
-
-(* rel1 is a subrelation of rel2 whenever
- forall x1 x2, rel1 x1 x2 -> rel2 x1 x2
- The Coq part of the tactic, however, needs rel1 == rel2.
- Hence the third case commented out.
- Note: accepting user-defined subtrelations seems to be the last
- useful generalization that does not go against the original spirit of
- the tactic.
-*)
-let subrelation gl rel1 rel2 =
- match rel1,rel2 with
- Relation {rel_aeq=rel_aeq1}, Relation {rel_aeq=rel_aeq2} ->
- (*COQ Tacmach.pf_conv_x gl rel_aeq1 rel_aeq2*) assert false
- | Leibniz (Some t1), Leibniz (Some t2) ->
- (*COQ Tacmach.pf_conv_x gl t1 t2*) assert false
- | Leibniz None, _
- | _, Leibniz None -> assert false
-(* This is the commented out case (see comment above)
- | Leibniz (Some t1), Relation {rel_a=t2; rel_refl = Some _} ->
- Tacmach.pf_conv_x gl t1 t2
-*)
- | _,_ -> false
-
-(* this function returns the list of new goals opened by a constr_with_marks *)
-let rec collect_new_goals =
- function
- MApp (_,_,a,_) -> List.concat (List.map collect_new_goals a)
- | ToReplace
- | ToKeep (_,Leibniz _,_)
- | ToKeep (_,Relation {rel_refl=Some _},_) -> []
- | ToKeep (c,Relation {rel_aeq=aeq; rel_refl=None},_) -> [Cic.Appl[aeq;c;c]]
-
-(* two marked_constr are equivalent if they produce the same set of new goals *)
-let marked_constr_equiv_or_more_complex to_marked_constr gl c1 c2 =
- let glc1 = collect_new_goals (to_marked_constr c1) in
- let glc2 = collect_new_goals (to_marked_constr c2) in
- List.for_all (fun c -> List.exists (fun c' -> (*COQ pf_conv_x gl c c'*) assert false) glc1) glc2
-
-let pr_new_goals i c =
- let glc = collect_new_goals c in
- " " ^ string_of_int i ^ ") side conditions:" ^
- (if glc = [] then " no side conditions"
- else
- ("\n " ^
- String.concat "\n "
- (List.map (fun c -> " ... |- " ^ CicPp.ppterm c) glc)))
-
-(* given a list of constr_with_marks, it returns the list where
- constr_with_marks than open more goals than simpler ones in the list
- are got rid of *)
-let elim_duplicates gl to_marked_constr =
- let rec aux =
- function
- [] -> []
- | he:: tl ->
- if List.exists
- (marked_constr_equiv_or_more_complex to_marked_constr gl he) tl
- then aux tl
- else he::aux tl
- in
- aux
-
-let filter_superset_of_new_goals gl new_goals l =
- List.filter
- (fun (_,_,c) ->
- List.for_all
- (fun g -> List.exists ((*COQ pf_conv_x gl g*)assert false) (collect_new_goals c)) new_goals) l
-
-(* given the list of lists [ l1 ; ... ; ln ] it returns the list of lists
- [ c1 ; ... ; cn ] that is the cartesian product of the sets l1, ..., ln *)
-let cartesian_product gl a =
- let rec aux =
- function
- [] -> assert false
- | [he] -> List.map (fun e -> [e]) he
- | he::tl ->
- let tl' = aux tl in
- List.flatten
- (List.map (function e -> List.map (function l -> e :: l) tl') he)
- in
- aux (List.map (elim_duplicates gl (fun x -> x)) a)
-
-let does_not_occur n t = assert false
-
-let mark_occur gl ~new_goals t in_c input_relation input_direction =
- let rec aux output_relation output_direction in_c =
- if t = in_c then
- if input_direction = output_direction
- && subrelation gl input_relation output_relation then
- [ToReplace]
- else []
- else
- match in_c with
- | Cic.Appl (c::al) ->
- let mors_and_cs_and_als =
- let mors_and_cs_and_als =
- let morphism_table_find c =
- try morphism_table_find c with Not_found -> [] in
- let rec aux acc =
- function
- [] ->
- let c' = Cic.Appl (c::acc) in
- let al' = [] in
- List.map (fun m -> m,c',al') (morphism_table_find c')
- | (he::tl) as l ->
- let c' = Cic.Appl (c::acc) in
- let acc' = acc @ [he] in
- (List.map (fun m -> m,c',l) (morphism_table_find c')) @
- (aux acc' tl)
- in
- aux [] al in
- let mors_and_cs_and_als =
- List.map
- (function (m,c,al) ->
- relation_morphism_of_constr_morphism m, c, al)
- mors_and_cs_and_als in
- let mors_and_cs_and_als =
- List.fold_left
- (fun l (m,c,al) ->
- try (unify_morphism_with_arguments gl (c,al) m t) :: l
- with Impossible -> l
- ) [] mors_and_cs_and_als
- in
- List.filter
- (fun (mor,_,_) -> subrelation gl mor.output output_relation)
- mors_and_cs_and_als
- in
- (* First we look for well typed morphisms *)
- let res_mors =
- List.fold_left
- (fun res (mor,c,al) ->
- let a =
- let arguments = mor.args in
- let apply_variance_to_direction default_dir =
- function
- None -> default_dir
- | Some true -> output_direction
- | Some false -> opposite_direction output_direction
- in
- List.map2
- (fun a (variance,relation) ->
- (aux relation
- (apply_variance_to_direction Left2Right variance) a) @
- (aux relation
- (apply_variance_to_direction Right2Left variance) a)
- ) al arguments
- in
- let a' = cartesian_product gl a in
- (List.map
- (function a ->
- if not (get_mark a) then
- ToKeep (in_c,output_relation,output_direction)
- else
- MApp (c,ACMorphism mor,a,output_direction)) a') @ res
- ) [] mors_and_cs_and_als in
- (* Then we look for well typed functions *)
- let res_functions =
- (* the tactic works only if the function type is
- made of non-dependent products only. However, here we
- can cheat a bit by partially istantiating c to match
- the requirement when the arguments to be replaced are
- bound by non-dependent products only. *)
- let typeofc = (*COQ Tacmach.pf_type_of gl c*) assert false in
- let typ = (*COQ nf_betaiota typeofc*) let _ = typeofc in assert false in
- let rec find_non_dependent_function context c c_args_rev typ
- f_args_rev a_rev
- =
- function
- [] ->
- if a_rev = [] then
- [ToKeep (in_c,output_relation,output_direction)]
- else
- let a' =
- cartesian_product gl (List.rev a_rev)
- in
- List.fold_left
- (fun res a ->
- if not (get_mark a) then
- (ToKeep (in_c,output_relation,output_direction))::res
- else
- let err =
- match output_relation with
- Leibniz (Some typ') when (*COQ pf_conv_x gl typ typ'*) assert false ->
- false
- | Leibniz None -> assert false
- | _ when output_relation = coq_iff_relation
- -> false
- | _ -> true
- in
- if err then res
- else
- let mor =
- ACFunction{f_args=List.rev f_args_rev;f_output=typ} in
- let func = beta_expand c c_args_rev in
- (MApp (func,mor,a,output_direction))::res
- ) [] a'
- | (he::tl) as a->
- let typnf = (*COQ Reduction.whd_betadeltaiota env typ*) assert false in
- match typnf with
- Cic.Cast (typ,_) ->
- find_non_dependent_function context c c_args_rev typ
- f_args_rev a_rev a
- | Cic.Prod (name,s,t) ->
- let context' = Some (name, Cic.Decl s)::context in
- let he =
- (aux (Leibniz (Some s)) Left2Right he) @
- (aux (Leibniz (Some s)) Right2Left he) in
- if he = [] then []
- else
- let he0 = List.hd he in
- begin
- match does_not_occur 1 t, he0 with
- _, ToKeep (arg,_,_) ->
- (* invariant: if he0 = ToKeep (t,_,_) then every
- element in he is = ToKeep (t,_,_) *)
- assert
- (List.for_all
- (function
- ToKeep(arg',_,_) when (*COQpf_conv_x gl arg arg'*) assert false ->
- true
- | _ -> false) he) ;
- (* generic product, to keep *)
- find_non_dependent_function
- context' c ((Toapply arg)::c_args_rev)
- (CicSubstitution.subst arg t) f_args_rev a_rev tl
- | true, _ ->
- (* non-dependent product, to replace *)
- find_non_dependent_function
- context' c ((Toexpand (name,s))::c_args_rev)
- (CicSubstitution.lift 1 t) (s::f_args_rev) (he::a_rev) tl
- | false, _ ->
- (* dependent product, to replace *)
- (* This limitation is due to the reflexive
- implementation and it is hard to lift *)
- raise (ProofEngineTypes.Fail (lazy
- ("Cannot rewrite in the argument of a " ^
- "dependent product. If you need this " ^
- "feature, please report to the author.")))
- end
- | _ -> assert false
- in
- find_non_dependent_function (*COQ (Tacmach.pf_env gl) ci vuole il contesto*)(assert false) c [] typ [] []
- al
- in
- elim_duplicates gl (fun x -> x) (res_functions @ res_mors)
- | Cic.Prod (_, c1, c2) ->
- if (*COQ (dependent (Cic.Rel 1) c2)*) assert false
- then
- raise (ProofEngineTypes.Fail (lazy
- ("Cannot rewrite in the type of a variable bound " ^
- "in a dependent product.")))
- else
- let typeofc1 = (*COQ Tacmach.pf_type_of gl c1*) assert false in
- if not (*COQ (Tacmach.pf_conv_x gl typeofc1 (Cic.Sort Cic.Prop))*) (assert false) then
- (* to avoid this error we should introduce an impl relation
- whose first argument is Type instead of Prop. However,
- the type of the new impl would be Type -> Prop -> Prop
- that is no longer a Relation_Definitions.relation. Thus
- the Coq part of the tactic should be heavily modified. *)
- raise (ProofEngineTypes.Fail (lazy
- ("Rewriting in a product A -> B is possible only when A " ^
- "is a proposition (i.e. A is of type Prop). The type " ^
- CicPp.ppterm c1 ^ " has type " ^ CicPp.ppterm typeofc1 ^
- " that is not convertible to Prop.")))
- else
- aux output_relation output_direction
- (Cic.Appl [coq_impl; c1 ; CicSubstitution.subst (Cic.Rel 1 (*dummy*)) c2])
- | _ ->
- if (*COQ occur_term t in_c*) assert false then
- raise (ProofEngineTypes.Fail (lazy
- ("Trying to replace " ^ CicPp.ppterm t ^ " in " ^ CicPp.ppterm in_c ^
- " that is not an applicative context.")))
- else
- [ToKeep (in_c,output_relation,output_direction)]
- in
- let aux2 output_relation output_direction =
- List.map
- (fun res -> output_relation,output_direction,res)
- (aux output_relation output_direction in_c) in
- let res =
- (aux2 coq_iff_relation Right2Left) @
- (* This is the case of a proposition of signature A ++> iff or B --> iff *)
- (aux2 coq_iff_relation Left2Right) @
- (aux2 coq_impl_relation Right2Left) in
- let res = elim_duplicates gl (function (_,_,t) -> t) res in
- let res' = filter_superset_of_new_goals gl new_goals res in
- match res' with
- [] when res = [] ->
- raise (ProofEngineTypes.Fail (lazy
- ("Either the term " ^ CicPp.ppterm t ^ " that must be " ^
- "rewritten occurs in a covariant position or the goal is not " ^
- "made of morphism applications only. You can replace only " ^
- "occurrences that are in a contravariant position and such that " ^
- "the context obtained by abstracting them is made of morphism " ^
- "applications only.")))
- | [] ->
- raise (ProofEngineTypes.Fail (lazy
- ("No generated set of side conditions is a superset of those " ^
- "requested by the user. The generated sets of side conditions " ^
- "are:\n" ^
- prlist_with_sepi "\n"
- (fun i (_,_,mc) -> pr_new_goals i mc) res)))
- | [he] -> he
- | he::_ ->
- prerr_endline
- ("Warning: The application of the tactic is subject to one of " ^
- "the \nfollowing set of side conditions that the user needs " ^
- "to prove:\n" ^
- prlist_with_sepi "\n"
- (fun i (_,_,mc) -> pr_new_goals i mc) res' ^
- "\nThe first set is randomly chosen. Use the syntax " ^
- "\"setoid_rewrite ... generate side conditions ...\" to choose " ^
- "a different set.") ;
- he
-
-let cic_morphism_context_list_of_list hole_relation hole_direction out_direction
-=
- let check =
- function
- (None,dir,dir') ->
- Cic.Appl [coq_MSNone ; dir ; dir']
- | (Some true,dir,dir') ->
- assert (dir = dir');
- Cic.Appl [coq_MSCovariant ; dir]
- | (Some false,dir,dir') ->
- assert (dir <> dir');
- Cic.Appl [coq_MSContravariant ; dir] in
- let rec aux =
- function
- [] -> assert false
- | [(variance,out),(value,direction)] ->
- Cic.Appl [coq_singl ; coq_Argument_Class ; out],
- Cic.Appl
- [coq_fcl_singl;
- hole_relation; hole_direction ; out ;
- direction ; out_direction ;
- check (variance,direction,out_direction) ; value]
- | ((variance,out),(value,direction))::tl ->
- let outtl, valuetl = aux tl in
- Cic.Appl
- [coq_cons; coq_Argument_Class ; out ; outtl],
- Cic.Appl
- [coq_fcl_cons;
- hole_relation ; hole_direction ; out ; outtl ;
- direction ; out_direction ;
- check (variance,direction,out_direction) ;
- value ; valuetl]
- in aux
-
-let rec cic_type_nelist_of_list =
- function
- [] -> assert false
- | [value] ->
- Cic.Appl [coq_singl; Cic.Sort (Cic.Type (CicUniv.fresh ())) ; value]
- | value::tl ->
- Cic.Appl
- [coq_cons; Cic.Sort (Cic.Type (CicUniv.fresh ())); value;
- cic_type_nelist_of_list tl]
-
-let syntactic_but_representation_of_marked_but hole_relation hole_direction =
- let rec aux out (rel_out,precise_out,is_reflexive) =
- function
- MApp (f, m, args, direction) ->
- let direction = cic_direction_of_direction direction in
- let morphism_theory, relations =
- match m with
- ACMorphism { args = args ; morphism_theory = morphism_theory } ->
- morphism_theory,args
- | ACFunction { f_args = f_args ; f_output = f_output } ->
- let mt =
- if (*COQ eq_constr out (cic_relation_class_of_relation_class
- coq_iff_relation)*) assert false
- then
- Cic.Appl
- [coq_morphism_theory_of_predicate;
- cic_type_nelist_of_list f_args; f]
- else
- Cic.Appl
- [coq_morphism_theory_of_function;
- cic_type_nelist_of_list f_args; f_output; f]
- in
- mt,List.map (fun x -> None,Leibniz (Some x)) f_args in
- let cic_relations =
- List.map
- (fun (variance,r) ->
- variance,
- r,
- cic_relation_class_of_relation_class r,
- cic_precise_relation_class_of_relation_class r
- ) relations in
- let cic_args_relations,argst =
- cic_morphism_context_list_of_list hole_relation hole_direction direction
- (List.map2
- (fun (variance,trel,t,precise_t) v ->
- (variance,cic_argument_class_of_argument_class (variance,trel)),
- (aux t precise_t v,
- direction_of_constr_with_marks hole_direction v)
- ) cic_relations args)
- in
- Cic.Appl
- [coq_App;
- hole_relation ; hole_direction ;
- cic_args_relations ; out ; direction ;
- morphism_theory ; argst]
- | ToReplace ->
- Cic.Appl [coq_ToReplace ; hole_relation ; hole_direction]
- | ToKeep (c,_,direction) ->
- let direction = cic_direction_of_direction direction in
- if is_reflexive then
- Cic.Appl
- [coq_ToKeep ; hole_relation ; hole_direction ; precise_out ;
- direction ; c]
- else
- let c_is_proper =
- let typ = Cic.Appl [rel_out ; c ; c] in
- Cic.Cast ((*COQ Evarutil.mk_new_meta ()*)assert false, typ)
- in
- Cic.Appl
- [coq_ProperElementToKeep ;
- hole_relation ; hole_direction; precise_out ;
- direction; c ; c_is_proper]
- in aux
-
-let apply_coq_setoid_rewrite hole_relation prop_relation c1 c2 (direction,h)
- prop_direction m
-=
- let hole_relation = cic_relation_class_of_relation_class hole_relation in
- let hyp,hole_direction = h,cic_direction_of_direction direction in
- let cic_prop_relation = cic_relation_class_of_relation_class prop_relation in
- let precise_prop_relation =
- cic_precise_relation_class_of_relation_class prop_relation
- in
- Cic.Appl
- [coq_setoid_rewrite;
- hole_relation ; hole_direction ; cic_prop_relation ;
- prop_direction ; c1 ; c2 ;
- syntactic_but_representation_of_marked_but hole_relation hole_direction
- cic_prop_relation precise_prop_relation m ; hyp]
-
-(*COQ
-let check_evar_map_of_evars_defs evd =
- let metas = Evd.meta_list evd in
- let check_freemetas_is_empty rebus =
- Evd.Metaset.iter
- (fun m ->
- if Evd.meta_defined evd m then () else
- raise (Logic.RefinerError (Logic.OccurMetaGoal rebus)))
- in
- List.iter
- (fun (_,binding) ->
- match binding with
- Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
- check_freemetas_is_empty rebus freemetas
- | Evd.Clval (_,{Evd.rebus=rebus1; Evd.freemetas=freemetas1},
- {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
- check_freemetas_is_empty rebus1 freemetas1 ;
- check_freemetas_is_empty rebus2 freemetas2
- ) metas
-*)
-
-(* For a correct meta-aware "rewrite in", we split unification
- apart from the actual rewriting (Pierre L, 05/04/06) *)
-
-(* [unification_rewrite] searchs a match for [c1] in [but] and then
- returns the modified objects (in particular [c1] and [c2]) *)
-
-let unification_rewrite c1 c2 cl but gl =
-(*COQ
- let (env',c1) =
- try
- (* ~mod_delta:false to allow to mark occurences that must not be
- rewritten simply by replacing them with let-defined definitions
- in the context *)
- w_unify_to_subterm ~mod_delta:false (pf_env gl) (c1,but) cl.env
- with
- Pretype_errors.PretypeError _ ->
- (* ~mod_delta:true to make Ring work (since it really
- exploits conversion) *)
- w_unify_to_subterm ~mod_delta:true (pf_env gl) (c1,but) cl.env
- in
- let cl' = {cl with env = env' } in
- let c2 = Clenv.clenv_nf_meta cl' c2 in
- check_evar_map_of_evars_defs env' ;
- env',Clenv.clenv_value cl', c1, c2
-*) assert false
-
-(* no unification is performed in this function. [sigma] is the
- substitution obtained from an earlier unification. *)
-
-let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl =
- let but = (*COQ pf_concl gl*) assert false in
- try
- let input_relation =
- relation_class_that_matches_a_constr "Setoid_rewrite"
- new_goals ((*COQTyping.mtype_of (pf_env gl) sigma (snd hyp)*) assert false) in
- let output_relation,output_direction,marked_but =
- mark_occur gl ~new_goals c1 but input_relation (fst hyp) in
- let cic_output_direction = cic_direction_of_direction output_direction in
- let if_output_relation_is_iff gl =
- let th =
- apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp
- cic_output_direction marked_but
- in
- let new_but = (*COQ Termops.replace_term c1 c2 but*) assert false in
- let hyp1,hyp2,proj =
- match output_direction with
- Right2Left -> new_but, but, coq_proj1
- | Left2Right -> but, new_but, coq_proj2
- in
- let impl1 = Cic.Prod (Cic.Anonymous, hyp2, CicSubstitution.lift 1 hyp1) in
- let impl2 = Cic.Prod (Cic.Anonymous, hyp1, CicSubstitution.lift 1 hyp2) in
- let th' = Cic.Appl [proj; impl2; impl1; th] in
- (*COQ Tactics.refine
- (Cic.Appl [th'; mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)])
- gl*) let _ = th' in assert false in
- let if_output_relation_is_if gl =
- let th =
- apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp
- cic_output_direction marked_but
- in
- let new_but = (*COQ Termops.replace_term c1 c2 but*) assert false in
- (*COQ Tactics.refine
- (Cic.Appl [th ; mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)])
- gl*) let _ = new_but,th in assert false in
- if output_relation = coq_iff_relation then
- if_output_relation_is_iff gl
- else
- if_output_relation_is_if gl
- with
- Optimize ->
- (*COQ !general_rewrite (fst hyp = Left2Right) (snd hyp) gl*) assert false
-
-let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl =
- let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl ((*COQ pf_concl gl*) assert false) gl in
- relation_rewrite_no_unif c1 c2 (input_direction,cl) ~new_goals sigma gl
-
-let analyse_hypothesis gl c =
- let ctype = (*COQ pf_type_of gl c*) assert false in
- let eqclause = (*COQ Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings*) let _ = ctype in assert false in
- let (equiv, args) = (*COQ decompose_app (Clenv.clenv_type eqclause)*) assert false in
- let rec split_last_two = function
- | [c1;c2] -> [],(c1, c2)
- | x::y::z ->
- let l,res = split_last_two (y::z) in x::l, res
- | _ -> raise (ProofEngineTypes.Fail (lazy "The term provided is not an equivalence")) in
- let others,(c1,c2) = split_last_two args in
- eqclause,Cic.Appl (equiv::others),c1,c2
-
-let general_s_rewrite lft2rgt c ~new_goals (*COQgl*) =
-(*COQ
- let eqclause,_,c1,c2 = analyse_hypothesis gl c in
- if lft2rgt then
- relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl
- else
- relation_rewrite c2 c1 (Right2Left,eqclause) ~new_goals gl
-*) assert false
-
-let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl =
- let hyp = (*COQ pf_type_of gl (mkVar id)*) assert false in
- (* first, we find a match for c1 in the hyp *)
- let (sigma,cl,c1,c2) = unification_rewrite c1 c2 eqclause hyp gl in
- (* since we will actually rewrite in the opposite direction, we also need
- to replace every occurrence of c2 (resp. c1) in hyp with something that
- is convertible but not syntactically equal. To this aim we introduce a
- let-in and then we will use the intro tactic to get rid of it.
- Quite tricky to do properly since c1 can occur in c2 or vice-versa ! *)
- let mangled_new_hyp =
- let hyp = CicSubstitution.lift 2 hyp in
- (* first, we backup every occurences of c1 in newly allocated (Rel 1) *)
- let hyp = (*COQ Termops.replace_term (CicSubstitution.lift 2 c1) (Cic.Rel 1) hyp*) let _ = hyp in assert false in
- (* then, we factorize every occurences of c2 into (Rel 2) *)
- let hyp = (*COQ Termops.replace_term (CicSubstitution.lift 2 c2) (Cic.Rel 2) hyp*) let _ = hyp in assert false in
- (* Now we substitute (Rel 1) (i.e. c1) for c2 *)
- let hyp = CicSubstitution.subst (CicSubstitution.lift 1 c2) hyp in
- (* Since CicSubstitution.subst has killed Rel 1 and decreased the other Rels,
- Rel 1 is now coding for c2, we can build the let-in factorizing c2 *)
- Cic.LetIn (Cic.Anonymous,c2,assert false,hyp)
- in
- let new_hyp = (*COQ Termops.replace_term c1 c2 hyp*) assert false in
- let oppdir = opposite_direction direction in
-(*COQ
- cut_replacing id new_hyp
- (tclTHENLAST
- (tclTHEN (change_in_concl None mangled_new_hyp)
- (tclTHEN intro
- (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma))))
- gl
-*) let _ = oppdir,new_hyp,mangled_new_hyp in assert false
-
-let general_s_rewrite_in id lft2rgt c ~new_goals (*COQgl*) =
-(*COQ
- let eqclause,_,c1,c2 = analyse_hypothesis gl c in
- if lft2rgt then
- relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl
- else
- relation_rewrite_in id c2 c1 (Right2Left,eqclause) ~new_goals gl
-*) assert false
-
-let setoid_replace relation c1 c2 ~new_goals (*COQgl*) =
- try
- let relation =
- match relation with
- Some rel ->
- (try
- match find_relation_class rel with
- Relation sa -> sa
- | Leibniz _ -> raise Optimize
- with
- Not_found ->
- raise (ProofEngineTypes.Fail (lazy
- (CicPp.ppterm rel ^ " is not a registered relation."))))
- | None ->
- match default_relation_for_carrier ((*COQ pf_type_of gl c1*) assert false) with
- Relation sa -> sa
- | Leibniz _ -> raise Optimize
- in
- let eq_left_to_right = Cic.Appl [relation.rel_aeq; c1 ; c2] in
- let eq_right_to_left = Cic.Appl [relation.rel_aeq; c2 ; c1] in
-(*COQ
- let replace dir eq =
- tclTHENS (assert_tac false Cic.Anonymous eq)
- [onLastHyp (fun id ->
- tclTHEN
- (general_s_rewrite dir (mkVar id) ~new_goals)
- (clear [id]));
- Tacticals.tclIDTAC]
- in
- tclORELSE
- (replace true eq_left_to_right) (replace false eq_right_to_left) gl
-*) let _ = eq_left_to_right,eq_right_to_left in assert false
- with
- Optimize -> (*COQ (!replace c1 c2) gl*) assert false
-
-let setoid_replace_in id relation c1 c2 ~new_goals (*COQgl*) =
-(*COQ
- let hyp = pf_type_of gl (mkVar id) in
- let new_hyp = Termops.replace_term c1 c2 hyp in
- cut_replacing id new_hyp
- (fun exact -> tclTHENLASTn
- (setoid_replace relation c2 c1 ~new_goals)
- [| exact; tclIDTAC |]) gl
-*) assert false
-
-(* [setoid_]{reflexivity,symmetry,transitivity} tactics *)
-
-let setoid_reflexivity_tac =
- let tac ((proof,goal) as status) =
- let (_,metasenv,_subst,_,_, _) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- try
- let relation_class =
- relation_class_that_matches_a_constr "Setoid_reflexivity" [] ty in
- match relation_class with
- Leibniz _ -> assert false (* since [] is empty *)
- | Relation rel ->
- match rel.rel_refl with
- None ->
- raise (ProofEngineTypes.Fail (lazy
- ("The relation " ^ prrelation rel ^ " is not reflexive.")))
- | Some refl ->
- ProofEngineTypes.apply_tactic (PrimitiveTactics.apply_tac refl)
- status
- with
- Optimize ->
- ProofEngineTypes.apply_tactic EqualityTactics.reflexivity_tac status
- in
- ProofEngineTypes.mk_tactic tac
-
-let setoid_reflexivity_tac =
- let start_tac = RT.whd_tac ~pattern:(PET.conclusion_pattern None) in
- let fail_tac = T.then_ ~start:start_tac ~continuation:setoid_reflexivity_tac in
- T.if_ ~start:setoid_reflexivity_tac ~continuation:T.id_tac ~fail:fail_tac
-
-let setoid_symmetry =
- let tac status =
- try
- let relation_class =
- relation_class_that_matches_a_constr "Setoid_symmetry"
- [] ((*COQ pf_concl gl*) assert false) in
- match relation_class with
- Leibniz _ -> assert false (* since [] is empty *)
- | Relation rel ->
- match rel.rel_sym with
- None ->
- raise (ProofEngineTypes.Fail (lazy
- ("The relation " ^ prrelation rel ^ " is not symmetric.")))
- | Some sym -> (*COQ apply sym gl*) assert false
- with
- Optimize -> (*COQ symmetry gl*) assert false
- in
- ProofEngineTypes.mk_tactic tac
-
-let setoid_symmetry_in id (*COQgl*) =
-(*COQ
- let new_hyp =
- let _,he,c1,c2 = analyse_hypothesis gl (mkVar id) in
- Cic.Appl [he ; c2 ; c1]
- in
- cut_replacing id new_hyp (tclTHEN setoid_symmetry) gl
-*) assert false
-
-let setoid_transitivity c (*COQgl*) =
- try
- let relation_class =
- relation_class_that_matches_a_constr "Setoid_transitivity"
- [] ((*COQ pf_concl gl*) assert false) in
- match relation_class with
- Leibniz _ -> assert false (* since [] is empty *)
- | Relation rel ->
-(*COQ
- let ctyp = pf_type_of gl c in
- let rel' = unify_relation_carrier_with_type (pf_env gl) rel ctyp in
- match rel'.rel_trans with
- None ->
- raise (ProofEngineTypes.Fail (lazy
- ("The relation " ^ prrelation rel ^ " is not transitive.")))
- | Some trans ->
- let transty = nf_betaiota (pf_type_of gl trans) in
- let argsrev, _ =
- Reductionops.decomp_n_prod (pf_env gl) Evd.empty 2 transty in
- let binder =
- match List.rev argsrev with
- _::(Name n2,None,_)::_ -> Rawterm.NamedHyp n2
- | _ -> assert false
- in
- apply_with_bindings
- (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl
-*) assert false
- with
- Optimize -> (*COQ transitivity c gl*) assert false
-;;
-
-(*COQ
-Tactics.register_setoid_reflexivity setoid_reflexivity;;
-Tactics.register_setoid_symmetry setoid_symmetry;;
-Tactics.register_setoid_symmetry_in setoid_symmetry_in;;
-Tactics.register_setoid_transitivity setoid_transitivity;;
-*)
+++ /dev/null
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(*i $Id: setoid_replace.mli 8779 2006-05-02 20:59:21Z letouzey $ i*)
-
-type relation =
- { rel_a: Cic.term ;
- rel_aeq: Cic.term;
- rel_refl: Cic.term option;
- rel_sym: Cic.term option;
- rel_trans : Cic.term option;
- rel_quantifiers_no: int (* it helps unification *);
- rel_X_relation_class: Cic.term;
- rel_Xreflexive_relation_class: Cic.term
- }
-
-type 'a relation_class =
- Relation of 'a (* the [rel_aeq] of the relation or the relation*)
- | Leibniz of Cic.term option (* the [carrier] (if [eq] is partially instantiated)*)
-
-type 'a morphism =
- { args : (bool option * 'a relation_class) list;
- output : 'a relation_class;
- lem : Cic.term;
- morphism_theory : Cic.term
- }
-
-type morphism_signature = (bool option * Cic.term) list * Cic.term
-
-val register_replace : (Cic.term -> Cic.term -> ProofEngineTypes.tactic) -> unit
-val register_general_rewrite : (bool -> Cic.term -> ProofEngineTypes.tactic) -> unit
-
-val print_setoids : unit -> unit
-
-val equiv_list : unit -> Cic.term list
-val default_relation_for_carrier :
- ?filter:(relation -> bool) -> Cic.term -> relation relation_class
-(* [default_morphism] raises [Not_found] *)
-val default_morphism :
- ?filter:(Cic.term morphism -> bool) -> Cic.term -> relation morphism
-
-val setoid_replace :
- Cic.term option -> Cic.term -> Cic.term -> new_goals:Cic.term list -> ProofEngineTypes.tactic
-val setoid_replace_in :
- string -> Cic.term option -> Cic.term -> Cic.term -> new_goals:Cic.term list ->
- ProofEngineTypes.tactic
-
-val general_s_rewrite : bool -> Cic.term -> new_goals:Cic.term list -> ProofEngineTypes.tactic
-val general_s_rewrite_in :
- string -> bool -> Cic.term -> new_goals:Cic.term list -> ProofEngineTypes.tactic
-
-val setoid_reflexivity_tac : ProofEngineTypes.tactic
-val setoid_symmetry : ProofEngineTypes.tactic
-val setoid_symmetry_in : string -> ProofEngineTypes.tactic
-val setoid_transitivity : Cic.term -> ProofEngineTypes.tactic
-
-val add_relation :
- string -> Cic.term -> Cic.term -> Cic.term option ->
- Cic.term option -> Cic.term option -> unit
-
-val new_named_morphism :
- string -> Cic.term -> morphism_signature option -> unit
-
-val relation_table_find : Cic.term -> relation
-val relation_table_mem : Cic.term -> bool
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-let default_history_size = 20
-
-exception No_goal_left
-exception Uri_redefinition
-type event = [ `Proof_changed | `Proof_completed ]
-let all_events = [ `Proof_changed; `Proof_completed ]
-let default_events: event list = [ `Proof_changed ]
-
-type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option
-
-type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit
-type observer_id = int
-
-exception Observer_failures of (observer_id * exn) list
-exception Tactic_failure of exn
-exception Data_failure of exn
-
-class ['a] status
- ?(history_size = default_history_size)
- ?uri ~typ ~body ~metasenv ~attrs init_data compute_data ()
- =
- let next_observer_id =
- let next_id = ref 0 in
- fun () ->
- incr next_id;
- !next_id
- in
- let _subst = ([] : Cic.substitution) in
- let initial_proof = ((uri: UriManager.uri option), metasenv, _subst, body, typ, attrs) in
- let next_goal (goals, proof) =
- match goals, proof with
- | goal :: _, _ -> Some goal
- | [], (_, (goal, _, _) :: _, _, _, _, _) ->
- (* the tactic left no open goal: let's choose the first open goal *)
- Some goal
- | _, _ -> None
- in
- let initial_goal = next_goal ([], initial_proof) in
- object (self)
-
- val mutable _proof = initial_proof
- val mutable _goal = initial_goal
- val mutable _data: 'a = init_data (initial_proof, initial_goal)
-
- (* event -> (id, observer) list *)
- val observers = Hashtbl.create 7
-
- (* assumption: all items in history are uncompleted proofs, thus option on
- * goal could be ignored and goal are stored as bare integers *)
- val history = new History.history history_size
-
- initializer
- history#push self#internal_status
-
- method proof = _proof
- method private status = (_proof, _goal) (* logic status *)
- method private set_status (proof, (goal: int option)) =
- _proof <- proof;
- _goal <- goal
-
- method goal =
- match _goal with
- | Some goal -> goal
- | None -> raise No_goal_left
-
- (* what will be kept in history *)
- method private internal_status = (self#status, _data)
- method private set_internal_status (status, data) =
- self#set_status status;
- _data <- data
-
- method set_goal goal =
- _goal <- Some goal
-(*
- let old_internal_status = self#internal_status in
- _goal <- Some goal;
- try
- self#update_data old_internal_status;
- history#push self#internal_status;
- self#private_notify (Some old_internal_status)
- with (Data_failure _) as exn ->
- self#set_internal_status old_internal_status;
- raise exn
-*)
-
- method uri = let (uri, _, _, _, _, _) = _proof in uri
- method metasenv = let (_, metasenv, _, _, _, _) = _proof in metasenv
- method body = let (_, _, _, body, _, _) = _proof in body
- method typ = let (_, _, _, _, typ, _) = _proof in typ
- method attrs = let (_, _, _, _, _, attrs) = _proof in attrs
-
- method set_metasenv metasenv =
- let (uri, _, _subst,body, typ, attes) = _proof in
- _proof <- (uri, metasenv, _subst,body, typ, attrs)
-
- method set_uri uri =
- let (old_uri, metasenv, _subst,body, typ, attrs) = _proof in
- if old_uri <> None then
- raise Uri_redefinition;
- _proof <- (Some uri, metasenv, _subst,body, typ, attrs)
-
- method conjecture goal =
- let (_, metasenv, _subst, _, _, _) = _proof in
- CicUtil.lookup_meta goal metasenv
-
- method apply_tactic tactic =
- let old_internal_status = self#internal_status in
- let (new_proof, new_goals) =
- try
- ProofEngineTypes.apply_tactic tactic (_proof, self#goal)
- with exn -> raise (Tactic_failure exn)
- in
- _proof <- new_proof;
- _goal <- next_goal (new_goals, new_proof);
- try
- self#update_data old_internal_status;
- history#push self#internal_status;
- self#private_notify (Some old_internal_status)
- with (Data_failure _) as exn ->
- self#set_internal_status old_internal_status;
- raise exn
-
- method proof_completed = _goal = None
-
- method attach_observer ?(interested_in = default_events) observer
- =
- let id = next_observer_id () in
- List.iter
- (fun event ->
- let prev_observers =
- try Hashtbl.find observers event with Not_found -> []
- in
- Hashtbl.replace observers event ((id, observer)::prev_observers))
- interested_in;
- id
-
- method detach_observer id =
- List.iter
- (fun event ->
- let prev_observers =
- try Hashtbl.find observers event with Not_found -> []
- in
- let new_observers =
- List.filter (fun (id', _) -> id' <> id) prev_observers
- in
- Hashtbl.replace observers event new_observers)
- all_events
-
- method private private_notify old_internal_status =
- let cur_internal_status = (self#status, _data) in
- let exns = ref [] in
- let notify (id, observer) =
- try
- observer old_internal_status cur_internal_status
- with exn -> exns := (id, exn) :: !exns
- in
- List.iter notify
- (try Hashtbl.find observers `Proof_changed with Not_found -> []);
- if self#proof_completed then
- List.iter notify
- (try Hashtbl.find observers `Proof_completed with Not_found -> []);
- match !exns with
- | [] -> ()
- | exns -> raise (Observer_failures exns)
-
- method private update_data old_internal_status =
- (* invariant: _goal and/or _proof has been changed
- * invariant: proof is not yet completed *)
- let status = self#status in
- try
- _data <- compute_data old_internal_status status
- with exn -> raise (Data_failure exn)
-
- method undo ?(steps = 1) () =
- let ((proof, goal), data) = history#undo steps in
- _proof <- proof;
- _goal <- goal;
- _data <- data;
- self#private_notify None
-
- method redo ?(steps = 1) () = self#undo ~steps:~-steps ()
-
- method notify = self#private_notify None
-
- end
-
-let trivial_status ?uri ~typ ~body ~metasenv ~attrs () =
- new status ?uri ~typ ~body ~metasenv ~attrs (fun _ -> ()) (fun _ _ -> ()) ()
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(** Stateful handling of proof status *)
-
-exception No_goal_left
-exception Uri_redefinition
-
-type event = [ `Proof_changed | `Proof_completed ]
-
-val all_events: event list
-
- (** from our point of view a status is the status of an incomplete proof, thus
- * we have an optional goal which is None if the proof is not yet completed
- * (i.e. some goal is still open) *)
-type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option
-
- (** Proof observer. First callback argument is Some extended_status
- * when a 'real 'change of the proof happened and None when Proof_changed event
- * was triggered by a time travel by the means of undo/redo actions or by an
- * external "#notify" invocation. Embedded status is the status _before_ the
- * current change. Second status is the status reached _after_ the current
- * change. *)
-type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit
-
- (** needed to detach previously attached observers *)
-type observer_id
-
- (** tactic application failed. @see apply_tactic *)
-exception Tactic_failure of exn
-
- (** one or more observers failed. @see apply_tactic *)
-exception Observer_failures of (observer_id * exn) list
-
- (** failure while updating internal data (: 'a). @see apply_tactic *)
-exception Data_failure of exn
-
-(** {2 OO interface} *)
-
-class ['a] status:
- ?history_size:int -> (** default 20 *)
- ?uri:UriManager.uri ->
- typ:Cic.term -> body:Cic.term Lazy.t -> metasenv:Cic.metasenv ->
- attrs:Cic.attribute list ->
- (proof_status -> 'a) -> (* init data *)
- (proof_status * 'a -> proof_status -> 'a) -> (* update data *)
- unit ->
- object
-
- method proof: ProofEngineTypes.proof
- method metasenv: Cic.metasenv
- method body: Cic.term Lazy.t
- method typ: Cic.term
- method attrs: Cic.attribute list
-
- (** change metasenv _without_ triggering any notification *)
- method set_metasenv: Cic.metasenv -> unit
-
- (** goal -> conjecture
- * @raise CicUtil.Meta_not_found *)
- method conjecture: int -> Cic.conjecture
-
- method proof_completed: bool
- method goal: int (** @raise No_goal_left *)
- method set_goal: int -> unit (** @raise Data_failure *)
-
- method uri: UriManager.uri option
- method set_uri: UriManager.uri -> unit (** @raise Uri_redefinition *)
-
- (** @raise Tactic_failure
- * @raise Observer_failures
- * @raise Data_failure
- *
- * In case of tactic failure, internal status is left unchanged.
- * In case of observer failures internal status will be changed and is
- * granted that all observer will be invoked collecting their failures.
- * In case of data failure, internal status is left unchanged (rolling back
- * last tactic application if needed)
- *)
- method apply_tactic: ProofEngineTypes.tactic -> unit
-
- method undo: ?steps:int -> unit -> unit
- method redo: ?steps:int -> unit -> unit
-
- method attach_observer:
- ?interested_in:(event list) -> 'a observer -> observer_id
-
- method detach_observer: observer_id -> unit
-
- (** force a notification to all observer, old status is passed as None *)
- method notify: unit
-
- end
-
-val trivial_status:
- ?uri:UriManager.uri ->
- typ:Cic.term -> body:Cic.term Lazy.t -> metasenv:Cic.metasenv ->
- attrs:Cic.attribute list ->
- unit ->
- unit status
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 18/02/2003 *)
-(* *)
-(* *)
-(*****************************************************************************)
-
-(* $Id$ *)
-
-module MQI = MQueryInterpreter
-module MQIC = MQIConn
-module I = MQueryInterpreter
-module U = MQGUtil
-module G = MQueryGenerator
-
- (* search arguments on which Apply tactic doesn't fail *)
-let matchConclusion mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status =
- let ((_, metasenv, _, _), metano) = status in
- let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in
- let list_of_must, only = CGMatchConclusion.get_constraints metasenv ey ty in
-match list_of_must with
- [] -> []
-|_ ->
- let must = choose_must list_of_must only in
- let result =
- I.execute mqi_handle
- (G.query_of_constraints
- (Some CGMatchConclusion.universe)
- (must,[],[]) (Some only,None,None)) in
- let uris =
- List.map
- (function uri,_ ->
- MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri
- ) result
- in
- let uris =
- (* TODO ristretto per ragioni di efficienza *)
- prerr_endline "STO FILTRANDO";
- List.filter (fun uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris
- in
- prerr_endline "HO FILTRATO";
- let uris',exc =
- let rec filter_out =
- function
- [] -> [],""
- | uri::tl ->
- let tl',exc = filter_out tl in
- try
- if
- let time = Unix.gettimeofday() in
- (try
- ignore(ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac
- ~term:(MQueryMisc.term_of_cic_textual_parser_uri
- (MQueryMisc.cic_textual_parser_uri_of_string uri)))
- status);
- let time1 = Unix.gettimeofday() in
- prerr_endline (Printf.sprintf "%1.3f" (time1 -. time) );
- true
- with ProofEngineTypes.Fail _ ->
- let time1 = Unix.gettimeofday() in
- prerr_endline (Printf.sprintf "%1.3f" (time1 -. time)); false)
- then
- uri::tl',exc
- else
- tl',exc
- with
- (ProofEngineTypes.Fail _) as e ->
- let exc' =
- "<h1 color=\"red\"> ^ Exception raised trying to apply " ^
- uri ^ ": " ^ Printexc.to_string e ^ " </h1>" ^ exc
- in
- tl',exc'
- in
- filter_out uris
- in
- let html' =
- " <h1>Objects that can actually be applied: </h1> " ^
- String.concat "<br>" uris' ^ exc ^
- " <h1>Number of false matches: " ^
- string_of_int (List.length uris - List.length uris') ^ "</h1>" ^
- " <h1>Number of good matches: " ^
- string_of_int (List.length uris') ^ "</h1>"
- in
- output_html html' ;
- uris'
-;;
-
-
-(*matchConclusion modificata per evitare una doppia apply*)
-let matchConclusion2 mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status =
- let ((_, metasenv, _, _), metano) = status in
- let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in
- let conn =
- match mqi_handle.MQIConn.pgc with
- MQIConn.MySQL_C conn -> conn
- | _ -> assert false in
- let uris = Match_concl.cmatch conn ty in
- (* List.iter
- (fun (n,u) -> prerr_endline ((string_of_int n) ^ " " ^u)) uris; *)
- (* delete all .var uris *)
- let uris = List.filter UriManager.is_var uris in
- (* delete all not "cic:/Coq" uris *)
- (*
- let uris =
- (* TODO ristretto per ragioni di efficienza *)
- List.filter (fun _,uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris in
- *)
- (* concl_cost are the costants in the conclusion of the proof
- while hyp_const are the constants in the hypothesis *)
- let (main_concl,concl_const) = NewConstraints.mainandcons ty in
- prerr_endline ("Ne sono rimasti" ^ string_of_int (List.length uris));
- let hyp t set =
- match t with
- Some (_,Cic.Decl t) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t))
- | Some (_,Cic.Def (t,_)) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t))
- | _ -> set in
- let hyp_const =
- List.fold_right hyp ey NewConstraints.StringSet.empty in
- prerr_endline (NewConstraints.pp_StringSet (NewConstraints.StringSet.union hyp_const concl_const));
- (* uris with new constants in the proof are filtered *)
- let all_const = NewConstraints.StringSet.union hyp_const concl_const in
- let uris =
- if (List.length uris < (Filter_auto.power 2 (List.length (NewConstraints.StringSet.elements all_const))))
- then
- (prerr_endline("metodo vecchio");List.filter (Filter_auto.filter_new_constants conn all_const) uris)
- else Filter_auto.filter_uris conn all_const uris main_concl in
-(*
- let uris =
- (* ristretto all cache *)
- prerr_endline "SOLO CACHE";
- List.filter
- (fun uri -> CicEnvironment.in_cache (UriManager.uri_of_string uri)) uris
- in
- prerr_endline "HO FILTRATO2";
-*)
- let uris =
- List.map
- (fun (n,u) ->
- (n,MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' u))
- uris in
- let uris' =
- let rec filter_out =
- function
- [] -> []
- | (m,uri)::tl ->
- let tl' = filter_out tl in
- try
- prerr_endline ("STO APPLICANDO " ^ uri);
- let res = (m,
- (ProofEngineTypes.apply_tactic( PrimitiveTactics.apply_tac
- ~term:(MQueryMisc.term_of_cic_textual_parser_uri
- (MQueryMisc.cic_textual_parser_uri_of_string uri)))
- status))::tl' in
- prerr_endline ("OK");res
- (* with ProofEngineTypes.Fail _ -> tl' *)
- (* patch to cover CSC's exportation bug *)
- with _ -> prerr_endline ("FAIL");tl'
- in
- prerr_endline ("Ne sono rimasti 2 " ^ string_of_int (List.length uris));
- filter_out uris
- in
- prerr_endline ("Ne sono rimasti 3 " ^ string_of_int (List.length uris'));
-
- uris'
-;;
-
-(*funzione che sceglie il penultimo livello di profondita' dei must*)
-
-(*
-let choose_must list_of_must only=
-let n = (List.length list_of_must) - 1 in
- List.nth list_of_must n
-;;*)
-
-(* questa prende solo il main *)
-let choose_must list_of_must only =
- List.nth list_of_must 0
-
-(* livello 1
-let choose_must list_of_must only =
- try
- List.nth list_of_must 1
- with _ ->
- List.nth list_of_must 0 *)
-
-let searchTheorems mqi_handle (proof,goal) =
- let subproofs =
- matchConclusion2 mqi_handle ~choose_must() (proof, goal) in
- let res =
- List.sort
- (fun (n1,(_,gl1)) (n2,(_,gl2)) ->
- let l1 = List.length gl1 in
- let l2 = List.length gl2 in
- (* if the list of subgoals have the same lenght we use the
- prefix tag, where higher tags have precedence *)
- if l1 = l2 then n2 - n1
- else l1 - l2)
- subproofs
- in
- (* now we may drop the prefix tag *)
- (*let res' =
- List.map snd res in*)
- let order_goal_list proof goal1 goal2 =
- let _,metasenv,_,_ = proof in
- let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in
- let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in
-(*
- prerr_endline "PRIMA DELLA PRIMA TYPE OF " ;
-*)
- let ty_sort1,u = (*TASSI: FIXME *)
- CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.oblivion_ugraph in
-(*
- prerr_endline (Printf.sprintf "PRIMA DELLA SECONDA TYPE OF %s \n### %s @@@%s " (CicMetaSubst.ppmetasenv metasenv []) (CicMetaSubst.ppcontext [] ey2) (CicMetaSubst.ppterm [] ty2));
-*)
- let ty_sort2,u1 = CicTypeChecker.type_of_aux' metasenv ey2 ty2 u in
-(*
- prerr_endline "DOPO LA SECONDA TYPE OF " ;
-*)
- let b,u2 =
- CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1 u1 in
- let prop1 = if b then 0 else 1 in
- let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2 u2 in
- let prop2 = if b then 0 else 1 in
- prop1 - prop2 in
- List.map (
- fun (level,(proof,goallist)) ->
- (proof, (List.stable_sort (order_goal_list proof) goallist))
- ) res
-;;
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-(* open CicReduction
-open ProofEngineTypes
-open UriManager *)
-
-(** DEBUGGING *)
-
- (** perform debugging output? *)
-let debug = false
-let debug_print = fun _ -> ()
-
- (** debugging print *)
-let info s = debug_print (lazy ("TACTICALS INFO: " ^ (Lazy.force s)))
-
-module PET = ProofEngineTypes
-
-let id_tac =
- let id_tac (proof,goal) =
- let _, metasenv, _, _, _, _ = proof in
- let _, _, _ = CicUtil.lookup_meta goal metasenv in
- (proof,[goal])
- in
- PET.mk_tactic id_tac
-
-let fail_tac =
- let fail_tac (proof,goal) =
- let _, metasenv, _, _ , _, _ = proof in
- let _, _, _ = CicUtil.lookup_meta goal metasenv in
- raise (PET.Fail (lazy "fail tactical"))
- in
- PET.mk_tactic fail_tac
-
-type goal = PET.goal
-
- (** TODO needed until tactics start returning both opened and closed goals
- * First part of the function performs a diff among goals ~before tactic
- * application and ~after it. Second part will add as both opened and closed
- * the goals which are returned as opened by the tactic *)
-let goals_diff ~before ~after ~opened =
- let sort_opened opened add =
- opened @ (List.filter (fun g -> not (List.mem g opened)) add)
- in
- let remove =
- List.fold_left
- (fun remove e -> if List.mem e after then remove else e :: remove)
- [] before
- in
- let add =
- List.fold_left
- (fun add e -> if List.mem e before then add else e :: add)
- []
- after
- in
- let add, remove = (* adds goals which have been both opened _and_ closed *)
- List.fold_left
- (fun (add, remove) opened_goal ->
- if List.mem opened_goal before
- then opened_goal :: add, opened_goal :: remove
- else add, remove)
- (add, remove)
- opened
- in
- sort_opened opened add, remove
-
-module ProofEngineStatus =
-struct
- module Stack = Continuationals.Stack
-
- (* The stack is used and saved only at the very end of the eval function;
- it is read only at the beginning of the eval;
- we need it just to apply several times in a row this machine to an
- initial stack, i.e. to chain several applications of the machine together,
- i.e. to dump and restore the state of the machine.
- The stack is never used by the tactics: each tactic of type
- PET.tactic ignore the stack. To make a tactic from the eval function
- of a machine we apply the eval on a fresh stack (via the mk_tactic). *)
- type input_status =
- PET.status (* (proof, goal) *) * Stack.t
-
- type output_status =
- (PET.proof * goal list * goal list) * Stack.t
-
- type tactic = PET.tactic
-
- (* f is an eval function of a machine;
- the machine is applied to a fresh stack and the final stack is read
- back to obtain the result of the tactic *)
- let mk_tactic f =
- PET.mk_tactic
- (fun ((proof, goal) as pstatus) ->
- let stack = [ [ 1, Stack.Open goal ], [], [], `NoTag ] in
- let istatus = pstatus, stack in
- let (proof, _, _), stack = f istatus in
- let opened = Continuationals.Stack.open_goals stack in
- proof, opened)
-
- (* it applies a tactic ignoring (and preserving) the stack *)
- let apply_tactic tac ((proof, _) as pstatus, stack) =
- let proof', opened = PET.apply_tactic tac pstatus in
- let before = PET.goals_of_proof proof in
- let after = PET.goals_of_proof proof' in
- let opened_goals, closed_goals = goals_diff ~before ~after ~opened in
- (proof', opened_goals, closed_goals), stack
-
- let goals ((_, opened, closed), _) = opened, closed
-
- (* Done only at the beginning of the eval of the machine *)
- let get_stack = snd
- (* Done only at the end of the eval of the machine *)
- let set_stack stack (opstatus, _) = opstatus, stack
-
- let inject ((proof, _), stack) = ((proof, [], []), stack)
- let focus goal ((proof, _, _), stack) = (proof, goal), stack
-end
-
-module S = ProofEngineStatus
-module C = Continuationals.Make (S)
-
-type tactic = S.tactic
-
-let fold_eval status ts =
- let istatus =
- List.fold_left (fun istatus t -> S.focus ~-1 (C.eval t istatus)) status ts
- in
- S.inject istatus
-
-(* Tacticals implemented on top of tynycals *)
-
-let thens ~start ~continuations =
- S.mk_tactic
- (fun istatus ->
- fold_eval istatus
- ([ C.Tactical (C.Tactic start); C.Branch ]
- @ (HExtlib.list_concat ~sep:[ C.Shift ]
- (List.map (fun t -> [ C.Tactical (C.Tactic t) ]) continuations))
- @ [ C.Merge ]))
-
-let then_ ~start ~continuation =
- S.mk_tactic
- (fun istatus ->
- let ostatus = C.eval (C.Tactical (C.Tactic start)) istatus in
- let opened,closed = S.goals ostatus in
- match opened with
- [] -> ostatus
- | _ ->
- fold_eval (S.focus ~-1 ostatus)
- [ C.Semicolon;
- C.Tactical (C.Tactic continuation) ])
-
-let seq ~tactics =
- S.mk_tactic
- (fun istatus ->
- fold_eval istatus
- (HExtlib.list_concat ~sep:[ C.Semicolon ]
- (List.map (fun t -> [ C.Tactical (C.Tactic t) ]) tactics)))
-
-(* Tacticals that cannot be implemented on top of tynycals *)
-
-let const_tac res = PET.mk_tactic (fun _ -> res)
-
-let if_ ~start ~continuation ~fail =
- let if_ status =
- let xoutput =
- try
- let result = PET.apply_tactic start status in
- info (lazy ("Tacticals.if_: succedeed!!!"));
- Some result
- with PET.Fail _ -> None
- in
- let tactic = match xoutput with
- | Some res -> then_ ~start:(const_tac res) ~continuation
- | None -> fail
- in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic if_
-
-let ifs ~start ~continuations ~fail =
- let ifs status =
- let xoutput =
- try
- let result = PET.apply_tactic start status in
- info (lazy ("Tacticals.ifs: succedeed!!!"));
- Some result
- with PET.Fail _ -> None
- in
- let tactic = match xoutput with
- | Some res -> thens ~start:(const_tac res) ~continuations
- | None -> fail
- in
- PET.apply_tactic tactic status
- in
- PET.mk_tactic ifs
-
-let first ~tactics =
- let rec first ~(tactics: tactic list) status =
- info (lazy "in Tacticals.first");
- match tactics with
- [] -> raise (PET.Fail (lazy "first: no tactics left"))
- | tac::tactics ->
- try
- let res = PET.apply_tactic tac status in
- info (lazy ("Tacticals.first: succedeed!!!"));
- res
- with
- PET.Fail _ -> first ~tactics status
- in
- PET.mk_tactic (first ~tactics)
-
-let rec do_tactic ~n ~tactic =
- PET.mk_tactic
- (function status ->
- if n = 0 then
- PET.apply_tactic id_tac status
- else
- PET.apply_tactic
- (then_ ~start:tactic ~continuation:(do_tactic ~n:(n-1) ~tactic))
- status)
-
-(* This applies tactic and catches its possible failure *)
-let try_tactic ~tactic =
- let try_tactic status =
- try
- PET.apply_tactic tactic status
- with (PET.Fail _) as e ->
- info (lazy (
- "Tacticals.try_tactic failed with exn: " ^ Printexc.to_string e));
- PET.apply_tactic id_tac status
- in
- PET.mk_tactic try_tactic
-
-let rec repeat_tactic ~tactic =
- ProofEngineTypes.mk_tactic
- (fun status ->
- ProofEngineTypes.apply_tactic
- (then_ ~start:tactic
- ~continuation:(try_tactic (repeat_tactic ~tactic))) status)
-
-(* This tries tactics until one of them solves the goal *)
-let solve_tactics ~tactics =
- let rec solve_tactics ~(tactics: tactic list) status =
- info (lazy "in Tacticals.solve_tactics");
- match tactics with
- | currenttactic::moretactics ->
- (try
- let (proof, opened) as output_status =
- PET.apply_tactic currenttactic status
- in
- match opened with
- | [] -> info (lazy ("Tacticals.solve_tactics: solved the goal!!!"));
- output_status
- | _ -> info (lazy ("Tacticals.solve_tactics: try the next tactic"));
- raise (PET.Fail (lazy "Goal not solved"))
- with (PET.Fail _) as e ->
- info (lazy (
- "Tacticals.solve_tactics: current tactic failed with exn: "
- ^ Printexc.to_string e));
- solve_tactics ~tactics:moretactics status)
- | [] ->
- raise (PET.Fail
- (lazy "solve_tactics cannot solve the goal"))
- in
- PET.mk_tactic (solve_tactics ~tactics)
-
-let progress_tactic ~tactic =
- let msg = lazy "Failed to progress" in
- let progress_tactic (((_,metasenv,_,_,_,_),g) as istatus) =
- let ((_,metasenv',_,_,_,_),opened) as ostatus =
- PET.apply_tactic tactic istatus
- in
- match opened with
- | [g1] ->
- let _,oc,oldty = CicUtil.lookup_meta g metasenv in
- let _,nc,newty = CicUtil.lookup_meta g1 metasenv' in
- if oldty = newty && oc = nc then
- raise (PET.Fail msg)
- else
- ostatus
- | _ -> ostatus
- in
- PET.mk_tactic progress_tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type tactic = ProofEngineTypes.tactic
-
-val id_tac : tactic
-val fail_tac: tactic
-
-val first: tactics: tactic list -> tactic
-val thens: start: tactic -> continuations: tactic list -> tactic
-val then_: start: tactic -> continuation: tactic -> tactic
-val ifs: start: tactic -> continuations: tactic list -> fail: tactic -> tactic
-val if_: start: tactic -> continuation: tactic -> fail: tactic -> tactic
-val seq: tactics: tactic list -> tactic (** "folding" of then_ *)
-val repeat_tactic: tactic: tactic -> tactic
-val do_tactic: n: int -> tactic: tactic -> tactic
-val try_tactic: tactic: tactic -> tactic
-val solve_tactics: tactics: tactic list -> tactic
-val progress_tactic: tactic: tactic -> tactic
-
-(* TODO temporary *)
-val goals_diff:
- before:ProofEngineTypes.goal list ->
- after:ProofEngineTypes.goal list ->
- opened:ProofEngineTypes.goal list ->
- ProofEngineTypes.goal list * ProofEngineTypes.goal list
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let absurd = NegationTactics.absurd_tac
-let apply = PrimitiveTactics.apply_tac
-let applyP = PrimitiveTactics.applyP_tac
-let applyS = Auto.applyS_tac
-let assumption = VariousTactics.assumption_tac
-let auto = Auto.auto_tac
-let cases_intros = PrimitiveTactics.cases_intros_tac
-let change = ReductionTactics.change_tac
-let clear = ProofEngineStructuralRules.clear
-let clearbody = ProofEngineStructuralRules.clearbody
-let constructor = IntroductionTactics.constructor_tac
-let contradiction = NegationTactics.contradiction_tac
-let cut = PrimitiveTactics.cut_tac
-let decompose = EliminationTactics.decompose_tac
-let demodulate = Auto.demodulate_tac
-let destruct = DestructTactic.destruct_tac
-let elim_intros = PrimitiveTactics.elim_intros_tac
-let elim_intros_simpl = PrimitiveTactics.elim_intros_simpl_tac
-let elim_type = EliminationTactics.elim_type_tac
-let exact = PrimitiveTactics.exact_tac
-let exists = IntroductionTactics.exists_tac
-let fail = Tacticals.fail_tac
-let fold = ReductionTactics.fold_tac
-let fourier = FourierR.fourier_tac
-let fwd_simpl = FwdSimplTactic.fwd_simpl_tac
-let generalize = PrimitiveTactics.generalize_tac
-let id = Tacticals.id_tac
-let intros = PrimitiveTactics.intros_tac
-let inversion = Inversion.inversion_tac
-let lapply = FwdSimplTactic.lapply_tac
-let left = IntroductionTactics.left_tac
-let letin = PrimitiveTactics.letin_tac
-let normalize = ReductionTactics.normalize_tac
-let reflexivity = Setoids.setoid_reflexivity_tac
-let replace = EqualityTactics.replace_tac
-let rewrite = EqualityTactics.rewrite_tac
-let rewrite_simpl = EqualityTactics.rewrite_simpl_tac
-let right = IntroductionTactics.right_tac
-let ring = Ring.ring_tac
-let simpl = ReductionTactics.simpl_tac
-let split = IntroductionTactics.split_tac
-let symmetry = EqualityTactics.symmetry_tac
-let transitivity = EqualityTactics.transitivity_tac
-let unfold = ReductionTactics.unfold_tac
-let whd = ReductionTactics.whd_tac
-let compose = Compose.compose_tac
-
-(* keep linked *)
-let _ = CloseCoercionGraph.close_coercion_graph;;
+++ /dev/null
-(* GENERATED FILE, DO NOT EDIT. STAMP:Mon May 18 11:04:27 CEST 2009 *)
-val absurd : term:Cic.term -> ProofEngineTypes.tactic
-val apply : term:Cic.term -> ProofEngineTypes.tactic
-val applyP : term:Cic.term -> ProofEngineTypes.tactic
-val applyS :
- dbd:HSql.dbd ->
- term:Cic.term ->
- params:Auto.auto_params ->
- automation_cache:AutomationCache.cache -> ProofEngineTypes.tactic
-val assumption : ProofEngineTypes.tactic
-val auto :
- dbd:HSql.dbd ->
- params:Auto.auto_params ->
- automation_cache:AutomationCache.cache -> ProofEngineTypes.tactic
-val cases_intros :
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> ProofEngineTypes.tactic
-val change :
- ?with_cast:bool ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.lazy_term -> ProofEngineTypes.tactic
-val clear : hyps:string list -> ProofEngineTypes.tactic
-val clearbody : hyp:string -> ProofEngineTypes.tactic
-val constructor : n:int -> ProofEngineTypes.tactic
-val contradiction : ProofEngineTypes.tactic
-val cut :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- Cic.term -> ProofEngineTypes.tactic
-val decompose :
- ?sorts:string list ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- unit -> ProofEngineTypes.tactic
-val demodulate :
- dbd:HSql.dbd ->
- params:Auto.auto_params ->
- automation_cache:AutomationCache.cache -> ProofEngineTypes.tactic
-val destruct : Cic.term list option -> ProofEngineTypes.tactic
-val elim_intros :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int ->
- ?using:Cic.term ->
- ?pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> ProofEngineTypes.tactic
-val elim_intros_simpl :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int ->
- ?using:Cic.term ->
- ?pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> ProofEngineTypes.tactic
-val elim_type :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
-val exact : term:Cic.term -> ProofEngineTypes.tactic
-val exists : ProofEngineTypes.tactic
-val fail : Tacticals.tactic
-val fold :
- reduction:ProofEngineTypes.lazy_reduction ->
- term:Cic.lazy_term ->
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val fourier : ProofEngineTypes.tactic
-val fwd_simpl :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- dbd:HSql.dbd -> string -> ProofEngineTypes.tactic
-val generalize :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val id : Tacticals.tactic
-val intros :
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- unit -> ProofEngineTypes.tactic
-val inversion : term:Cic.term -> ProofEngineTypes.tactic
-val lapply :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?linear:bool ->
- ?how_many:int ->
- ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic
-val left : ProofEngineTypes.tactic
-val letin :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- Cic.term -> ProofEngineTypes.tactic
-val normalize :
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val reflexivity : ProofEngineTypes.tactic
-val replace :
- pattern:ProofEngineTypes.lazy_pattern ->
- with_what:Cic.lazy_term -> ProofEngineTypes.tactic
-val rewrite :
- direction:[ `LeftToRight | `RightToLeft ] ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> string list -> ProofEngineTypes.tactic
-val rewrite_simpl :
- direction:[ `LeftToRight | `RightToLeft ] ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> string list -> ProofEngineTypes.tactic
-val right : ProofEngineTypes.tactic
-val ring : ProofEngineTypes.tactic
-val simpl : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val split : ProofEngineTypes.tactic
-val symmetry : ProofEngineTypes.tactic
-val transitivity : term:Cic.term -> ProofEngineTypes.tactic
-val unfold :
- Cic.lazy_term option ->
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val whd : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val compose :
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- int -> Cic.term -> Cic.term option -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-module Codomain = struct
- type t = Cic.term
- let compare = Pervasives.compare
-end
-module S = Set.Make(Codomain)
-module TI = Discrimination_tree.Make(Cic_indexable.CicIndexable)(S)
-type universe = TI.t
-
-let empty = TI.empty ;;
-
-let iter u f =
- TI.iter u
- (fun p s -> f p (S.elements s))
-;;
-
-let get_candidates univ ty =
- S.elements (TI.retrieve_unifiables univ ty)
-;;
-
-let in_universe univ ty =
- let candidates = get_candidates univ ty in
- List.fold_left
- (fun res cand ->
- match res with
- | Some found -> Some found
- | None ->
- let candty,_ =
- CicTypeChecker.type_of_aux' [] [] cand CicUniv.oblivion_ugraph in
- let same ,_ =
- CicReduction.are_convertible [] candty ty CicUniv.oblivion_ugraph in
- if same then Some cand else None
- ) None candidates
-;;
-
-let rec unfold context = function
- | Cic.Prod(name,s,t) ->
- let t' = unfold ((Some (name,Cic.Decl s))::context) t in
- Cic.Prod(name,s,t')
- | t -> ProofEngineReduction.unfold context t
-
-let rec collapse_head_metas t =
- match t with
- | Cic.Appl([]) -> assert false
- | Cic.Appl(a::l) ->
- let a' = collapse_head_metas a in
- (match a' with
- | Cic.Meta(n,m) -> Cic.Meta(n,m)
- | t ->
- let l' = List.map collapse_head_metas l in
- Cic.Appl(t::l'))
- | Cic.Rel _
- | Cic.Var _
- | Cic.Meta _
- | Cic.Sort _
- | Cic.Implicit _
- | Cic.Const _
- | Cic.MutInd _
- | Cic.MutConstruct _ -> t
- | Cic.LetIn _
- | Cic.Lambda _
- | Cic.Prod _
- | Cic.Cast _
- | Cic.MutCase _
- | Cic.Fix _
- | Cic.CoFix _ -> Cic.Meta(-1,[])
-;;
-
-let rec dummies_of_coercions =
- function
- | Cic.Appl (c::l) when CoercDb.is_a_coercion c <> None ->
- Cic.Meta (-1,[])
- | Cic.Appl l ->
- let l' = List.map dummies_of_coercions l in Cic.Appl l'
- | Cic.Lambda(n,s,t) ->
- let s' = dummies_of_coercions s in
- let t' = dummies_of_coercions t in
- Cic.Lambda (n,s',t')
- | Cic.Prod(n,s,t) ->
- let s' = dummies_of_coercions s in
- let t' = dummies_of_coercions t in
- Cic.Prod (n,s',t')
- | Cic.LetIn(n,s,ty,t) ->
- let s' = dummies_of_coercions s in
- let ty' = dummies_of_coercions ty in
- let t' = dummies_of_coercions t in
- Cic.LetIn (n,s',ty',t')
- | Cic.MutCase _ -> Cic.Meta (-1,[])
- | t -> t
-;;
-
-
-let rec head remove_coercions t =
- let clean_up t =
- if remove_coercions then dummies_of_coercions t
- else t in
- let rec aux = function
- | Cic.Prod(_,_,t) ->
- CicSubstitution.subst (Cic.Meta (-1,[])) (aux t)
- | t -> t
- in collapse_head_metas (clean_up (aux t))
-;;
-
-
-let index univ key term =
- (* flexible terms are not indexed *)
- if key = Cic.Meta(-1,[]) then univ
- else
- ((*prerr_endline("ADD: "^CicPp.ppterm key^" |-> "^CicPp.ppterm term);*)
- TI.index univ key term)
-;;
-
-let keys context ty =
- try
- [head true ty; head true (unfold context ty)]
- with ProofEngineTypes.Fail _ -> [head true ty]
-
-let key term = head false term;;
-
-let index_term_and_unfolded_term univ context t ty =
- let key = head true ty in
- let univ = index univ key t in
- try
- let key = head true (unfold context ty) in
- index univ key t
- with ProofEngineTypes.Fail _ -> univ
-;;
-
-let index_local_term univ context t ty =
- let key = head true ty in
- let univ = index univ key t in
- let key1 = head false ty in
- let univ =
- if key<>key1 then index univ key1 t else univ in
- try
- let key = head true (unfold context ty) in
- index univ key t
- with ProofEngineTypes.Fail _ -> univ
-;;
-
-
-let index_list univ context terms_and_types =
- List.fold_left
- (fun acc (term,ty) ->
- index_term_and_unfolded_term acc context term ty)
- univ terms_and_types
-
-;;
-
-let remove univ context term ty =
- let key = head true ty in
- let univ = TI.remove_index univ key term in
- try
- let key = head true (unfold context ty) in
- TI.remove_index univ key term
- with ProofEngineTypes.Fail _ -> univ
-
-let remove_uri univ uri =
- let term = CicUtil.term_of_uri uri in
- let ty,_ = CicTypeChecker.type_of_aux' [] [] term CicUniv.oblivion_ugraph in
- remove univ [] term ty
-
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type universe
-
-val empty : universe
-
-
-val iter :
- universe ->
- (UriManager.uri Discrimination_tree.path -> Cic.term list -> unit) ->
- unit
-
-(* retrieves the list of term that hopefully unify *)
-val get_candidates: universe -> Cic.term -> Cic.term list
-
-(* index [univ] [key] [term] *)
-val index: universe -> Cic.term -> Cic.term -> universe
-
-(* collapse non-indexable terms, removing coercions an unfolding the head
- * constant if any *)
-val keys: Cic.context -> Cic.term -> Cic.term list
-
-(* collapse non-indexable terms, not removing coercions *)
-val key: Cic.term -> Cic.term
-
-val in_universe: universe -> Cic.term -> Cic.term option
-
-(* indexes the term and its unfolded both without coercions *)
-val index_term_and_unfolded_term:
- universe -> Cic.context -> Cic.term -> Cic.term -> universe
-
-(* indexex the term without coercions, with coercions and unfolded without
- * coercions *)
-val index_local_term:
- universe -> Cic.context -> Cic.term -> Cic.term -> universe
-
-(* pairs are (term,ty) *)
-val index_list:
- universe -> Cic.context -> (Cic.term*Cic.term) list -> universe
-val remove:
- universe -> Cic.context -> Cic.term -> Cic.term -> universe
-val remove_uri:
- universe -> UriManager.uri -> universe
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-
-(* TODO se ce n'e' piu' di una, prende la prima che trova... sarebbe meglio
-chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una
-funzione di callback che restituisce la (sola) hyp da applicare *)
-
-let assumption_tac =
- let module PET = ProofEngineTypes in
- let assumption_tac status =
- let (proof, goal) = status in
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let module PT = PrimitiveTactics in
- let _,metasenv,_,_,_, _ = proof in
- let _,context,ty = CicUtil.lookup_meta goal metasenv in
- let rec find n = function
- hd::tl ->
- (match hd with
- (Some (_, C.Decl t)) when
- fst (R.are_convertible context (S.lift n t) ty
- CicUniv.oblivion_ugraph) -> n
- | (Some (_, C.Def (_,ty'))) when
- fst (R.are_convertible context (S.lift n ty') ty
- CicUniv.oblivion_ugraph) -> n
- | _ -> find (n+1) tl
- )
- | [] -> raise (PET.Fail (lazy "Assumption: No such assumption"))
- in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status
- in
- PET.mk_tactic assumption_tac
-;;
+++ /dev/null
-
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val assumption_tac: ProofEngineTypes.tactic
helm-ng_disambiguation \
helm-ng_cic_content \
helm-grafite_parser \
-helm-acic_procedural \
helm-content_pres \
helm-hgdome \
-helm-tactics \
helm-ng_paramodulation \
helm-ng_tactics \
helm-cic_exportation \
components/extlib/componentsConf.ml
matita/matita.conf.xml
matita/buildTimeConf.ml
- matita/gtkmathview.matita.conf.xml
matita/help/C/version.txt
Makefile.defs
])
module GE = GrafiteEngine
module LS = LibrarySync
module Ds = CicDischarge
-module PO = ProceduralOptimizer
module N = CicNotationPt
-module A2P = Acic2Procedural
let mpres_document pres_box =
Xml.add_xml_declaration (CicNotationPres.print_box pres_box)
(*
Ds.debug := true;
*)
- let print_exc = function
- | ProofEngineHelpers.Bad_pattern s as e ->
- Printexc.to_string e ^ " " ^ Lazy.force s
- | e -> Printexc.to_string e
- in
+ let print_exc = Printexc.to_string in
let dbd = LibraryDb.instance () in
let sorted_uris = MetadataDeps.sorted_uris_of_baseuri ~dbd suri in
let error uri e =
in
txt_of_inline_uri ~map_unicode_to_tex params suri
-(****************************************************************************)
-(* procedural_txt_of_cic_term *)
-
-let procedural_txt_of_cic_term ~map_unicode_to_tex n params context term =
- let term, _info = PO.optimize_term context term in
- let annterm, ids_to_inner_sorts, ids_to_inner_types =
- try Cic2acic.acic_term_of_cic_term context term
- with e ->
- let msg = "procedural_txt_of_cic_term: " ^ Printexc.to_string e in
- failwith msg
- in
- let term_pp = term2pres ~map_unicode_to_tex (n - 8) ids_to_inner_sorts in
- let lazy_term_pp = term_pp in
- let obj_pp = CicNotationPp.pp_obj term_pp in
- let aux = GrafiteAstPp.pp_statement
- ~map_unicode_to_tex ~term_pp ~lazy_term_pp ~obj_pp in
- let script =
- A2P.procedural_of_acic_term
- ~ids_to_inner_sorts ~ids_to_inner_types params context annterm
- in
- String.concat "" (List.map aux script)
-;;
-
-(****************************************************************************)
-
let txt_of_macro ~map_unicode_to_tex metasenv context m =
GrafiteAstPp.pp_macro
~term_pp:(txt_of_cic_term ~map_unicode_to_tex 80 metasenv context)
Cic.metasenv ->
Cic.context ->
(Cic.term, Cic.lazy_term) GrafiteAst.macro -> string
-
-(* columns, rendering depth, context, term *)
-val procedural_txt_of_cic_term:
- map_unicode_to_tex:bool -> int -> GrafiteAst.inline_param list ->
- Cic.context -> Cic.term ->
- string
+++ /dev/null
-<?xml version="1.0" encoding="UTF-8"?>
-<math-engine-configuration>
- <section name="dictionary">
- <key name="path">@RT_BASE_DIR@/dictionary-matita.xml</key>
- </section>
-<!--
- <section name="gtk-backend">
- <section name="pango-default-shaper">
- <section name="variants">
- <section name="italic">
- <key name="style">normal</key>
- </section>
- </section>
- </section>
- </section>
--->
-<!--
- <section name="gtk-backend">
- <section name="pango-default-shaper">
- <section name="variants">
- <section name="normal">
- <key name="family">courier</key>
- </section>
- <section name="italic">
- <key name="family">courier</key>
- </section>
- </section>
- </section>
- </section>
--->
-</math-engine-configuration>
let browser_observer _ = MatitaMathView.refresh_all_browsers () in
let sequents_observer grafite_status =
sequents_viewer#reset;
- match grafite_status#proof_status with
- | Incomplete_proof ({ stack = stack } as incomplete_proof) ->
- sequents_viewer#load_sequents grafite_status incomplete_proof;
+ match grafite_status#ng_mode with
+ `ProofMode ->
+ sequents_viewer#nload_sequents grafite_status;
(try
- script#setGoal (Some (Continuationals.Stack.find_goal stack));
+ script#setGoal
+ (Some (Continuationals.Stack.find_goal grafite_status#stack));
let goal =
match script#goal with
None -> assert false
in
sequents_viewer#goto_sequent grafite_status goal
with Failure _ -> script#setGoal None);
- | Proof proof -> sequents_viewer#load_logo_with_qed
- | No_proof ->
- (match grafite_status#ng_mode with
- `ProofMode ->
- sequents_viewer#nload_sequents grafite_status;
- (try
- script#setGoal
- (Some (Continuationals.Stack.find_goal grafite_status#stack));
- let goal =
- match script#goal with
- None -> assert false
- | Some n -> n
- in
- sequents_viewer#goto_sequent grafite_status goal
- with Failure _ -> script#setGoal None);
- | `CommandMode -> sequents_viewer#load_logo
- )
- | Intermediate _ -> assert false (* only the engine may be in this state *)
+ | `CommandMode -> sequents_viewer#load_logo
in
script#addObserver sequents_observer;
script#addObserver browser_observer
(fun x l -> (LexiconAstPp.pp_command x)::l)
(filter status.LexiconEngine.lexicon_content_rev) [])));
*)
- addDebugItem "print metasenv goals and stack to stderr"
- (fun _ ->
- prerr_endline ("metasenv goals: " ^ String.concat " "
- (List.map (fun (g, _, _) -> string_of_int g)
- (MatitaScript.current ())#proofMetasenv));
- prerr_endline ("stack: " ^ Continuationals.Stack.pp
- (GrafiteTypes.get_stack (MatitaScript.current ())#grafite_status)));
- addDebugItem "Print current proof term"
- (fun _ ->
- HLog.debug
- (CicPp.ppterm
- (match
- (MatitaScript.current ())#grafite_status#proof_status
- with
- | GrafiteTypes.No_proof -> (Cic.Implicit None)
- | Incomplete_proof i ->
- let _,_,_subst,p,_, _ = i.GrafiteTypes.proof in
- Lazy.force p
- | Proof p -> let _,_,_subst,p,_, _ = p in Lazy.force p
- | Intermediate _ -> assert false)));
- addDebugItem "Print current proof (natural language) to stderr"
- (fun _ ->
- prerr_endline
- (ApplyTransformation.txt_of_cic_object 120 []
- ~map_unicode_to_tex:(Helm_registry.get_bool
- "matita.paste_unicode_as_tex")
- (match
- (MatitaScript.current ())#grafite_status#proof_status
- with
- | GrafiteTypes.No_proof -> assert false
- | Incomplete_proof i ->
- let _,m,_subst,p,ty, attrs = i.GrafiteTypes.proof in
- Cic.CurrentProof ("current (incomplete) proof",m,Lazy.force p,ty,[],attrs)
- | Proof (_,m,_subst,p,ty, attrs) ->
- Cic.CurrentProof ("current proof",m,Lazy.force p,ty,[],attrs)
- | Intermediate _ -> assert false)));
addDebugSeparator ();
addDebugCheckbox "high level pretty printer" ~init:true
(fun mi () -> CicMetaSubst.use_low_level_ppterm_in_context := mi#active);
let disambiguate_command lexicon_status_ref grafite_status cmd =
let baseuri = grafite_status#baseuri in
- let lexicon_status,metasenv,cmd =
+ let lexicon_status,cmd =
GrafiteDisambiguate.disambiguate_command ~baseuri
- !lexicon_status_ref (GrafiteTypes.get_proof_metasenv grafite_status) cmd
+ !lexicon_status_ref cmd
in
lexicon_status_ref := lexicon_status;
- GrafiteTypes.set_metasenv metasenv grafite_status,cmd
+ grafite_status,cmd
let eval_macro_screenshot (status : GrafiteTypes.status) name =
let _,_,metasenv,subst,_ = status#obj in
status, `Old []
| ast ->
GrafiteEngine.eval_ast
- ~disambiguate_tactic:((* MATITA 1.0*) fun _ -> assert false)
~disambiguate_command:(disambiguate_command lexicon_status_ref)
~disambiguate_macro:((* MATITA 1.0*) fun _ -> assert false)
?do_heavy_checks status (text,prefix_len,ast)
None,
sprintf "format/version mismatch for file '%s', please recompile it'"
fname
- | ProofEngineTypes.Fail msg -> None, "Tactic error: " ^ Lazy.force msg
| Continuationals.Error s -> None, "Tactical error: " ^ Lazy.force s
- | ProofEngineHelpers.Bad_pattern msg ->
- None, "Bad pattern: " ^ Lazy.force msg
| CicRefine.RefineFailure msg
| CicRefine.AssertFailure msg ->
None, "Refiner error: " ^ Lazy.force msg
let save_moo grafite_status =
let script = MatitaScript.current () in
let baseuri = grafite_status#baseuri in
- let no_pstatus =
- grafite_status#proof_status = GrafiteTypes.No_proof
- in
- match script#bos, script#eos, no_pstatus with
- | true, _, _ -> ()
- | _, true, true ->
+ match script#bos, script#eos with
+ | true, _ -> ()
+ | _, true ->
let moo_fname =
LibraryMisc.obj_file_of_baseuri ~must_exist:false ~baseuri
~writable:true in
method reset: unit
method load_logo: unit
method load_logo_with_qed: unit
- method load_sequents:
- #NCicCoercion.status -> GrafiteTypes.incomplete_proof -> unit
method nload_sequents: #NTacStatus.tac_status -> unit
method goto_sequent:
#NCicCoercion.status -> int -> unit (* to be called _after_ load_sequents *)
let _ =
CicFix.init ();
- Inversion_principle.init ();
CicRecord.init ();
CicElim.init ()
;;
_metasenv <- `Old [];
self#script#setGoal None
- method load_sequents : 'status. #NCicCoercion.status as 'status -> 'a
- = fun status { proof= (_,metasenv,_subst,_,_, _) as proof; stack = stack }
- ->
- _metasenv <- `Old metasenv;
- pages <- 0;
- let win goal_switch =
- let w =
- GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS
- ~shadow_type:`IN ~show:true ()
- in
- let reparent () =
- scrolledWin <- Some w;
- match cicMathView#misc#parent with
- | None -> w#add cicMathView#coerce
- | Some parent ->
- let parent =
- match cicMathView#misc#parent with
- None -> assert false
- | Some p -> GContainer.cast_container p
- in
- parent#remove cicMathView#coerce;
- w#add cicMathView#coerce
- in
- goal2win <- (goal_switch, reparent) :: goal2win;
- w#coerce
- in
- assert (
- let stack_goals = Stack.open_goals stack in
- let proof_goals = ProofEngineTypes.goals_of_proof proof in
- if
- HExtlib.list_uniq (List.sort Pervasives.compare stack_goals)
- <> List.sort Pervasives.compare proof_goals
- then begin
- prerr_endline ("STACK GOALS = " ^ String.concat " " (List.map string_of_int stack_goals));
- prerr_endline ("PROOF GOALS = " ^ String.concat " " (List.map string_of_int proof_goals));
- false
- end
- else true
- );
- let render_switch =
- function Stack.Open i ->`Meta i | Stack.Closed i ->`Closed (`Meta i)
- in
- let page = ref 0 in
- let added_goals = ref [] in
- (* goals can be duplicated on the tack due to focus, but we should avoid
- * multiple labels in the user interface *)
- let add_tab markup goal_switch =
- let goal = Stack.goal_of_switch goal_switch in
- if not (List.mem goal !added_goals) then begin
- ignore(notebook#append_page
- ~tab_label:(tab_label markup) (win goal_switch));
- page2goal <- (!page, goal_switch) :: page2goal;
- goal2page <- (goal_switch, !page) :: goal2page;
- incr page;
- pages <- pages + 1;
- added_goals := goal :: !added_goals
- end
- in
- let add_switch _ _ (_, sw) = add_tab (render_switch sw) sw in
- Stack.iter (** populate notebook with tabs *)
- ~env:(fun depth tag (pos, sw) ->
- let markup =
- match depth, pos with
- | 0, 0 -> `Current (render_switch sw)
- | 0, _ -> `Shift (pos, `Current (render_switch sw))
- | 1, pos when Stack.head_tag stack = `BranchTag ->
- `Shift (pos, render_switch sw)
- | _ -> render_switch sw
- in
- add_tab markup sw)
- ~cont:add_switch ~todo:add_switch
- stack;
- switch_page_callback <-
- Some (notebook#connect#switch_page ~callback:(fun page ->
- let goal_switch =
- try List.assoc page page2goal with Not_found -> assert false
- in
- self#script#setGoal (Some (goal_of_switch goal_switch));
- self#render_page status ~page ~goal_switch))
-
method nload_sequents : 'status. #NTacStatus.tac_status as 'status -> unit
= fun status ->
let _,_,metasenv,subst,_ = status#obj in
type term_source =
[ `Ast of CicNotationPt.term
- | `Cic of Cic.term * Cic.metasenv
| `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution
| `String of string
]
| `About `TeX -> self#tex ()
| `About `Grammar -> self#grammar ()
| `Check term -> self#_loadCheck term
- | `Cic (term, metasenv) -> self#_loadTermCic term metasenv
| `NCic (term, ctx, metasenv, subst) ->
self#_loadTermNCic term metasenv subst ctx
| `Dir dir -> self#_loadDir dir
method private home () =
self#_showMath;
- match self#script#grafite_status#proof_status with
- | Proof (uri, metasenv, _subst, bo, ty, attrs) ->
- let name = UriManager.name_of_uri (HExtlib.unopt uri) in
- let obj =
- Cic.CurrentProof (name, metasenv, Lazy.force bo, ty, [], attrs)
- in
- self#_loadObj obj
- | Incomplete_proof { proof = (uri, metasenv, _subst, bo, ty, attrs) } ->
- let name = UriManager.name_of_uri (HExtlib.unopt uri) in
- let obj =
- Cic.CurrentProof (name, metasenv, Lazy.force bo, ty, [], attrs)
- in
- self#_loadObj obj
- | _ ->
- match self#script#grafite_status#ng_mode with
- `ProofMode ->
- self#_loadNObj self#script#grafite_status
- self#script#grafite_status#obj
- | _ -> self#blank ()
+ match self#script#grafite_status#ng_mode with
+ `ProofMode ->
+ self#_loadNObj self#script#grafite_status
+ self#script#grafite_status#obj
+ | _ -> self#blank ()
(** loads a cic uri from the environment
* @param uri UriManager.uri *)
self#_showMath;
mathView#load_nobject status obj
- method private _loadTermCic term metasenv =
- let context = self#script#proofContext in
- let dummyno = CicMkImplicit.new_meta metasenv [] in
- let sequent = (dummyno, context, term) in
- mathView#load_sequent (sequent :: metasenv) dummyno;
- self#_showMath
-
method private _loadTermNCic term m s c =
let d = 0 in
let m = (0,([],c,term))::m in
GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term
~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false)
-(* naive implementation of procedural proof script generation,
- * starting from an applicatiove *auto generated) proof.
- * this is out of place, but I like it :-P *)
-let cic2grafite context menv t =
- (* indents a proof script in a stupid way, better than nothing *)
- let stupid_indenter s =
- let next s =
- let idx_square_o = try String.index s '[' with Not_found -> -1 in
- let idx_square_c = try String.index s ']' with Not_found -> -1 in
- let idx_pipe = try String.index s '|' with Not_found -> -1 in
- let tok =
- List.sort (fun (i,_) (j,_) -> compare i j)
- [idx_square_o,'[';idx_square_c,']';idx_pipe,'|']
- in
- let tok = List.filter (fun (i,_) -> i <> -1) tok in
- match tok with
- | (i,c)::_ -> Some (i,c)
- | _ -> None
- in
- let break_apply n s =
- let tab = String.make (n+1) ' ' in
- Pcre.replace ~templ:(".\n" ^ tab ^ "apply") ~pat:"\\.apply" s
- in
- let rec ind n s =
- match next s with
- | None ->
- s
- | Some (position, char) ->
- try
- let s1, s2 =
- String.sub s 0 position,
- String.sub s (position+1) (String.length s - (position+1))
- in
- match char with
- | '[' -> break_apply n s1 ^ "\n" ^ String.make (n+2) ' ' ^
- "[" ^ ind (n+2) s2
- | '|' -> break_apply n s1 ^ "\n" ^ String.make n ' ' ^
- "|" ^ ind n s2
- | ']' -> break_apply n s1 ^ "\n" ^ String.make n ' ' ^
- "]" ^ ind (n-2) s2
- | _ -> assert false
- with
- Invalid_argument err ->
- prerr_endline err;
- s
- in
- ind 0 s
- in
- let module PT = CicNotationPt in
- let module GA = GrafiteAst in
- let pp_t context t =
- let names =
- List.map (function Some (n,_) -> Some n | None -> None) context
- in
- CicPp.pp t names
- in
- let sort_of context t =
- try
- let ty,_ =
- CicTypeChecker.type_of_aux' menv context t
- CicUniv.oblivion_ugraph
- in
- let sort,_ = CicTypeChecker.type_of_aux' menv context ty
- CicUniv.oblivion_ugraph
- in
- match sort with
- | Cic.Sort Cic.Prop -> true
- | _ -> false
- with
- CicTypeChecker.TypeCheckerFailure _ ->
- HLog.error "auto proof to sript transformation error"; false
- in
- let floc = HExtlib.dummy_floc in
- (* minimalisti cic.term -> pt.term *)
- let print_term c t =
- let rec aux c = function
- | Cic.Rel _
- | Cic.MutConstruct _
- | Cic.MutInd _
- | Cic.Const _ as t ->
- PT.Ident (pp_t c t, None)
- | Cic.Appl l -> PT.Appl (List.map (aux c) l)
- | Cic.Implicit _ -> PT.Implicit `JustOne
- | Cic.Lambda (Cic.Name n, s, t) ->
- PT.Binder (`Lambda, (PT.Ident (n,None), Some (aux c s)),
- aux (Some (Cic.Name n, Cic.Decl s)::c) t)
- | Cic.Prod (Cic.Name n, s, t) ->
- PT.Binder (`Forall, (PT.Ident (n,None), Some (aux c s)),
- aux (Some (Cic.Name n, Cic.Decl s)::c) t)
- | Cic.LetIn (Cic.Name n, s, ty, t) ->
- PT.Binder (`Lambda, (PT.Ident (n,None), Some (aux c s)),
- aux (Some (Cic.Name n, Cic.Def (s,ty))::c) t)
- | Cic.Meta _ -> PT.Implicit `JustOne
- | Cic.Sort (Cic.Type u) -> PT.Sort (`Type u)
- | Cic.Sort Cic.Set -> PT.Sort `Set
- | Cic.Sort (Cic.CProp u) -> PT.Sort (`CProp u)
- | Cic.Sort Cic.Prop -> PT.Sort `Prop
- | _ as t -> PT.Ident ("ERROR: "^CicPp.ppterm t, None)
- in
- aux c t
- in
- (* prints an applicative proof, that is an auto proof.
- * don't use in the general case! *)
- let rec print_proof context = function
- | Cic.Rel _
- | Cic.Const _ as t ->
- [GA.Executable (floc,
- GA.Tactic (floc,
- Some (GA.Apply (floc, print_term context t)), GA.Dot floc))]
- | Cic.Appl (he::tl) ->
- let tl = List.map (fun t -> t, sort_of context t) tl in
- let subgoals =
- HExtlib.filter_map (function (t,true) -> Some t | _ -> None) tl
- in
- let args =
- List.map (function | (t,true) -> Cic.Implicit None | (t,_) -> t) tl
- in
- if List.length subgoals > 1 then
- (* branch *)
- [GA.Executable (floc,
- GA.Tactic (floc,
- Some (GA.Apply (floc, print_term context (Cic.Appl (he::args)))),
- GA.Semicolon floc))] @
- [GA.Executable (floc, GA.Tactic (floc, None, GA.Branch floc))] @
- (HExtlib.list_concat
- ~sep:[GA.Executable (floc, GA.Tactic (floc, None,GA.Shift floc))]
- (List.map (print_proof context) subgoals)) @
- [GA.Executable (floc, GA.Tactic (floc, None,GA.Merge floc))]
- else
- (* simple apply *)
- [GA.Executable (floc,
- GA.Tactic (floc,
- Some (GA.Apply
- (floc, print_term context (Cic.Appl (he::args)) )), GA.Dot floc))]
- @
- (match subgoals with
- | [] -> []
- | [x] -> print_proof context x
- | _ -> assert false)
- | Cic.Lambda (Cic.Name n, ty, bo) ->
- [GA.Executable (floc,
- GA.Tactic (floc,
- Some (GA.Cut (floc, Some n, (print_term context ty))),
- GA.Branch floc))] @
- (print_proof (Some (Cic.Name n, Cic.Decl ty)::context) bo) @
- [GA.Executable (floc, GA.Tactic (floc, None,GA.Shift floc))] @
- [GA.Executable (floc, GA.Tactic (floc,
- Some (GA.Assumption floc),GA.Merge floc))]
- | _ -> []
- (*
- debug_print (lazy (CicPp.ppterm t));
- assert false
- *)
- in
- (* performs a lambda closure of the proof term abstracting metas.
- * this is really an approximation of a closure, local subst of metas
- * is not kept into account *)
- let close_pt menv context t =
- let metas = CicUtil.metas_of_term t in
- let metas =
- HExtlib.list_uniq ~eq:(fun (i,_) (j,_) -> i = j)
- (List.sort (fun (i,_) (j,_) -> compare i j) metas)
- in
- let mk_rels_and_collapse_metas metas =
- let rec aux i map acc acc1 = function
- | [] -> acc, acc1, map
- | (j,_ as m)::tl ->
- let _,_,ty = CicUtil.lookup_meta j menv in
- try
- let n = List.assoc ty map in
- aux i map (Cic.Rel n :: acc) (m::acc1) tl
- with Not_found ->
- let map = (ty, i)::map in
- aux (i+1) map (Cic.Rel i :: acc) (m::acc1) tl
- in
- aux 1 [] [] [] metas
- in
- let rels, metas, map = mk_rels_and_collapse_metas metas in
- let n_lambdas = List.length map in
- let t =
- if metas = [] then
- t
- else
- let t =
- ProofEngineReduction.replace_lifting
- ~what:(List.map (fun (x,_) -> Cic.Meta (x,[])) metas)
- ~with_what:rels
- ~context:context
- ~equality:(fun _ x y ->
- match x,y with
- | Cic.Meta(i,_), Cic.Meta(j,_) when i=j -> true
- | _ -> false)
- ~where:(CicSubstitution.lift n_lambdas t)
- in
- let rec mk_lam = function
- | [] -> t
- | (ty,n)::tl ->
- let name = "fresh_"^ string_of_int n in
- Cic.Lambda (Cic.Name name, ty, mk_lam tl)
- in
- mk_lam
- (fst (List.fold_left
- (fun (l,liftno) (ty,_) ->
- (l @ [CicSubstitution.lift liftno ty,liftno] , liftno+1))
- ([],0) map))
- in
- t
- in
- let ast = print_proof context (close_pt menv context t) in
- let pp t =
- (* ZACK: setting width to 80 will trigger a bug of BoxPp.render_to_string
- * which will show up using the following command line:
- * ./tptp2grafite -tptppath ~tassi/TPTP-v3.1.1 GRP170-1 *)
- let width = max_int in
- let term_pp content_term =
- let pres_term = TermContentPres.pp_ast content_term in
- let lookup_uri = fun _ -> None in
- let markup = CicNotationPres.render ~lookup_uri pres_term in
- let s = "(" ^ BoxPp.render_to_string
- ~map_unicode_to_tex:(Helm_registry.get_bool
- "matita.paste_unicode_as_tex")
- List.hd width markup ^ ")" in
- Pcre.substitute
- ~pat:"\\\\forall [Ha-z][a-z0-9_]*" ~subst:(fun x -> "\n" ^ x) s
- in
- CicNotationPp.set_pp_term term_pp;
- let lazy_term_pp = fun x -> assert false in
- let obj_pp = CicNotationPp.pp_obj CicNotationPp.pp_term in
- GrafiteAstPp.pp_statement
- ~map_unicode_to_tex:(Helm_registry.get_bool
- "matita.paste_unicode_as_tex")
- ~term_pp ~lazy_term_pp ~obj_pp t
- in
- let script = String.concat "" (List.map pp ast) in
- prerr_endline script;
- stupid_indenter script
-;;
let eval_nmacro include_paths (buffer : GText.buffer) guistuff grafite_status user_goal unparsed_text parsed_text script mac =
let parsed_text_length = String.length parsed_text in
match mac with
| TA.NAutoInteractive (_, (Some _,_)) -> assert false
let rec eval_macro include_paths (buffer : GText.buffer) guistuff grafite_status user_goal unparsed_text parsed_text script mac =
- let module MQ = MetadataQuery in
let module CTC = CicTypeChecker in
(* no idea why ocaml wants this *)
let parsed_text_length = String.length parsed_text in
match mac with
(* REAL macro *)
| TA.Hint (loc, rewrite) -> (* MATITA 1.0 *) assert false
- | TA.Eval (_, kind, term) ->
+ | TA.Eval (_, kind, term) -> assert false (* MATITA 1.0
let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in
let context =
match user_goal with
let t_and_ty = Cic.Cast (term,ty) in
guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv));
[(grafite_status#set_proof_status No_proof), parsed_text ],"",
- parsed_text_length
- | TA.Check (_,term) ->
- let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in
- let context =
- match user_goal with
- None -> []
- | Some n -> GrafiteTypes.get_proof_context grafite_status n in
- let ty,_ = CTC.type_of_aux' metasenv context term CicUniv.empty_ugraph in
- let t_and_ty = Cic.Cast (term,ty) in
- guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv));
- [], "", parsed_text_length
- | TA.AutoInteractive (_, params) ->
- let user_goal' =
- match user_goal with
- Some n -> n
- | None -> raise NoUnfinishedProof
- in
- let proof = GrafiteTypes.get_current_proof grafite_status in
- let proof_status = proof,user_goal' in
- (try
- let _,menv,_,_,_,_ = proof in
- let i,cc,ty = CicUtil.lookup_meta user_goal' menv in
- let timestamp = Unix.gettimeofday () in
- let (_,menv,subst,_,_,_), _ =
- ProofEngineTypes.apply_tactic
- (Auto.auto_tac ~dbd ~params
- ~automation_cache:grafite_status#automation_cache)
- proof_status
- in
- let proof_term =
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable cc
- in
- CicMetaSubst.apply_subst subst (Cic.Meta (i,irl))
- in
- let time = Unix.gettimeofday () -. timestamp in
- let size, depth = Auto.size_and_depth cc menv proof_term in
- let trailer =
- Printf.sprintf
- "\n(* end auto(%s) proof: TIME=%4.2f SIZE=%d DEPTH=%d *)"
- Auto.revision time size depth
- in
- let proof_script =
- if List.exists (fun (s,_) -> s = "paramodulation") (snd params) then
- let proof_term, how_many_lambdas =
- Auto.lambda_close ~prefix_name:"orrible_hack_"
- proof_term menv cc
- in
- let ty,_ =
- CicTypeChecker.type_of_aux'
- [] [] proof_term CicUniv.empty_ugraph
- in
- prerr_endline (CicPp.ppterm proof_term ^ " n lambda= " ^ string_of_int how_many_lambdas);
- (* use declarative output *)
- let obj =
- (* il proof_term vive in cc, devo metterci i lambda no? *)
- (Cic.CurrentProof ("xxx",[],proof_term,ty,[],[]))
- in
- ApplyTransformation.txt_of_cic_object
- ~map_unicode_to_tex:(Helm_registry.get_bool
- "matita.paste_unicode_as_tex")
- ~skip_thm_and_qed:true
- ~skip_initial_lambdas:how_many_lambdas
- 80 [] obj
- else
- if true then
- (* use cic2grafite *)
- cic2grafite cc menv proof_term
- else
- (* alternative using FG stuff *)
- let map_unicode_to_tex =
- Helm_registry.get_bool "matita.paste_unicode_as_tex"
- in
- ApplyTransformation.procedural_txt_of_cic_term
- ~map_unicode_to_tex 78 [] cc proof_term
- in
- let text = comment parsed_text ^ "\n" ^ proof_script ^ trailer in
- [],text,parsed_text_length
- with
- ProofEngineTypes.Fail _ as exn ->
- raise exn
- (* [], comment parsed_text ^ "\nfail.\n", parsed_text_length *))
+ parsed_text_length *)
| TA.Inline (_, suri, params) ->
let str = "\n\n" ^
ApplyTransformation.txt_of_inline_macro
with
MatitaTypes.Cancel -> [], "", 0
| GrafiteEngine.Macro (_loc,lazy_macro) ->
- let context =
- match user_goal with
- None -> []
- | Some n -> GrafiteTypes.get_proof_context grafite_status n in
+ let context = [] in
let grafite_status,macro = lazy_macro context in
eval_macro include_paths buffer guistuff grafite_status
user_goal unparsed_text (skipped_txt ^ nonskipped_txt) script macro
* Invariant: this list length is 1 + length of statements *)
(** goal as seen by the user (i.e. metano corresponding to current tab) *)
- val mutable userGoal = None
+ val mutable userGoal = (None : int option)
(** text mark and tag representing locked part of a script *)
val locked_mark =
buffer#insert ~iter:(buffer#get_iter_at_mark (`MARK locked_mark)) newtext;
(* here we need to set the Goal in case we are going to cursor (or to
bottom) and we will face a macro *)
- match self#grafite_status#proof_status with
- Incomplete_proof p ->
- userGoal <-
- (try Some (Continuationals.Stack.find_goal p.stack)
- with Failure _ -> None)
- | _ -> userGoal <- None
+ userGoal <- None
method private _retract offset grafite_status new_statements
new_history
with Invalid_argument "Array.make" ->
HLog.error "The script is too big!\n"
- method onGoingProof () =
- match self#grafite_status#proof_status with
- | No_proof | Proof _ -> false
- | Incomplete_proof _ -> true
- | Intermediate _ -> assert false
-
-(* method proofStatus = MatitaTypes.get_proof_status self#status *)
- method proofMetasenv = GrafiteTypes.get_proof_metasenv self#grafite_status
-
- method proofContext =
- match userGoal with
- None -> []
- | Some n -> GrafiteTypes.get_proof_context self#grafite_status n
-
- method proofConclusion =
- match userGoal with
- None -> assert false
- | Some n ->
- GrafiteTypes.get_proof_conclusion self#grafite_status n
-
- method stack = GrafiteTypes.get_stack self#grafite_status
+ method stack = (assert false : Continuationals.Stack.t) (* MATITA 1.0 GrafiteTypes.get_stack
+ self#grafite_status *)
method setGoal n = userGoal <- n
method goal = userGoal
(** {2 Current proof} (if any) *)
- (** @return true if there is an ongoing proof, false otherise *)
- method onGoingProof: unit -> bool
-
- method proofMetasenv: Cic.metasenv (** @raise Statement_error *)
- method proofContext: Cic.context (** @raise Statement_error *)
- method proofConclusion: Cic.term (** @raise Statement_error *)
method stack: Continuationals.Stack.t (** @raise Statement_error *)
method setGoal: int option -> unit
type mathViewer_entry =
[ `About of abouts (* current proof *)
| `Check of string (* term *)
- | `Cic of Cic.term * Cic.metasenv
| `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution
| `Dir of string (* "directory" in cic uris namespace *)
| `Uri of UriManager.uri (* cic object uri *)
| `About `Grammar -> "about:grammar"
| `About `Hints -> "about:hints"
| `Check _ -> "check:"
- | `Cic (_, _) -> "term:"
| `NCic (_, _, _, _) -> "nterm:"
| `Dir uri -> uri
| `Uri uri -> UriManager.string_of_uri uri
type mathViewer_entry =
[ `About of abouts
| `Check of string
- | `Cic of Cic.term * Cic.metasenv
| `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution
| `Dir of string
| `Uri of UriManager.uri
end
;;
-let get_macro_context = function
- | Some status when status#proof_status = GrafiteTypes.No_proof -> []
- | Some status ->
- let stack = GrafiteTypes.get_stack status in
- let goal = Continuationals.Stack.find_goal stack in
- GrafiteTypes.get_proof_context status goal
- | None -> assert false
+let get_macro_context = function _ -> []
;;
let pp_times fname rc big_bang big_bang_u big_bang_s =
aux_for_dump print_cb grafite_status
in
let elapsed = Unix.time () -. time in
- let proof_status,moo_content_rev,lexicon_content_rev =
- grafite_status#proof_status, grafite_status#moo_content_rev,
+ let moo_content_rev,lexicon_content_rev =
+ grafite_status#moo_content_rev,
grafite_status#lstatus.LexiconEngine.lexicon_content_rev
in
- if proof_status <> GrafiteTypes.No_proof then
- (HLog.error
- "there are still incomplete proofs at the end of the script";
- pp_times fname false big_bang big_bang_u big_bang_s;
-(*
- LexiconSync.time_travel
- ~present:lexicon_status ~past:initial_lexicon_status;
-*)
- clean_exit baseuri false)
- else
(if Helm_registry.get_bool "matita.moo" then begin
(* FG: we do not generate .moo when dumping .mma files *)
GrafiteMarshal.save_moo moo_fname moo_content_rev;
projects / helm.git / commitdiff