# HG changeset patch # User blanchet # Date 1327336832 -3600 # Node ID 0b8b73b49848da0ee667f0c8c2b63111c5d4440e # Parent c248e4f1be74503115bb29eec5cf16769788473f renamed two files to make room for a new file diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/ATP.thy --- a/src/HOL/ATP.thy Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/ATP.thy Mon Jan 23 17:40:32 2012 +0100 @@ -12,9 +12,9 @@ "Tools/ATP/atp_util.ML" "Tools/ATP/atp_problem.ML" "Tools/ATP/atp_proof.ML" - "Tools/ATP/atp_redirect.ML" - ("Tools/ATP/atp_translate.ML") - ("Tools/ATP/atp_reconstruct.ML") + "Tools/ATP/atp_proof_redirect.ML" + ("Tools/ATP/atp_problem_generate.ML") + ("Tools/ATP/atp_proof_reconstruct.ML") ("Tools/ATP/atp_systems.ML") begin @@ -49,8 +49,8 @@ subsection {* Setup *} -use "Tools/ATP/atp_translate.ML" -use "Tools/ATP/atp_reconstruct.ML" +use "Tools/ATP/atp_problem_generate.ML" +use "Tools/ATP/atp_proof_reconstruct.ML" use "Tools/ATP/atp_systems.ML" setup ATP_Systems.setup diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/IsaMakefile --- a/src/HOL/IsaMakefile Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/IsaMakefile Mon Jan 23 17:40:32 2012 +0100 @@ -204,11 +204,11 @@ Set.thy \ Sum_Type.thy \ Tools/ATP/atp_problem.ML \ + Tools/ATP/atp_problem_generate.ML \ Tools/ATP/atp_proof.ML \ - Tools/ATP/atp_reconstruct.ML \ - Tools/ATP/atp_redirect.ML \ + Tools/ATP/atp_proof_reconstruct.ML \ + Tools/ATP/atp_proof_redirect.ML \ Tools/ATP/atp_systems.ML \ - Tools/ATP/atp_translate.ML \ Tools/ATP/atp_util.ML \ Tools/Datatype/datatype.ML \ Tools/Datatype/datatype_aux.ML \ @@ -241,9 +241,9 @@ Tools/Meson/meson.ML \ Tools/Meson/meson_clausify.ML \ Tools/Meson/meson_tactic.ML \ + Tools/Metis/metis_generate.ML \ Tools/Metis/metis_reconstruct.ML \ Tools/Metis/metis_tactic.ML \ - Tools/Metis/metis_translate.ML \ Tools/abel_cancel.ML \ Tools/arith_data.ML \ Tools/cnf_funcs.ML \ diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Metis.thy --- a/src/HOL/Metis.thy Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Metis.thy Mon Jan 23 17:40:32 2012 +0100 @@ -9,7 +9,7 @@ theory Metis imports ATP uses "~~/src/Tools/Metis/metis.ML" - ("Tools/Metis/metis_translate.ML") + ("Tools/Metis/metis_generate.ML") ("Tools/Metis/metis_reconstruct.ML") ("Tools/Metis/metis_tactic.ML") ("Tools/try_methods.ML") @@ -40,7 +40,7 @@ subsection {* Metis package *} -use "Tools/Metis/metis_translate.ML" +use "Tools/Metis/metis_generate.ML" use "Tools/Metis/metis_reconstruct.ML" use "Tools/Metis/metis_tactic.ML" diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Mirabelle/Tools/mirabelle_metis.ML --- a/src/HOL/Mirabelle/Tools/mirabelle_metis.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Mirabelle/Tools/mirabelle_metis.ML Mon Jan 23 17:40:32 2012 +0100 @@ -19,7 +19,8 @@ val facts = Facts.props (Proof_Context.facts_of (Proof.context_of pre)) fun metis ctxt = - Metis_Tactic.metis_tac [] ATP_Translate.lam_liftingN ctxt (thms @ facts) + Metis_Tactic.metis_tac [] ATP_Problem_Generate.lam_liftingN ctxt + (thms @ facts) in (if Mirabelle.can_apply timeout metis pre then "succeeded" else "failed") |> prefix (metis_tag id) diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Mon Jan 23 17:40:32 2012 +0100 @@ -336,7 +336,7 @@ | NONE => get_prover (default_prover_name ())) end -type locality = ATP_Translate.locality +type locality = ATP_Problem_Generate.locality (* hack *) fun reconstructor_from_msg args msg = @@ -410,7 +410,7 @@ fun failed failure = ({outcome = SOME failure, used_facts = [], run_time = Time.zeroTime, preplay = - K (ATP_Reconstruct.Failed_to_Play Sledgehammer_Provers.plain_metis), + K (ATP_Proof_Reconstruct.Failed_to_Play Sledgehammer_Provers.plain_metis), message = K "", message_tail = ""}, ~1) val ({outcome, used_facts, run_time, preplay, message, message_tail} : Sledgehammer_Provers.prover_result, @@ -581,12 +581,13 @@ ORELSE' sledge_tac 0.2 ATP_Systems.eN "mono_guards??" ORELSE' sledge_tac 0.2 ATP_Systems.vampireN "mono_guards??" ORELSE' sledge_tac 0.2 ATP_Systems.spassN "poly_tags" - ORELSE' Metis_Tactic.metis_tac [] ATP_Translate.combinatorsN ctxt thms + ORELSE' Metis_Tactic.metis_tac [] ATP_Problem_Generate.combinatorsN + ctxt thms else if !reconstructor = "smt" then SMT_Solver.smt_tac ctxt thms else if full then - Metis_Tactic.metis_tac [ATP_Reconstruct.full_typesN] - ATP_Reconstruct.metis_default_lam_trans ctxt thms + Metis_Tactic.metis_tac [ATP_Proof_Reconstruct.full_typesN] + ATP_Proof_Reconstruct.metis_default_lam_trans ctxt thms else if String.isPrefix "metis (" (!reconstructor) then let val (type_encs, lam_trans) = @@ -594,11 +595,11 @@ |> Outer_Syntax.scan Position.start |> filter Token.is_proper |> tl |> Metis_Tactic.parse_metis_options |> fst - |>> the_default [ATP_Reconstruct.partial_typesN] - ||> the_default ATP_Reconstruct.metis_default_lam_trans + |>> the_default [ATP_Proof_Reconstruct.partial_typesN] + ||> the_default ATP_Proof_Reconstruct.metis_default_lam_trans in Metis_Tactic.metis_tac type_encs lam_trans ctxt thms end else if !reconstructor = "metis" then - Metis_Tactic.metis_tac [] ATP_Reconstruct.metis_default_lam_trans ctxt + Metis_Tactic.metis_tac [] ATP_Proof_Reconstruct.metis_default_lam_trans ctxt thms else K all_tac diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/TPTP/CASC_Setup.thy --- a/src/HOL/TPTP/CASC_Setup.thy Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/TPTP/CASC_Setup.thy Mon Jan 23 17:40:32 2012 +0100 @@ -129,7 +129,7 @@ Sledgehammer_Filter.no_relevance_override)) ORELSE SOLVE_TIMEOUT (max_secs div 10) "metis" - (ALLGOALS (Metis_Tactic.metis_tac [] ATP_Translate.lam_liftingN ctxt [])) + (ALLGOALS (Metis_Tactic.metis_tac [] ATP_Problem_Generate.lam_liftingN ctxt [])) ORELSE SOLVE_TIMEOUT (max_secs div 10) "fast" (ALLGOALS (fast_tac ctxt)) ORELSE diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/TPTP/atp_export.ML --- a/src/HOL/TPTP/atp_export.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/TPTP/atp_export.ML Mon Jan 23 17:40:32 2012 +0100 @@ -22,8 +22,8 @@ struct open ATP_Problem -open ATP_Translate open ATP_Proof +open ATP_Problem_Generate open ATP_Systems val fact_name_of = prefix fact_prefix o ascii_of diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/TPTP/lib/Tools/tptp_translate --- a/src/HOL/TPTP/lib/Tools/tptp_translate Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/TPTP/lib/Tools/tptp_translate Mon Jan 23 17:40:32 2012 +0100 @@ -22,7 +22,7 @@ for FILE in "$@" do - echo "theory $SCRATCH imports \"Main\" begin ML {* ATP_Translate.translate_tptp_file \"$FILE\" *} end;" \ + echo "theory $SCRATCH imports \"Main\" begin ML {* ATP_Problem_Generate.translate_tptp_file \"$FILE\" *} end;" \ > /tmp/$SCRATCH.thy "$ISABELLE_PROCESS" -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" done diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_problem.ML --- a/src/HOL/Tools/ATP/atp_problem.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/ATP/atp_problem.ML Mon Jan 23 17:40:32 2012 +0100 @@ -349,7 +349,7 @@ (AQuant (if s = tptp_ho_forall then AForall else AExists, [(s', SOME ty)], AAtom tm)) | (_, true, [AAbs ((s', ty), tm)]) => - (* There is code in "ATP_Translate" to ensure that "Eps" is always + (* There is code in "ATP_Problem_Generate" to ensure that "Eps" is always applied to an abstraction. *) tptp_choice ^ "[" ^ s' ^ " : " ^ string_for_type format ty ^ "]: " ^ tptp_string_for_term format tm ^ "" diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_problem_generate.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP/atp_problem_generate.ML Mon Jan 23 17:40:32 2012 +0100 @@ -0,0 +1,2557 @@ +(* Title: HOL/Tools/ATP/atp_problem_generate.ML + Author: Fabian Immler, TU Muenchen + Author: Makarius + Author: Jasmin Blanchette, TU Muenchen + +Translation of HOL to FOL for Metis and Sledgehammer. +*) + +signature ATP_PROBLEM_GENERATE = +sig + type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term + type connective = ATP_Problem.connective + type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula + type atp_format = ATP_Problem.atp_format + type formula_kind = ATP_Problem.formula_kind + type 'a problem = 'a ATP_Problem.problem + + datatype locality = + General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained + + datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic + datatype strictness = Strict | Non_Strict + datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars + datatype type_level = + All_Types | + Noninf_Nonmono_Types of strictness * granularity | + Fin_Nonmono_Types of granularity | + Const_Arg_Types | + No_Types + type type_enc + + val type_tag_idempotence : bool Config.T + val type_tag_arguments : bool Config.T + val no_lamsN : string + val hide_lamsN : string + val lam_liftingN : string + val combinatorsN : string + val hybrid_lamsN : string + val keep_lamsN : string + val schematic_var_prefix : string + val fixed_var_prefix : string + val tvar_prefix : string + val tfree_prefix : string + val const_prefix : string + val type_const_prefix : string + val class_prefix : string + val lam_lifted_prefix : string + val lam_lifted_mono_prefix : string + val lam_lifted_poly_prefix : string + val skolem_const_prefix : string + val old_skolem_const_prefix : string + val new_skolem_const_prefix : string + val combinator_prefix : string + val type_decl_prefix : string + val sym_decl_prefix : string + val guards_sym_formula_prefix : string + val tags_sym_formula_prefix : string + val fact_prefix : string + val conjecture_prefix : string + val helper_prefix : string + val class_rel_clause_prefix : string + val arity_clause_prefix : string + val tfree_clause_prefix : string + val lam_fact_prefix : string + val typed_helper_suffix : string + val untyped_helper_suffix : string + val type_tag_idempotence_helper_name : string + val predicator_name : string + val app_op_name : string + val type_guard_name : string + val type_tag_name : string + val simple_type_prefix : string + val prefixed_predicator_name : string + val prefixed_app_op_name : string + val prefixed_type_tag_name : string + val ascii_of : string -> string + val unascii_of : string -> string + val unprefix_and_unascii : string -> string -> string option + val proxy_table : (string * (string * (thm * (string * string)))) list + val proxify_const : string -> (string * string) option + val invert_const : string -> string + val unproxify_const : string -> string + val new_skolem_var_name_from_const : string -> string + val atp_irrelevant_consts : string list + val atp_schematic_consts_of : term -> typ list Symtab.table + val is_type_enc_higher_order : type_enc -> bool + val polymorphism_of_type_enc : type_enc -> polymorphism + val level_of_type_enc : type_enc -> type_level + val is_type_enc_quasi_sound : type_enc -> bool + val is_type_enc_fairly_sound : type_enc -> bool + val type_enc_from_string : strictness -> string -> type_enc + val adjust_type_enc : atp_format -> type_enc -> type_enc + val mk_aconns : + connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula + val unmangled_const : string -> string * (string, 'b) ho_term list + val unmangled_const_name : string -> string + val helper_table : ((string * bool) * thm list) list + val trans_lams_from_string : + Proof.context -> type_enc -> string -> term list -> term list * term list + val factsN : string + val prepare_atp_problem : + Proof.context -> atp_format -> formula_kind -> formula_kind -> type_enc + -> bool -> string -> bool -> bool -> term list -> term + -> ((string * locality) * term) list + -> string problem * string Symtab.table * (string * locality) list vector + * (string * term) list * int Symtab.table + val atp_problem_weights : string problem -> (string * real) list +end; + +structure ATP_Problem_Generate : ATP_PROBLEM_GENERATE = +struct + +open ATP_Util +open ATP_Problem + +type name = string * string + +val type_tag_idempotence = + Attrib.setup_config_bool @{binding atp_type_tag_idempotence} (K false) +val type_tag_arguments = + Attrib.setup_config_bool @{binding atp_type_tag_arguments} (K false) + +val no_lamsN = "no_lams" (* used internally; undocumented *) +val hide_lamsN = "hide_lams" +val lam_liftingN = "lam_lifting" +val combinatorsN = "combinators" +val hybrid_lamsN = "hybrid_lams" +val keep_lamsN = "keep_lams" + +(* It's still unclear whether all TFF1 implementations will support type + signatures such as "!>[A : $tType] : $o", with ghost type variables. *) +val avoid_first_order_ghost_type_vars = false + +val bound_var_prefix = "B_" +val all_bound_var_prefix = "BA_" +val exist_bound_var_prefix = "BE_" +val schematic_var_prefix = "V_" +val fixed_var_prefix = "v_" +val tvar_prefix = "T_" +val tfree_prefix = "t_" +val const_prefix = "c_" +val type_const_prefix = "tc_" +val simple_type_prefix = "s_" +val class_prefix = "cl_" + +(* Freshness almost guaranteed! *) +val atp_weak_prefix = "ATP:" + +val lam_lifted_prefix = atp_weak_prefix ^ "Lam" +val lam_lifted_mono_prefix = lam_lifted_prefix ^ "m" +val lam_lifted_poly_prefix = lam_lifted_prefix ^ "p" + +val skolem_const_prefix = "ATP" ^ Long_Name.separator ^ "Sko" +val old_skolem_const_prefix = skolem_const_prefix ^ "o" +val new_skolem_const_prefix = skolem_const_prefix ^ "n" + +val combinator_prefix = "COMB" + +val type_decl_prefix = "ty_" +val sym_decl_prefix = "sy_" +val guards_sym_formula_prefix = "gsy_" +val tags_sym_formula_prefix = "tsy_" +val fact_prefix = "fact_" +val conjecture_prefix = "conj_" +val helper_prefix = "help_" +val class_rel_clause_prefix = "clar_" +val arity_clause_prefix = "arity_" +val tfree_clause_prefix = "tfree_" + +val lam_fact_prefix = "ATP.lambda_" +val typed_helper_suffix = "_T" +val untyped_helper_suffix = "_U" +val type_tag_idempotence_helper_name = helper_prefix ^ "ti_idem" + +val predicator_name = "pp" +val app_op_name = "aa" +val type_guard_name = "gg" +val type_tag_name = "tt" + +val prefixed_predicator_name = const_prefix ^ predicator_name +val prefixed_app_op_name = const_prefix ^ app_op_name +val prefixed_type_tag_name = const_prefix ^ type_tag_name + +(*Escaping of special characters. + Alphanumeric characters are left unchanged. + The character _ goes to __ + Characters in the range ASCII space to / go to _A to _P, respectively. + Other characters go to _nnn where nnn is the decimal ASCII code.*) +val upper_a_minus_space = Char.ord #"A" - Char.ord #" " + +fun stringN_of_int 0 _ = "" + | stringN_of_int k n = + stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10) + +fun ascii_of_char c = + if Char.isAlphaNum c then + String.str c + else if c = #"_" then + "__" + else if #" " <= c andalso c <= #"/" then + "_" ^ String.str (Char.chr (Char.ord c + upper_a_minus_space)) + else + (* fixed width, in case more digits follow *) + "_" ^ stringN_of_int 3 (Char.ord c) + +val ascii_of = String.translate ascii_of_char + +(** Remove ASCII armoring from names in proof files **) + +(* We don't raise error exceptions because this code can run inside a worker + thread. Also, the errors are impossible. *) +val unascii_of = + let + fun un rcs [] = String.implode(rev rcs) + | un rcs [#"_"] = un (#"_" :: rcs) [] (* ERROR *) + (* Three types of _ escapes: __, _A to _P, _nnn *) + | un rcs (#"_" :: #"_" :: cs) = un (#"_" :: rcs) cs + | un rcs (#"_" :: c :: cs) = + if #"A" <= c andalso c<= #"P" then + (* translation of #" " to #"/" *) + un (Char.chr (Char.ord c - upper_a_minus_space) :: rcs) cs + else + let val digits = List.take (c :: cs, 3) handle General.Subscript => [] in + case Int.fromString (String.implode digits) of + SOME n => un (Char.chr n :: rcs) (List.drop (cs, 2)) + | NONE => un (c :: #"_" :: rcs) cs (* ERROR *) + end + | un rcs (c :: cs) = un (c :: rcs) cs + in un [] o String.explode end + +(* If string s has the prefix s1, return the result of deleting it, + un-ASCII'd. *) +fun unprefix_and_unascii s1 s = + if String.isPrefix s1 s then + SOME (unascii_of (String.extract (s, size s1, NONE))) + else + NONE + +val proxy_table = + [("c_False", (@{const_name False}, (@{thm fFalse_def}, + ("fFalse", @{const_name ATP.fFalse})))), + ("c_True", (@{const_name True}, (@{thm fTrue_def}, + ("fTrue", @{const_name ATP.fTrue})))), + ("c_Not", (@{const_name Not}, (@{thm fNot_def}, + ("fNot", @{const_name ATP.fNot})))), + ("c_conj", (@{const_name conj}, (@{thm fconj_def}, + ("fconj", @{const_name ATP.fconj})))), + ("c_disj", (@{const_name disj}, (@{thm fdisj_def}, + ("fdisj", @{const_name ATP.fdisj})))), + ("c_implies", (@{const_name implies}, (@{thm fimplies_def}, + ("fimplies", @{const_name ATP.fimplies})))), + ("equal", (@{const_name HOL.eq}, (@{thm fequal_def}, + ("fequal", @{const_name ATP.fequal})))), + ("c_All", (@{const_name All}, (@{thm fAll_def}, + ("fAll", @{const_name ATP.fAll})))), + ("c_Ex", (@{const_name Ex}, (@{thm fEx_def}, + ("fEx", @{const_name ATP.fEx}))))] + +val proxify_const = AList.lookup (op =) proxy_table #> Option.map (snd o snd) + +(* Readable names for the more common symbolic functions. Do not mess with the + table unless you know what you are doing. *) +val const_trans_table = + [(@{type_name Product_Type.prod}, "prod"), + (@{type_name Sum_Type.sum}, "sum"), + (@{const_name False}, "False"), + (@{const_name True}, "True"), + (@{const_name Not}, "Not"), + (@{const_name conj}, "conj"), + (@{const_name disj}, "disj"), + (@{const_name implies}, "implies"), + (@{const_name HOL.eq}, "equal"), + (@{const_name All}, "All"), + (@{const_name Ex}, "Ex"), + (@{const_name If}, "If"), + (@{const_name Set.member}, "member"), + (@{const_name Meson.COMBI}, combinator_prefix ^ "I"), + (@{const_name Meson.COMBK}, combinator_prefix ^ "K"), + (@{const_name Meson.COMBB}, combinator_prefix ^ "B"), + (@{const_name Meson.COMBC}, combinator_prefix ^ "C"), + (@{const_name Meson.COMBS}, combinator_prefix ^ "S")] + |> Symtab.make + |> fold (Symtab.update o swap o snd o snd o snd) proxy_table + +(* Invert the table of translations between Isabelle and ATPs. *) +val const_trans_table_inv = + const_trans_table |> Symtab.dest |> map swap |> Symtab.make +val const_trans_table_unprox = + Symtab.empty + |> fold (fn (_, (isa, (_, (_, atp)))) => Symtab.update (atp, isa)) proxy_table + +val invert_const = perhaps (Symtab.lookup const_trans_table_inv) +val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox) + +fun lookup_const c = + case Symtab.lookup const_trans_table c of + SOME c' => c' + | NONE => ascii_of c + +fun ascii_of_indexname (v, 0) = ascii_of v + | ascii_of_indexname (v, i) = ascii_of v ^ "_" ^ string_of_int i + +fun make_bound_var x = bound_var_prefix ^ ascii_of x +fun make_all_bound_var x = all_bound_var_prefix ^ ascii_of x +fun make_exist_bound_var x = exist_bound_var_prefix ^ ascii_of x +fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v +fun make_fixed_var x = fixed_var_prefix ^ ascii_of x + +fun make_schematic_type_var (x, i) = + tvar_prefix ^ (ascii_of_indexname (unprefix "'" x, i)) +fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (unprefix "'" x)) + +(* "HOL.eq" and choice are mapped to the ATP's equivalents *) +local + val choice_const = (fst o dest_Const o HOLogic.choice_const) Term.dummyT + fun default c = const_prefix ^ lookup_const c +in + fun make_fixed_const _ @{const_name HOL.eq} = tptp_old_equal + | make_fixed_const (SOME (THF (_, _, THF_With_Choice))) c = + if c = choice_const then tptp_choice else default c + | make_fixed_const _ c = default c +end + +fun make_fixed_type_const c = type_const_prefix ^ lookup_const c + +fun make_type_class clas = class_prefix ^ ascii_of clas + +fun new_skolem_var_name_from_const s = + let val ss = s |> space_explode Long_Name.separator in + nth ss (length ss - 2) + end + +(* These are either simplified away by "Meson.presimplify" (most of the time) or + handled specially via "fFalse", "fTrue", ..., "fequal". *) +val atp_irrelevant_consts = + [@{const_name False}, @{const_name True}, @{const_name Not}, + @{const_name conj}, @{const_name disj}, @{const_name implies}, + @{const_name HOL.eq}, @{const_name If}, @{const_name Let}] + +val atp_monomorph_bad_consts = + atp_irrelevant_consts @ + (* These are ignored anyway by the relevance filter (unless they appear in + higher-order places) but not by the monomorphizer. *) + [@{const_name all}, @{const_name "==>"}, @{const_name "=="}, + @{const_name Trueprop}, @{const_name All}, @{const_name Ex}, + @{const_name Ex1}, @{const_name Ball}, @{const_name Bex}] + +fun add_schematic_const (x as (_, T)) = + Monomorph.typ_has_tvars T ? Symtab.insert_list (op =) x +val add_schematic_consts_of = + Term.fold_aterms (fn Const (x as (s, _)) => + not (member (op =) atp_monomorph_bad_consts s) + ? add_schematic_const x + | _ => I) +fun atp_schematic_consts_of t = add_schematic_consts_of t Symtab.empty + +(** Definitions and functions for FOL clauses and formulas for TPTP **) + +(** Isabelle arities **) + +type arity_atom = name * name * name list + +val type_class = the_single @{sort type} + +type arity_clause = + {name : string, + prem_atoms : arity_atom list, + concl_atom : arity_atom} + +fun add_prem_atom tvar = + fold (fn s => s <> type_class ? cons (`make_type_class s, `I tvar, [])) + +(* Arity of type constructor "tcon :: (arg1, ..., argN) res" *) +fun make_axiom_arity_clause (tcons, name, (cls, args)) = + let + val tvars = map (prefix tvar_prefix o string_of_int) (1 upto length args) + val tvars_srts = ListPair.zip (tvars, args) + in + {name = name, + prem_atoms = [] |> fold (uncurry add_prem_atom) tvars_srts, + concl_atom = (`make_type_class cls, `make_fixed_type_const tcons, + tvars ~~ tvars)} + end + +fun arity_clause _ _ (_, []) = [] + | arity_clause seen n (tcons, ("HOL.type", _) :: ars) = (* ignore *) + arity_clause seen n (tcons, ars) + | arity_clause seen n (tcons, (ar as (class, _)) :: ars) = + if member (op =) seen class then + (* multiple arities for the same (tycon, class) pair *) + make_axiom_arity_clause (tcons, + lookup_const tcons ^ "___" ^ ascii_of class ^ "_" ^ string_of_int n, + ar) :: + arity_clause seen (n + 1) (tcons, ars) + else + make_axiom_arity_clause (tcons, lookup_const tcons ^ "___" ^ + ascii_of class, ar) :: + arity_clause (class :: seen) n (tcons, ars) + +fun multi_arity_clause [] = [] + | multi_arity_clause ((tcons, ars) :: tc_arlists) = + arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists + +(* Generate all pairs (tycon, class, sorts) such that tycon belongs to class in + theory thy provided its arguments have the corresponding sorts. *) +fun type_class_pairs thy tycons classes = + let + val alg = Sign.classes_of thy + fun domain_sorts tycon = Sorts.mg_domain alg tycon o single + fun add_class tycon class = + cons (class, domain_sorts tycon class) + handle Sorts.CLASS_ERROR _ => I + fun try_classes tycon = (tycon, fold (add_class tycon) classes []) + in map try_classes tycons end + +(*Proving one (tycon, class) membership may require proving others, so iterate.*) +fun iter_type_class_pairs _ _ [] = ([], []) + | iter_type_class_pairs thy tycons classes = + let + fun maybe_insert_class s = + (s <> type_class andalso not (member (op =) classes s)) + ? insert (op =) s + val cpairs = type_class_pairs thy tycons classes + val newclasses = + [] |> fold (fold (fold (fold maybe_insert_class) o snd) o snd) cpairs + val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses + in (classes' @ classes, union (op =) cpairs' cpairs) end + +fun make_arity_clauses thy tycons = + iter_type_class_pairs thy tycons ##> multi_arity_clause + + +(** Isabelle class relations **) + +type class_rel_clause = + {name : string, + subclass : name, + superclass : name} + +(* Generate all pairs (sub, super) such that sub is a proper subclass of super + in theory "thy". *) +fun class_pairs _ [] _ = [] + | class_pairs thy subs supers = + let + val class_less = Sorts.class_less (Sign.classes_of thy) + fun add_super sub super = class_less (sub, super) ? cons (sub, super) + fun add_supers sub = fold (add_super sub) supers + in fold add_supers subs [] end + +fun make_class_rel_clause (sub, super) = + {name = sub ^ "_" ^ super, subclass = `make_type_class sub, + superclass = `make_type_class super} + +fun make_class_rel_clauses thy subs supers = + map make_class_rel_clause (class_pairs thy subs supers) + +(* intermediate terms *) +datatype iterm = + IConst of name * typ * typ list | + IVar of name * typ | + IApp of iterm * iterm | + IAbs of (name * typ) * iterm + +fun ityp_of (IConst (_, T, _)) = T + | ityp_of (IVar (_, T)) = T + | ityp_of (IApp (t1, _)) = snd (dest_funT (ityp_of t1)) + | ityp_of (IAbs ((_, T), tm)) = T --> ityp_of tm + +(*gets the head of a combinator application, along with the list of arguments*) +fun strip_iterm_comb u = + let + fun stripc (IApp (t, u), ts) = stripc (t, u :: ts) + | stripc x = x + in stripc (u, []) end + +fun atomic_types_of T = fold_atyps (insert (op =)) T [] + +val tvar_a_str = "'a" +val tvar_a = TVar ((tvar_a_str, 0), HOLogic.typeS) +val tvar_a_name = (make_schematic_type_var (tvar_a_str, 0), tvar_a_str) +val itself_name = `make_fixed_type_const @{type_name itself} +val TYPE_name = `(make_fixed_const NONE) @{const_name TYPE} +val tvar_a_atype = AType (tvar_a_name, []) +val a_itself_atype = AType (itself_name, [tvar_a_atype]) + +fun new_skolem_const_name s num_T_args = + [new_skolem_const_prefix, s, string_of_int num_T_args] + |> space_implode Long_Name.separator + +fun robust_const_type thy s = + if s = app_op_name then + Logic.varifyT_global @{typ "('a => 'b) => 'a => 'b"} + else if String.isPrefix lam_lifted_prefix s then + Logic.varifyT_global @{typ "'a => 'b"} + else + (* Old Skolems throw a "TYPE" exception here, which will be caught. *) + s |> Sign.the_const_type thy + +(* This function only makes sense if "T" is as general as possible. *) +fun robust_const_typargs thy (s, T) = + if s = app_op_name then + let val (T1, T2) = T |> domain_type |> dest_funT in [T1, T2] end + else if String.isPrefix old_skolem_const_prefix s then + [] |> Term.add_tvarsT T |> rev |> map TVar + else if String.isPrefix lam_lifted_prefix s then + if String.isPrefix lam_lifted_poly_prefix s then + let val (T1, T2) = T |> dest_funT in [T1, T2] end + else + [] + else + (s, T) |> Sign.const_typargs thy + +(* Converts an Isabelle/HOL term (with combinators) into an intermediate term. + Also accumulates sort infomation. *) +fun iterm_from_term thy format bs (P $ Q) = + let + val (P', P_atomics_Ts) = iterm_from_term thy format bs P + val (Q', Q_atomics_Ts) = iterm_from_term thy format bs Q + in (IApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end + | iterm_from_term thy format _ (Const (c, T)) = + (IConst (`(make_fixed_const (SOME format)) c, T, + robust_const_typargs thy (c, T)), + atomic_types_of T) + | iterm_from_term _ _ _ (Free (s, T)) = + (IConst (`make_fixed_var s, T, []), atomic_types_of T) + | iterm_from_term _ format _ (Var (v as (s, _), T)) = + (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then + let + val Ts = T |> strip_type |> swap |> op :: + val s' = new_skolem_const_name s (length Ts) + in IConst (`(make_fixed_const (SOME format)) s', T, Ts) end + else + IVar ((make_schematic_var v, s), T), atomic_types_of T) + | iterm_from_term _ _ bs (Bound j) = + nth bs j |> (fn (_, (name, T)) => (IConst (name, T, []), atomic_types_of T)) + | iterm_from_term thy format bs (Abs (s, T, t)) = + let + fun vary s = s |> AList.defined (op =) bs s ? vary o Symbol.bump_string + val s = vary s + val name = `make_bound_var s + val (tm, atomic_Ts) = iterm_from_term thy format ((s, (name, T)) :: bs) t + in (IAbs ((name, T), tm), union (op =) atomic_Ts (atomic_types_of T)) end + +datatype locality = + General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained + +datatype order = First_Order | Higher_Order +datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic +datatype strictness = Strict | Non_Strict +datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars +datatype type_level = + All_Types | + Noninf_Nonmono_Types of strictness * granularity | + Fin_Nonmono_Types of granularity | + Const_Arg_Types | + No_Types + +datatype type_enc = + Simple_Types of order * polymorphism * type_level | + Guards of polymorphism * type_level | + Tags of polymorphism * type_level + +fun is_type_enc_higher_order (Simple_Types (Higher_Order, _, _)) = true + | is_type_enc_higher_order _ = false + +fun polymorphism_of_type_enc (Simple_Types (_, poly, _)) = poly + | polymorphism_of_type_enc (Guards (poly, _)) = poly + | polymorphism_of_type_enc (Tags (poly, _)) = poly + +fun level_of_type_enc (Simple_Types (_, _, level)) = level + | level_of_type_enc (Guards (_, level)) = level + | level_of_type_enc (Tags (_, level)) = level + +fun granularity_of_type_level (Noninf_Nonmono_Types (_, grain)) = grain + | granularity_of_type_level (Fin_Nonmono_Types grain) = grain + | granularity_of_type_level _ = All_Vars + +fun is_type_level_quasi_sound All_Types = true + | is_type_level_quasi_sound (Noninf_Nonmono_Types _) = true + | is_type_level_quasi_sound _ = false +val is_type_enc_quasi_sound = is_type_level_quasi_sound o level_of_type_enc + +fun is_type_level_fairly_sound (Fin_Nonmono_Types _) = true + | is_type_level_fairly_sound level = is_type_level_quasi_sound level +val is_type_enc_fairly_sound = is_type_level_fairly_sound o level_of_type_enc + +fun is_type_level_monotonicity_based (Noninf_Nonmono_Types _) = true + | is_type_level_monotonicity_based (Fin_Nonmono_Types _) = true + | is_type_level_monotonicity_based _ = false + +(* "_query", "_bang", and "_at" are for the ASCII-challenged Metis and + Mirabelle. *) +val queries = ["?", "_query"] +val bangs = ["!", "_bang"] +val ats = ["@", "_at"] + +fun try_unsuffixes ss s = + fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE + +fun try_nonmono constr suffixes fallback s = + case try_unsuffixes suffixes s of + SOME s => + (case try_unsuffixes suffixes s of + SOME s => (constr Positively_Naked_Vars, s) + | NONE => + case try_unsuffixes ats s of + SOME s => (constr Ghost_Type_Arg_Vars, s) + | NONE => (constr All_Vars, s)) + | NONE => fallback s + +fun type_enc_from_string strictness s = + (case try (unprefix "poly_") s of + SOME s => (SOME Polymorphic, s) + | NONE => + case try (unprefix "raw_mono_") s of + SOME s => (SOME Raw_Monomorphic, s) + | NONE => + case try (unprefix "mono_") s of + SOME s => (SOME Mangled_Monomorphic, s) + | NONE => (NONE, s)) + ||> (pair All_Types + |> try_nonmono Fin_Nonmono_Types bangs + |> try_nonmono (curry Noninf_Nonmono_Types strictness) queries) + |> (fn (poly, (level, core)) => + case (core, (poly, level)) of + ("simple", (SOME poly, _)) => + (case (poly, level) of + (Polymorphic, All_Types) => + Simple_Types (First_Order, Polymorphic, All_Types) + | (Mangled_Monomorphic, _) => + if granularity_of_type_level level = All_Vars then + Simple_Types (First_Order, Mangled_Monomorphic, level) + else + raise Same.SAME + | _ => raise Same.SAME) + | ("simple_higher", (SOME poly, _)) => + (case (poly, level) of + (Polymorphic, All_Types) => + Simple_Types (Higher_Order, Polymorphic, All_Types) + | (_, Noninf_Nonmono_Types _) => raise Same.SAME + | (Mangled_Monomorphic, _) => + if granularity_of_type_level level = All_Vars then + Simple_Types (Higher_Order, Mangled_Monomorphic, level) + else + raise Same.SAME + | _ => raise Same.SAME) + | ("guards", (SOME poly, _)) => + if poly = Mangled_Monomorphic andalso + granularity_of_type_level level = Ghost_Type_Arg_Vars then + raise Same.SAME + else + Guards (poly, level) + | ("tags", (SOME poly, _)) => + if granularity_of_type_level level = Ghost_Type_Arg_Vars then + raise Same.SAME + else + Tags (poly, level) + | ("args", (SOME poly, All_Types (* naja *))) => + Guards (poly, Const_Arg_Types) + | ("erased", (NONE, All_Types (* naja *))) => + Guards (Polymorphic, No_Types) + | _ => raise Same.SAME) + handle Same.SAME => error ("Unknown type encoding: " ^ quote s ^ ".") + +fun adjust_type_enc (THF (TPTP_Monomorphic, _, _)) + (Simple_Types (order, _, level)) = + Simple_Types (order, Mangled_Monomorphic, level) + | adjust_type_enc (THF _) type_enc = type_enc + | adjust_type_enc (TFF (TPTP_Monomorphic, _)) (Simple_Types (_, _, level)) = + Simple_Types (First_Order, Mangled_Monomorphic, level) + | adjust_type_enc (DFG DFG_Sorted) (Simple_Types (_, _, level)) = + Simple_Types (First_Order, Mangled_Monomorphic, level) + | adjust_type_enc (TFF _) (Simple_Types (_, poly, level)) = + Simple_Types (First_Order, poly, level) + | adjust_type_enc format (Simple_Types (_, poly, level)) = + adjust_type_enc format (Guards (poly, level)) + | adjust_type_enc CNF_UEQ (type_enc as Guards stuff) = + (if is_type_enc_fairly_sound type_enc then Tags else Guards) stuff + | adjust_type_enc _ type_enc = type_enc + +fun constify_lifted (t $ u) = constify_lifted t $ constify_lifted u + | constify_lifted (Abs (s, T, t)) = Abs (s, T, constify_lifted t) + | constify_lifted (Free (x as (s, _))) = + (if String.isPrefix lam_lifted_prefix s then Const else Free) x + | constify_lifted t = t + +(* Requires bound variables not to clash with any schematic variables (as should + be the case right after lambda-lifting). *) +fun open_form (Const (@{const_name All}, _) $ Abs (s, T, t)) = + let + val names = Name.make_context (map fst (Term.add_var_names t [])) + val (s, _) = Name.variant s names + in open_form (subst_bound (Var ((s, 0), T), t)) end + | open_form t = t + +fun lift_lams_part_1 ctxt type_enc = + map close_form #> rpair ctxt + #-> Lambda_Lifting.lift_lambdas + (SOME ((if polymorphism_of_type_enc type_enc = Polymorphic then + lam_lifted_poly_prefix + else + lam_lifted_mono_prefix) ^ "_a")) + Lambda_Lifting.is_quantifier + #> fst +val lift_lams_part_2 = pairself (map (open_form o constify_lifted)) +val lift_lams = lift_lams_part_2 ooo lift_lams_part_1 + +fun intentionalize_def (Const (@{const_name All}, _) $ Abs (_, _, t)) = + intentionalize_def t + | intentionalize_def (Const (@{const_name HOL.eq}, _) $ t $ u) = + let + fun lam T t = Abs (Name.uu, T, t) + val (head, args) = strip_comb t ||> rev + val head_T = fastype_of head + val n = length args + val arg_Ts = head_T |> binder_types |> take n |> rev + val u = u |> subst_atomic (args ~~ map Bound (0 upto n - 1)) + in HOLogic.eq_const head_T $ head $ fold lam arg_Ts u end + | intentionalize_def t = t + +type translated_formula = + {name : string, + locality : locality, + kind : formula_kind, + iformula : (name, typ, iterm) formula, + atomic_types : typ list} + +fun update_iformula f ({name, locality, kind, iformula, atomic_types} + : translated_formula) = + {name = name, locality = locality, kind = kind, iformula = f iformula, + atomic_types = atomic_types} : translated_formula + +fun fact_lift f ({iformula, ...} : translated_formula) = f iformula + +fun insert_type ctxt get_T x xs = + let val T = get_T x in + if exists (type_instance ctxt T o get_T) xs then xs + else x :: filter_out (type_generalization ctxt T o get_T) xs + end + +(* The Booleans indicate whether all type arguments should be kept. *) +datatype type_arg_policy = + Explicit_Type_Args of bool (* infer_from_term_args *) | + Mangled_Type_Args | + No_Type_Args + +fun type_arg_policy monom_constrs type_enc s = + let val poly = polymorphism_of_type_enc type_enc in + if s = type_tag_name then + if poly = Mangled_Monomorphic then Mangled_Type_Args + else Explicit_Type_Args false + else case type_enc of + Simple_Types (_, Polymorphic, _) => Explicit_Type_Args false + | Tags (_, All_Types) => No_Type_Args + | _ => + let val level = level_of_type_enc type_enc in + if level = No_Types orelse s = @{const_name HOL.eq} orelse + (s = app_op_name andalso level = Const_Arg_Types) then + No_Type_Args + else if poly = Mangled_Monomorphic then + Mangled_Type_Args + else if member (op =) monom_constrs s andalso + granularity_of_type_level level = Positively_Naked_Vars then + No_Type_Args + else + Explicit_Type_Args + (level = All_Types orelse + granularity_of_type_level level = Ghost_Type_Arg_Vars) + end + end + +(* Make atoms for sorted type variables. *) +fun generic_add_sorts_on_type (_, []) = I + | generic_add_sorts_on_type ((x, i), s :: ss) = + generic_add_sorts_on_type ((x, i), ss) + #> (if s = the_single @{sort HOL.type} then + I + else if i = ~1 then + insert (op =) (`make_type_class s, `make_fixed_type_var x) + else + insert (op =) (`make_type_class s, + (make_schematic_type_var (x, i), x))) +fun add_sorts_on_tfree (TFree (s, S)) = generic_add_sorts_on_type ((s, ~1), S) + | add_sorts_on_tfree _ = I +fun add_sorts_on_tvar (TVar z) = generic_add_sorts_on_type z + | add_sorts_on_tvar _ = I + +fun type_class_formula type_enc class arg = + AAtom (ATerm (class, arg :: + (case type_enc of + Simple_Types (First_Order, Polymorphic, _) => + if avoid_first_order_ghost_type_vars then [ATerm (TYPE_name, [arg])] + else [] + | _ => []))) +fun formulas_for_types type_enc add_sorts_on_typ Ts = + [] |> level_of_type_enc type_enc <> No_Types ? fold add_sorts_on_typ Ts + |> map (fn (class, name) => + type_class_formula type_enc class (ATerm (name, []))) + +fun mk_aconns c phis = + let val (phis', phi') = split_last phis in + fold_rev (mk_aconn c) phis' phi' + end +fun mk_ahorn [] phi = phi + | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi]) +fun mk_aquant _ [] phi = phi + | mk_aquant q xs (phi as AQuant (q', xs', phi')) = + if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi) + | mk_aquant q xs phi = AQuant (q, xs, phi) + +fun close_universally add_term_vars phi = + let + fun add_formula_vars bounds (AQuant (_, xs, phi)) = + add_formula_vars (map fst xs @ bounds) phi + | add_formula_vars bounds (AConn (_, phis)) = + fold (add_formula_vars bounds) phis + | add_formula_vars bounds (AAtom tm) = add_term_vars bounds tm + in mk_aquant AForall (add_formula_vars [] phi []) phi end + +fun add_term_vars bounds (ATerm (name as (s, _), tms)) = + (if is_tptp_variable s andalso + not (String.isPrefix tvar_prefix s) andalso + not (member (op =) bounds name) then + insert (op =) (name, NONE) + else + I) + #> fold (add_term_vars bounds) tms + | add_term_vars bounds (AAbs ((name, _), tm)) = + add_term_vars (name :: bounds) tm +fun close_formula_universally phi = close_universally add_term_vars phi + +fun add_iterm_vars bounds (IApp (tm1, tm2)) = + fold (add_iterm_vars bounds) [tm1, tm2] + | add_iterm_vars _ (IConst _) = I + | add_iterm_vars bounds (IVar (name, T)) = + not (member (op =) bounds name) ? insert (op =) (name, SOME T) + | add_iterm_vars bounds (IAbs (_, tm)) = add_iterm_vars bounds tm +fun close_iformula_universally phi = close_universally add_iterm_vars phi + +val fused_infinite_type_name = @{type_name ind} (* any infinite type *) +val fused_infinite_type = Type (fused_infinite_type_name, []) + +fun tvar_name (x as (s, _)) = (make_schematic_type_var x, s) + +fun ho_term_from_typ format type_enc = + let + fun term (Type (s, Ts)) = + ATerm (case (is_type_enc_higher_order type_enc, s) of + (true, @{type_name bool}) => `I tptp_bool_type + | (true, @{type_name fun}) => `I tptp_fun_type + | _ => if s = fused_infinite_type_name andalso + is_format_typed format then + `I tptp_individual_type + else + `make_fixed_type_const s, + map term Ts) + | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, []) + | term (TVar (x, _)) = ATerm (tvar_name x, []) + in term end + +fun ho_term_for_type_arg format type_enc T = + if T = dummyT then NONE else SOME (ho_term_from_typ format type_enc T) + +(* This shouldn't clash with anything else. *) +val mangled_type_sep = "\000" + +fun generic_mangled_type_name f (ATerm (name, [])) = f name + | generic_mangled_type_name f (ATerm (name, tys)) = + f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys) + ^ ")" + | generic_mangled_type_name _ _ = raise Fail "unexpected type abstraction" + +fun mangled_type format type_enc = + generic_mangled_type_name fst o ho_term_from_typ format type_enc + +fun make_simple_type s = + if s = tptp_bool_type orelse s = tptp_fun_type orelse + s = tptp_individual_type then + s + else + simple_type_prefix ^ ascii_of s + +fun ho_type_from_ho_term type_enc pred_sym ary = + let + fun to_mangled_atype ty = + AType ((make_simple_type (generic_mangled_type_name fst ty), + generic_mangled_type_name snd ty), []) + fun to_poly_atype (ATerm (name, tys)) = AType (name, map to_poly_atype tys) + | to_poly_atype _ = raise Fail "unexpected type abstraction" + val to_atype = + if polymorphism_of_type_enc type_enc = Polymorphic then to_poly_atype + else to_mangled_atype + fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1)) + fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty + | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys + | to_fo _ _ = raise Fail "unexpected type abstraction" + fun to_ho (ty as ATerm ((s, _), tys)) = + if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty + | to_ho _ = raise Fail "unexpected type abstraction" + in if is_type_enc_higher_order type_enc then to_ho else to_fo ary end + +fun ho_type_from_typ format type_enc pred_sym ary = + ho_type_from_ho_term type_enc pred_sym ary + o ho_term_from_typ format type_enc + +fun mangled_const_name format type_enc T_args (s, s') = + let + val ty_args = T_args |> map_filter (ho_term_for_type_arg format type_enc) + fun type_suffix f g = + fold_rev (curry (op ^) o g o prefix mangled_type_sep + o generic_mangled_type_name f) ty_args "" + in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end + +val parse_mangled_ident = + Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode + +fun parse_mangled_type x = + (parse_mangled_ident + -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")") + [] >> ATerm) x +and parse_mangled_types x = + (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x + +fun unmangled_type s = + s |> suffix ")" |> raw_explode + |> Scan.finite Symbol.stopper + (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^ + quote s)) parse_mangled_type)) + |> fst + +val unmangled_const_name = space_explode mangled_type_sep #> hd +fun unmangled_const s = + let val ss = space_explode mangled_type_sep s in + (hd ss, map unmangled_type (tl ss)) + end + +fun introduce_proxies_in_iterm type_enc = + let + fun tweak_ho_quant ho_quant T [IAbs _] = IConst (`I ho_quant, T, []) + | tweak_ho_quant ho_quant (T as Type (_, [p_T as Type (_, [x_T, _]), _])) + _ = + (* Eta-expand "!!" and "??", to work around LEO-II 1.2.8 parser + limitation. This works in conjuction with special code in + "ATP_Problem" that uses the syntactic sugar "!" and "?" whenever + possible. *) + IAbs ((`I "P", p_T), + IApp (IConst (`I ho_quant, T, []), + IAbs ((`I "X", x_T), + IApp (IConst (`I "P", p_T, []), + IConst (`I "X", x_T, []))))) + | tweak_ho_quant _ _ _ = raise Fail "unexpected type for quantifier" + fun intro top_level args (IApp (tm1, tm2)) = + IApp (intro top_level (tm2 :: args) tm1, intro false [] tm2) + | intro top_level args (IConst (name as (s, _), T, T_args)) = + (case proxify_const s of + SOME proxy_base => + if top_level orelse is_type_enc_higher_order type_enc then + case (top_level, s) of + (_, "c_False") => IConst (`I tptp_false, T, []) + | (_, "c_True") => IConst (`I tptp_true, T, []) + | (false, "c_Not") => IConst (`I tptp_not, T, []) + | (false, "c_conj") => IConst (`I tptp_and, T, []) + | (false, "c_disj") => IConst (`I tptp_or, T, []) + | (false, "c_implies") => IConst (`I tptp_implies, T, []) + | (false, "c_All") => tweak_ho_quant tptp_ho_forall T args + | (false, "c_Ex") => tweak_ho_quant tptp_ho_exists T args + | (false, s) => + if is_tptp_equal s andalso length args = 2 then + IConst (`I tptp_equal, T, []) + else + (* Use a proxy even for partially applied THF0 equality, + because the LEO-II and Satallax parsers complain about not + being able to infer the type of "=". *) + IConst (proxy_base |>> prefix const_prefix, T, T_args) + | _ => IConst (name, T, []) + else + IConst (proxy_base |>> prefix const_prefix, T, T_args) + | NONE => if s = tptp_choice then tweak_ho_quant tptp_choice T args + else IConst (name, T, T_args)) + | intro _ _ (IAbs (bound, tm)) = IAbs (bound, intro false [] tm) + | intro _ _ tm = tm + in intro true [] end + +fun mangle_type_args_in_iterm format type_enc = + if polymorphism_of_type_enc type_enc = Mangled_Monomorphic then + let + fun mangle (IApp (tm1, tm2)) = IApp (mangle tm1, mangle tm2) + | mangle (tm as IConst (_, _, [])) = tm + | mangle (tm as IConst (name as (s, _), T, T_args)) = + (case unprefix_and_unascii const_prefix s of + NONE => tm + | SOME s'' => + case type_arg_policy [] type_enc (invert_const s'') of + Mangled_Type_Args => + IConst (mangled_const_name format type_enc T_args name, T, []) + | _ => tm) + | mangle (IAbs (bound, tm)) = IAbs (bound, mangle tm) + | mangle tm = tm + in mangle end + else + I + +fun chop_fun 0 T = ([], T) + | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) = + chop_fun (n - 1) ran_T |>> cons dom_T + | chop_fun _ T = ([], T) + +fun filter_const_type_args _ _ _ [] = [] + | filter_const_type_args thy s ary T_args = + let + val U = robust_const_type thy s + val arg_U_vars = fold Term.add_tvarsT (U |> chop_fun ary |> fst) [] + val U_args = (s, U) |> robust_const_typargs thy + in + U_args ~~ T_args + |> map (fn (U, T) => + if member (op =) arg_U_vars (dest_TVar U) then dummyT else T) + end + handle TYPE _ => T_args + +fun filter_type_args_in_iterm thy monom_constrs type_enc = + let + fun filt ary (IApp (tm1, tm2)) = IApp (filt (ary + 1) tm1, filt 0 tm2) + | filt _ (tm as IConst (_, _, [])) = tm + | filt ary (IConst (name as (s, _), T, T_args)) = + (case unprefix_and_unascii const_prefix s of + NONE => + (name, + if level_of_type_enc type_enc = No_Types orelse s = tptp_choice then + [] + else + T_args) + | SOME s'' => + let + val s'' = invert_const s'' + fun filter_T_args false = T_args + | filter_T_args true = filter_const_type_args thy s'' ary T_args + in + case type_arg_policy monom_constrs type_enc s'' of + Explicit_Type_Args infer_from_term_args => + (name, filter_T_args infer_from_term_args) + | No_Type_Args => (name, []) + | Mangled_Type_Args => raise Fail "unexpected (un)mangled symbol" + end) + |> (fn (name, T_args) => IConst (name, T, T_args)) + | filt _ (IAbs (bound, tm)) = IAbs (bound, filt 0 tm) + | filt _ tm = tm + in filt 0 end + +fun iformula_from_prop ctxt format type_enc eq_as_iff = + let + val thy = Proof_Context.theory_of ctxt + fun do_term bs t atomic_Ts = + iterm_from_term thy format bs (Envir.eta_contract t) + |>> (introduce_proxies_in_iterm type_enc + #> mangle_type_args_in_iterm format type_enc + #> AAtom) + ||> union (op =) atomic_Ts + fun do_quant bs q pos s T t' = + let + val s = singleton (Name.variant_list (map fst bs)) s + val universal = Option.map (q = AExists ? not) pos + val name = + s |> `(case universal of + SOME true => make_all_bound_var + | SOME false => make_exist_bound_var + | NONE => make_bound_var) + in + do_formula ((s, (name, T)) :: bs) pos t' + #>> mk_aquant q [(name, SOME T)] + ##> union (op =) (atomic_types_of T) + end + and do_conn bs c pos1 t1 pos2 t2 = + do_formula bs pos1 t1 ##>> do_formula bs pos2 t2 #>> uncurry (mk_aconn c) + and do_formula bs pos t = + case t of + @{const Trueprop} $ t1 => do_formula bs pos t1 + | @{const Not} $ t1 => do_formula bs (Option.map not pos) t1 #>> mk_anot + | Const (@{const_name All}, _) $ Abs (s, T, t') => + do_quant bs AForall pos s T t' + | (t0 as Const (@{const_name All}, _)) $ t1 => + do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1) + | Const (@{const_name Ex}, _) $ Abs (s, T, t') => + do_quant bs AExists pos s T t' + | (t0 as Const (@{const_name Ex}, _)) $ t1 => + do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1) + | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd pos t1 pos t2 + | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr pos t1 pos t2 + | @{const HOL.implies} $ t1 $ t2 => + do_conn bs AImplies (Option.map not pos) t1 pos t2 + | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 => + if eq_as_iff then do_conn bs AIff NONE t1 NONE t2 else do_term bs t + | _ => do_term bs t + in do_formula [] end + +fun presimplify_term ctxt t = + t |> exists_Const (member (op =) Meson.presimplified_consts o fst) t + ? (Skip_Proof.make_thm (Proof_Context.theory_of ctxt) + #> Meson.presimplify + #> prop_of) + +fun concealed_bound_name j = atp_weak_prefix ^ string_of_int j +fun conceal_bounds Ts t = + subst_bounds (map (Free o apfst concealed_bound_name) + (0 upto length Ts - 1 ~~ Ts), t) +fun reveal_bounds Ts = + subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j)) + (0 upto length Ts - 1 ~~ Ts)) + +fun is_fun_equality (@{const_name HOL.eq}, + Type (_, [Type (@{type_name fun}, _), _])) = true + | is_fun_equality _ = false + +fun extensionalize_term ctxt t = + if exists_Const is_fun_equality t then + let val thy = Proof_Context.theory_of ctxt in + t |> cterm_of thy |> Meson.extensionalize_conv ctxt + |> prop_of |> Logic.dest_equals |> snd + end + else + t + +fun simple_translate_lambdas do_lambdas ctxt t = + let val thy = Proof_Context.theory_of ctxt in + if Meson.is_fol_term thy t then + t + else + let + fun trans Ts t = + case t of + @{const Not} $ t1 => @{const Not} $ trans Ts t1 + | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') => + t0 $ Abs (s, T, trans (T :: Ts) t') + | (t0 as Const (@{const_name All}, _)) $ t1 => + trans Ts (t0 $ eta_expand Ts t1 1) + | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') => + t0 $ Abs (s, T, trans (T :: Ts) t') + | (t0 as Const (@{const_name Ex}, _)) $ t1 => + trans Ts (t0 $ eta_expand Ts t1 1) + | (t0 as @{const HOL.conj}) $ t1 $ t2 => + t0 $ trans Ts t1 $ trans Ts t2 + | (t0 as @{const HOL.disj}) $ t1 $ t2 => + t0 $ trans Ts t1 $ trans Ts t2 + | (t0 as @{const HOL.implies}) $ t1 $ t2 => + t0 $ trans Ts t1 $ trans Ts t2 + | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _]))) + $ t1 $ t2 => + t0 $ trans Ts t1 $ trans Ts t2 + | _ => + if not (exists_subterm (fn Abs _ => true | _ => false) t) then t + else t |> Envir.eta_contract |> do_lambdas ctxt Ts + val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single + in t |> trans [] |> singleton (Variable.export_terms ctxt' ctxt) end + end + +fun do_cheaply_conceal_lambdas Ts (t1 $ t2) = + do_cheaply_conceal_lambdas Ts t1 + $ do_cheaply_conceal_lambdas Ts t2 + | do_cheaply_conceal_lambdas Ts (Abs (_, T, t)) = + Const (lam_lifted_poly_prefix ^ serial_string (), + T --> fastype_of1 (T :: Ts, t)) + | do_cheaply_conceal_lambdas _ t = t + +fun do_introduce_combinators ctxt Ts t = + let val thy = Proof_Context.theory_of ctxt in + t |> conceal_bounds Ts + |> cterm_of thy + |> Meson_Clausify.introduce_combinators_in_cterm + |> prop_of |> Logic.dest_equals |> snd + |> reveal_bounds Ts + end + (* A type variable of sort "{}" will make abstraction fail. *) + handle THM _ => t |> do_cheaply_conceal_lambdas Ts +val introduce_combinators = simple_translate_lambdas do_introduce_combinators + +fun preprocess_abstractions_in_terms trans_lams facts = + let + val (facts, lambda_ts) = + facts |> map (snd o snd) |> trans_lams + |>> map2 (fn (name, (kind, _)) => fn t => (name, (kind, t))) facts + val lam_facts = + map2 (fn t => fn j => + ((lam_fact_prefix ^ Int.toString j, Helper), (Axiom, t))) + lambda_ts (1 upto length lambda_ts) + in (facts, lam_facts) end + +(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the + same in Sledgehammer to prevent the discovery of unreplayable proofs. *) +fun freeze_term t = + let + fun freeze (t $ u) = freeze t $ freeze u + | freeze (Abs (s, T, t)) = Abs (s, T, freeze t) + | freeze (Var ((s, i), T)) = + Free (atp_weak_prefix ^ s ^ "_" ^ string_of_int i, T) + | freeze t = t + in t |> exists_subterm is_Var t ? freeze end + +fun presimp_prop ctxt role t = + (let + val thy = Proof_Context.theory_of ctxt + val t = t |> Envir.beta_eta_contract + |> transform_elim_prop + |> Object_Logic.atomize_term thy + val need_trueprop = (fastype_of t = @{typ bool}) + in + t |> need_trueprop ? HOLogic.mk_Trueprop + |> extensionalize_term ctxt + |> presimplify_term ctxt + |> HOLogic.dest_Trueprop + end + handle TERM _ => if role = Conjecture then @{term False} else @{term True}) + |> pair role + +fun make_formula ctxt format type_enc eq_as_iff name loc kind t = + let + val (iformula, atomic_Ts) = + iformula_from_prop ctxt format type_enc eq_as_iff + (SOME (kind <> Conjecture)) t [] + |>> close_iformula_universally + in + {name = name, locality = loc, kind = kind, iformula = iformula, + atomic_types = atomic_Ts} + end + +fun make_fact ctxt format type_enc eq_as_iff ((name, loc), t) = + case t |> make_formula ctxt format type_enc (eq_as_iff andalso format <> CNF) + name loc Axiom of + formula as {iformula = AAtom (IConst ((s, _), _, _)), ...} => + if s = tptp_true then NONE else SOME formula + | formula => SOME formula + +fun s_not_trueprop (@{const Trueprop} $ t) = @{const Trueprop} $ s_not t + | s_not_trueprop t = + if fastype_of t = @{typ bool} then s_not t else @{prop False} (* too meta *) + +fun make_conjecture ctxt format type_enc = + map (fn ((name, loc), (kind, t)) => + t |> kind = Conjecture ? s_not_trueprop + |> make_formula ctxt format type_enc (format <> CNF) name loc kind) + +(** Finite and infinite type inference **) + +fun tvar_footprint thy s ary = + (case unprefix_and_unascii const_prefix s of + SOME s => + s |> invert_const |> robust_const_type thy |> chop_fun ary |> fst + |> map (fn T => Term.add_tvarsT T [] |> map fst) + | NONE => []) + handle TYPE _ => [] + +fun ghost_type_args thy s ary = + if is_tptp_equal s then + 0 upto ary - 1 + else + let + val footprint = tvar_footprint thy s ary + val eq = (s = @{const_name HOL.eq}) + fun ghosts _ [] = [] + | ghosts seen ((i, tvars) :: args) = + ghosts (union (op =) seen tvars) args + |> (eq orelse exists (fn tvar => not (member (op =) seen tvar)) tvars) + ? cons i + in + if forall null footprint then + [] + else + 0 upto length footprint - 1 ~~ footprint + |> sort (rev_order o list_ord Term_Ord.indexname_ord o pairself snd) + |> ghosts [] + end + +type monotonicity_info = + {maybe_finite_Ts : typ list, + surely_finite_Ts : typ list, + maybe_infinite_Ts : typ list, + surely_infinite_Ts : typ list, + maybe_nonmono_Ts : typ list} + +(* These types witness that the type classes they belong to allow infinite + models and hence that any types with these type classes is monotonic. *) +val known_infinite_types = + [@{typ nat}, HOLogic.intT, HOLogic.realT, @{typ "nat => bool"}] + +fun is_type_kind_of_surely_infinite ctxt strictness cached_Ts T = + strictness <> Strict andalso is_type_surely_infinite ctxt true cached_Ts T + +(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are + dangerous because their "exhaust" properties can easily lead to unsound ATP + proofs. On the other hand, all HOL infinite types can be given the same + models in first-order logic (via Löwenheim-Skolem). *) + +fun should_encode_type _ (_ : monotonicity_info) All_Types _ = true + | should_encode_type ctxt {maybe_finite_Ts, surely_infinite_Ts, + maybe_nonmono_Ts, ...} + (Noninf_Nonmono_Types (strictness, grain)) T = + grain = Ghost_Type_Arg_Vars orelse + (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso + not (exists (type_instance ctxt T) surely_infinite_Ts orelse + (not (member (type_equiv ctxt) maybe_finite_Ts T) andalso + is_type_kind_of_surely_infinite ctxt strictness surely_infinite_Ts + T))) + | should_encode_type ctxt {surely_finite_Ts, maybe_infinite_Ts, + maybe_nonmono_Ts, ...} + (Fin_Nonmono_Types grain) T = + grain = Ghost_Type_Arg_Vars orelse + (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso + (exists (type_generalization ctxt T) surely_finite_Ts orelse + (not (member (type_equiv ctxt) maybe_infinite_Ts T) andalso + is_type_surely_finite ctxt T))) + | should_encode_type _ _ _ _ = false + +fun should_guard_type ctxt mono (Guards (_, level)) should_guard_var T = + should_guard_var () andalso should_encode_type ctxt mono level T + | should_guard_type _ _ _ _ _ = false + +fun is_maybe_universal_var (IConst ((s, _), _, _)) = + String.isPrefix bound_var_prefix s orelse + String.isPrefix all_bound_var_prefix s + | is_maybe_universal_var (IVar _) = true + | is_maybe_universal_var _ = false + +datatype site = + Top_Level of bool option | + Eq_Arg of bool option | + Elsewhere + +fun should_tag_with_type _ _ _ (Top_Level _) _ _ = false + | should_tag_with_type ctxt mono (Tags (_, level)) site u T = + if granularity_of_type_level level = All_Vars then + should_encode_type ctxt mono level T + else + (case (site, is_maybe_universal_var u) of + (Eq_Arg _, true) => should_encode_type ctxt mono level T + | _ => false) + | should_tag_with_type _ _ _ _ _ _ = false + +fun fused_type ctxt mono level = + let + val should_encode = should_encode_type ctxt mono level + fun fuse 0 T = if should_encode T then T else fused_infinite_type + | fuse ary (Type (@{type_name fun}, [T1, T2])) = + fuse 0 T1 --> fuse (ary - 1) T2 + | fuse _ _ = raise Fail "expected function type" + in fuse end + +(** predicators and application operators **) + +type sym_info = + {pred_sym : bool, min_ary : int, max_ary : int, types : typ list, + in_conj : bool} + +fun default_sym_tab_entries type_enc = + (make_fixed_const NONE @{const_name undefined}, + {pred_sym = false, min_ary = 0, max_ary = 0, types = [], + in_conj = false}) :: + ([tptp_false, tptp_true] + |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = [], + in_conj = false})) @ + ([tptp_equal, tptp_old_equal] + |> map (rpair {pred_sym = true, min_ary = 2, max_ary = 2, types = [], + in_conj = false})) + |> not (is_type_enc_higher_order type_enc) + ? cons (prefixed_predicator_name, + {pred_sym = true, min_ary = 1, max_ary = 1, types = [], + in_conj = false}) + +fun sym_table_for_facts ctxt type_enc explicit_apply conjs facts = + let + fun consider_var_ary const_T var_T max_ary = + let + fun iter ary T = + if ary = max_ary orelse type_instance ctxt var_T T orelse + type_instance ctxt T var_T then + ary + else + iter (ary + 1) (range_type T) + in iter 0 const_T end + fun add_universal_var T (accum as ((bool_vars, fun_var_Ts), sym_tab)) = + if explicit_apply = NONE andalso + (can dest_funT T orelse T = @{typ bool}) then + let + val bool_vars' = bool_vars orelse body_type T = @{typ bool} + fun repair_min_ary {pred_sym, min_ary, max_ary, types, in_conj} = + {pred_sym = pred_sym andalso not bool_vars', + min_ary = fold (fn T' => consider_var_ary T' T) types min_ary, + max_ary = max_ary, types = types, in_conj = in_conj} + val fun_var_Ts' = + fun_var_Ts |> can dest_funT T ? insert_type ctxt I T + in + if bool_vars' = bool_vars andalso + pointer_eq (fun_var_Ts', fun_var_Ts) then + accum + else + ((bool_vars', fun_var_Ts'), Symtab.map (K repair_min_ary) sym_tab) + end + else + accum + fun add_fact_syms conj_fact = + let + fun add_iterm_syms top_level tm + (accum as ((bool_vars, fun_var_Ts), sym_tab)) = + let val (head, args) = strip_iterm_comb tm in + (case head of + IConst ((s, _), T, _) => + if String.isPrefix bound_var_prefix s orelse + String.isPrefix all_bound_var_prefix s then + add_universal_var T accum + else if String.isPrefix exist_bound_var_prefix s then + accum + else + let val ary = length args in + ((bool_vars, fun_var_Ts), + case Symtab.lookup sym_tab s of + SOME {pred_sym, min_ary, max_ary, types, in_conj} => + let + val pred_sym = + pred_sym andalso top_level andalso not bool_vars + val types' = types |> insert_type ctxt I T + val in_conj = in_conj orelse conj_fact + val min_ary = + if is_some explicit_apply orelse + pointer_eq (types', types) then + min_ary + else + fold (consider_var_ary T) fun_var_Ts min_ary + in + Symtab.update (s, {pred_sym = pred_sym, + min_ary = Int.min (ary, min_ary), + max_ary = Int.max (ary, max_ary), + types = types', in_conj = in_conj}) + sym_tab + end + | NONE => + let + val pred_sym = top_level andalso not bool_vars + val min_ary = + case explicit_apply of + SOME true => 0 + | SOME false => ary + | NONE => fold (consider_var_ary T) fun_var_Ts ary + in + Symtab.update_new (s, + {pred_sym = pred_sym, min_ary = min_ary, + max_ary = ary, types = [T], in_conj = conj_fact}) + sym_tab + end) + end + | IVar (_, T) => add_universal_var T accum + | IAbs ((_, T), tm) => + accum |> add_universal_var T |> add_iterm_syms false tm + | _ => accum) + |> fold (add_iterm_syms false) args + end + in K (add_iterm_syms true) |> formula_fold NONE |> fact_lift end + in + ((false, []), Symtab.empty) + |> fold (add_fact_syms true) conjs + |> fold (add_fact_syms false) facts + |> snd + |> fold Symtab.update (default_sym_tab_entries type_enc) + end + +fun min_ary_of sym_tab s = + case Symtab.lookup sym_tab s of + SOME ({min_ary, ...} : sym_info) => min_ary + | NONE => + case unprefix_and_unascii const_prefix s of + SOME s => + let val s = s |> unmangled_const_name |> invert_const in + if s = predicator_name then 1 + else if s = app_op_name then 2 + else if s = type_guard_name then 1 + else 0 + end + | NONE => 0 + +(* True if the constant ever appears outside of the top-level position in + literals, or if it appears with different arities (e.g., because of different + type instantiations). If false, the constant always receives all of its + arguments and is used as a predicate. *) +fun is_pred_sym sym_tab s = + case Symtab.lookup sym_tab s of + SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) => + pred_sym andalso min_ary = max_ary + | NONE => false + +val app_op = `(make_fixed_const NONE) app_op_name +val predicator_combconst = + IConst (`(make_fixed_const NONE) predicator_name, @{typ "bool => bool"}, []) + +fun list_app head args = fold (curry (IApp o swap)) args head +fun predicator tm = IApp (predicator_combconst, tm) + +fun firstorderize_fact thy monom_constrs format type_enc sym_tab = + let + fun do_app arg head = + let + val head_T = ityp_of head + val (arg_T, res_T) = dest_funT head_T + val app = + IConst (app_op, head_T --> head_T, [arg_T, res_T]) + |> mangle_type_args_in_iterm format type_enc + in list_app app [head, arg] end + fun list_app_ops head args = fold do_app args head + fun introduce_app_ops tm = + case strip_iterm_comb tm of + (head as IConst ((s, _), _, _), args) => + args |> map introduce_app_ops + |> chop (min_ary_of sym_tab s) + |>> list_app head + |-> list_app_ops + | (head, args) => list_app_ops head (map introduce_app_ops args) + fun introduce_predicators tm = + case strip_iterm_comb tm of + (IConst ((s, _), _, _), _) => + if is_pred_sym sym_tab s then tm else predicator tm + | _ => predicator tm + val do_iterm = + not (is_type_enc_higher_order type_enc) + ? (introduce_app_ops #> introduce_predicators) + #> filter_type_args_in_iterm thy monom_constrs type_enc + in update_iformula (formula_map do_iterm) end + +(** Helper facts **) + +val not_ffalse = @{lemma "~ fFalse" by (unfold fFalse_def) fast} +val ftrue = @{lemma "fTrue" by (unfold fTrue_def) fast} + +(* The Boolean indicates that a fairly sound type encoding is needed. *) +val helper_table = + [(("COMBI", false), @{thms Meson.COMBI_def}), + (("COMBK", false), @{thms Meson.COMBK_def}), + (("COMBB", false), @{thms Meson.COMBB_def}), + (("COMBC", false), @{thms Meson.COMBC_def}), + (("COMBS", false), @{thms Meson.COMBS_def}), + ((predicator_name, false), [not_ffalse, ftrue]), + (("fFalse", false), [not_ffalse]), + (("fFalse", true), @{thms True_or_False}), + (("fTrue", false), [ftrue]), + (("fTrue", true), @{thms True_or_False}), + (("fNot", false), + @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1] + fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]}), + (("fconj", false), + @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q" + by (unfold fconj_def) fast+}), + (("fdisj", false), + @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q" + by (unfold fdisj_def) fast+}), + (("fimplies", false), + @{lemma "P | fimplies P Q" "~ Q | fimplies P Q" "~ fimplies P Q | ~ P | Q" + by (unfold fimplies_def) fast+}), + (("fequal", true), + (* This is a lie: Higher-order equality doesn't need a sound type encoding. + However, this is done so for backward compatibility: Including the + equality helpers by default in Metis breaks a few existing proofs. *) + @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1] + fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]}), + (* Partial characterization of "fAll" and "fEx". A complete characterization + would require the axiom of choice for replay with Metis. *) + (("fAll", false), [@{lemma "~ fAll P | P x" by (auto simp: fAll_def)}]), + (("fEx", false), [@{lemma "~ P x | fEx P" by (auto simp: fEx_def)}]), + (("If", true), @{thms if_True if_False True_or_False})] + |> map (apsnd (map zero_var_indexes)) + +fun atype_of_type_vars (Simple_Types (_, Polymorphic, _)) = SOME atype_of_types + | atype_of_type_vars _ = NONE + +fun bound_tvars type_enc sorts Ts = + (sorts ? mk_ahorn (formulas_for_types type_enc add_sorts_on_tvar Ts)) + #> mk_aquant AForall + (map_filter (fn TVar (x as (s, _), _) => + SOME ((make_schematic_type_var x, s), + atype_of_type_vars type_enc) + | _ => NONE) Ts) + +fun eq_formula type_enc atomic_Ts pred_sym tm1 tm2 = + (if pred_sym then AConn (AIff, [AAtom tm1, AAtom tm2]) + else AAtom (ATerm (`I tptp_equal, [tm1, tm2]))) + |> close_formula_universally + |> bound_tvars type_enc true atomic_Ts + +val type_tag = `(make_fixed_const NONE) type_tag_name + +fun type_tag_idempotence_fact format type_enc = + let + fun var s = ATerm (`I s, []) + fun tag tm = ATerm (type_tag, [var "A", tm]) + val tagged_var = tag (var "X") + in + Formula (type_tag_idempotence_helper_name, Axiom, + eq_formula type_enc [] false (tag tagged_var) tagged_var, + isabelle_info format simpN, NONE) + end + +fun should_specialize_helper type_enc t = + polymorphism_of_type_enc type_enc <> Polymorphic andalso + level_of_type_enc type_enc <> No_Types andalso + not (null (Term.hidden_polymorphism t)) + +fun helper_facts_for_sym ctxt format type_enc (s, {types, ...} : sym_info) = + case unprefix_and_unascii const_prefix s of + SOME mangled_s => + let + val thy = Proof_Context.theory_of ctxt + val unmangled_s = mangled_s |> unmangled_const_name + fun dub needs_fairly_sound j k = + (unmangled_s ^ "_" ^ string_of_int j ^ "_" ^ string_of_int k ^ + (if mangled_s = unmangled_s then "" else "_" ^ ascii_of mangled_s) ^ + (if needs_fairly_sound then typed_helper_suffix + else untyped_helper_suffix), + Helper) + fun dub_and_inst needs_fairly_sound (th, j) = + let val t = prop_of th in + if should_specialize_helper type_enc t then + map (fn T => specialize_type thy (invert_const unmangled_s, T) t) + types + else + [t] + end + |> map (fn (k, t) => (dub needs_fairly_sound j k, t)) o tag_list 1 + val make_facts = map_filter (make_fact ctxt format type_enc false) + val fairly_sound = is_type_enc_fairly_sound type_enc + in + helper_table + |> maps (fn ((helper_s, needs_fairly_sound), ths) => + if helper_s <> unmangled_s orelse + (needs_fairly_sound andalso not fairly_sound) then + [] + else + ths ~~ (1 upto length ths) + |> maps (dub_and_inst needs_fairly_sound) + |> make_facts) + end + | NONE => [] +fun helper_facts_for_sym_table ctxt format type_enc sym_tab = + Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_enc) sym_tab + [] + +(***************************************************************) +(* Type Classes Present in the Axiom or Conjecture Clauses *) +(***************************************************************) + +fun set_insert (x, s) = Symtab.update (x, ()) s + +fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts) + +(* Remove this trivial type class (FIXME: similar code elsewhere) *) +fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset + +fun classes_of_terms get_Ts = + map (map snd o get_Ts) + #> List.foldl add_classes Symtab.empty + #> delete_type #> Symtab.keys + +val tfree_classes_of_terms = classes_of_terms Misc_Legacy.term_tfrees +val tvar_classes_of_terms = classes_of_terms Misc_Legacy.term_tvars + +fun fold_type_constrs f (Type (s, Ts)) x = + fold (fold_type_constrs f) Ts (f (s, x)) + | fold_type_constrs _ _ x = x + +(* Type constructors used to instantiate overloaded constants are the only ones + needed. *) +fun add_type_constrs_in_term thy = + let + fun add (Const (@{const_name Meson.skolem}, _) $ _) = I + | add (t $ u) = add t #> add u + | add (Const x) = + x |> robust_const_typargs thy |> fold (fold_type_constrs set_insert) + | add (Abs (_, _, u)) = add u + | add _ = I + in add end + +fun type_constrs_of_terms thy ts = + Symtab.keys (fold (add_type_constrs_in_term thy) ts Symtab.empty) + +fun extract_lambda_def (Const (@{const_name HOL.eq}, _) $ t $ u) = + let val (head, args) = strip_comb t in + (head |> dest_Const |> fst, + fold_rev (fn t as Var ((s, _), T) => + (fn u => Abs (s, T, abstract_over (t, u))) + | _ => raise Fail "expected Var") args u) + end + | extract_lambda_def _ = raise Fail "malformed lifted lambda" + +fun trans_lams_from_string ctxt type_enc lam_trans = + if lam_trans = no_lamsN then + rpair [] + else if lam_trans = hide_lamsN then + lift_lams ctxt type_enc ##> K [] + else if lam_trans = lam_liftingN then + lift_lams ctxt type_enc + else if lam_trans = combinatorsN then + map (introduce_combinators ctxt) #> rpair [] + else if lam_trans = hybrid_lamsN then + lift_lams_part_1 ctxt type_enc + ##> maps (fn t => [t, introduce_combinators ctxt (intentionalize_def t)]) + #> lift_lams_part_2 + else if lam_trans = keep_lamsN then + map (Envir.eta_contract) #> rpair [] + else + error ("Unknown lambda translation scheme: " ^ quote lam_trans ^ ".") + +fun translate_formulas ctxt format prem_kind type_enc lam_trans presimp hyp_ts + concl_t facts = + let + val thy = Proof_Context.theory_of ctxt + val trans_lams = trans_lams_from_string ctxt type_enc lam_trans + val fact_ts = facts |> map snd + (* Remove existing facts from the conjecture, as this can dramatically + boost an ATP's performance (for some reason). *) + val hyp_ts = + hyp_ts + |> map (fn t => if member (op aconv) fact_ts t then @{prop True} else t) + val facts = facts |> map (apsnd (pair Axiom)) + val conjs = + map (pair prem_kind) hyp_ts @ [(Conjecture, s_not_trueprop concl_t)] + |> map (apsnd freeze_term) + |> map2 (pair o rpair Local o string_of_int) (0 upto length hyp_ts) + val ((conjs, facts), lam_facts) = + (conjs, facts) + |> presimp ? pairself (map (apsnd (uncurry (presimp_prop ctxt)))) + |> (if lam_trans = no_lamsN then + rpair [] + else + op @ + #> preprocess_abstractions_in_terms trans_lams + #>> chop (length conjs)) + val conjs = conjs |> make_conjecture ctxt format type_enc + val (fact_names, facts) = + facts + |> map_filter (fn (name, (_, t)) => + make_fact ctxt format type_enc true (name, t) + |> Option.map (pair name)) + |> ListPair.unzip + val lifted = lam_facts |> map (extract_lambda_def o snd o snd) + val lam_facts = + lam_facts |> map_filter (make_fact ctxt format type_enc true o apsnd snd) + val all_ts = concl_t :: hyp_ts @ fact_ts + val subs = tfree_classes_of_terms all_ts + val supers = tvar_classes_of_terms all_ts + val tycons = type_constrs_of_terms thy all_ts + val (supers, arity_clauses) = + if level_of_type_enc type_enc = No_Types then ([], []) + else make_arity_clauses thy tycons supers + val class_rel_clauses = make_class_rel_clauses thy subs supers + in + (fact_names |> map single, union (op =) subs supers, conjs, + facts @ lam_facts, class_rel_clauses, arity_clauses, lifted) + end + +val type_guard = `(make_fixed_const NONE) type_guard_name + +fun type_guard_iterm format type_enc T tm = + IApp (IConst (type_guard, T --> @{typ bool}, [T]) + |> mangle_type_args_in_iterm format type_enc, tm) + +fun is_var_positively_naked_in_term _ (SOME false) _ accum = accum + | is_var_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum = + accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, []))) + | is_var_positively_naked_in_term _ _ _ _ = true + +fun is_var_ghost_type_arg_in_term thy polym_constrs name pos tm accum = + is_var_positively_naked_in_term name pos tm accum orelse + let + val var = ATerm (name, []) + fun is_nasty_in_term (ATerm (_, [])) = false + | is_nasty_in_term (ATerm ((s, _), tms)) = + let + val ary = length tms + val polym_constr = member (op =) polym_constrs s + val ghosts = ghost_type_args thy s ary + in + exists (fn (j, tm) => + if polym_constr then + member (op =) ghosts j andalso + (tm = var orelse is_nasty_in_term tm) + else + tm = var andalso member (op =) ghosts j) + (0 upto ary - 1 ~~ tms) + orelse (not polym_constr andalso exists is_nasty_in_term tms) + end + | is_nasty_in_term _ = true + in is_nasty_in_term tm end + +fun should_guard_var_in_formula thy polym_constrs level pos phi (SOME true) + name = + (case granularity_of_type_level level of + All_Vars => true + | Positively_Naked_Vars => + formula_fold pos (is_var_positively_naked_in_term name) phi false + | Ghost_Type_Arg_Vars => + formula_fold pos (is_var_ghost_type_arg_in_term thy polym_constrs name) + phi false) + | should_guard_var_in_formula _ _ _ _ _ _ _ = true + +fun always_guard_var_in_formula _ _ _ _ _ _ _ = true + +fun should_generate_tag_bound_decl _ _ _ (SOME true) _ = false + | should_generate_tag_bound_decl ctxt mono (Tags (_, level)) _ T = + granularity_of_type_level level <> All_Vars andalso + should_encode_type ctxt mono level T + | should_generate_tag_bound_decl _ _ _ _ _ = false + +fun mk_aterm format type_enc name T_args args = + ATerm (name, map_filter (ho_term_for_type_arg format type_enc) T_args @ args) + +fun tag_with_type ctxt format mono type_enc pos T tm = + IConst (type_tag, T --> T, [T]) + |> mangle_type_args_in_iterm format type_enc + |> ho_term_from_iterm ctxt format mono type_enc pos + |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm]) + | _ => raise Fail "unexpected lambda-abstraction") +and ho_term_from_iterm ctxt format mono type_enc = + let + fun term site u = + let + val (head, args) = strip_iterm_comb u + val pos = + case site of + Top_Level pos => pos + | Eq_Arg pos => pos + | _ => NONE + val t = + case head of + IConst (name as (s, _), _, T_args) => + let + val arg_site = if is_tptp_equal s then Eq_Arg pos else Elsewhere + in + map (term arg_site) args |> mk_aterm format type_enc name T_args + end + | IVar (name, _) => + map (term Elsewhere) args |> mk_aterm format type_enc name [] + | IAbs ((name, T), tm) => + AAbs ((name, ho_type_from_typ format type_enc true 0 T), + term Elsewhere tm) + | IApp _ => raise Fail "impossible \"IApp\"" + val T = ityp_of u + in + if should_tag_with_type ctxt mono type_enc site u T then + tag_with_type ctxt format mono type_enc pos T t + else + t + end + in term o Top_Level end +and formula_from_iformula ctxt polym_constrs format mono type_enc + should_guard_var = + let + val thy = Proof_Context.theory_of ctxt + val level = level_of_type_enc type_enc + val do_term = ho_term_from_iterm ctxt format mono type_enc + val do_bound_type = + case type_enc of + Simple_Types _ => fused_type ctxt mono level 0 + #> ho_type_from_typ format type_enc false 0 #> SOME + | _ => K NONE + fun do_out_of_bound_type pos phi universal (name, T) = + if should_guard_type ctxt mono type_enc + (fn () => should_guard_var thy polym_constrs level pos phi + universal name) T then + IVar (name, T) + |> type_guard_iterm format type_enc T + |> do_term pos |> AAtom |> SOME + else if should_generate_tag_bound_decl ctxt mono type_enc universal T then + let + val var = ATerm (name, []) + val tagged_var = tag_with_type ctxt format mono type_enc pos T var + in SOME (AAtom (ATerm (`I tptp_equal, [tagged_var, var]))) end + else + NONE + fun do_formula pos (AQuant (q, xs, phi)) = + let + val phi = phi |> do_formula pos + val universal = Option.map (q = AExists ? not) pos + in + AQuant (q, xs |> map (apsnd (fn NONE => NONE + | SOME T => do_bound_type T)), + (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd)) + (map_filter + (fn (_, NONE) => NONE + | (s, SOME T) => + do_out_of_bound_type pos phi universal (s, T)) + xs) + phi) + end + | do_formula pos (AConn conn) = aconn_map pos do_formula conn + | do_formula pos (AAtom tm) = AAtom (do_term pos tm) + in do_formula end + +(* Each fact is given a unique fact number to avoid name clashes (e.g., because + of monomorphization). The TPTP explicitly forbids name clashes, and some of + the remote provers might care. *) +fun formula_line_for_fact ctxt polym_constrs format prefix encode freshen pos + mono type_enc (j, {name, locality, kind, iformula, atomic_types}) = + (prefix ^ (if freshen then string_of_int j ^ "_" else "") ^ encode name, kind, + iformula + |> formula_from_iformula ctxt polym_constrs format mono type_enc + should_guard_var_in_formula (if pos then SOME true else NONE) + |> close_formula_universally + |> bound_tvars type_enc true atomic_types, + NONE, + case locality of + Intro => isabelle_info format introN + | Elim => isabelle_info format elimN + | Simp => isabelle_info format simpN + | _ => NONE) + |> Formula + +fun formula_line_for_class_rel_clause format type_enc + ({name, subclass, superclass, ...} : class_rel_clause) = + let val ty_arg = ATerm (tvar_a_name, []) in + Formula (class_rel_clause_prefix ^ ascii_of name, Axiom, + AConn (AImplies, + [type_class_formula type_enc subclass ty_arg, + type_class_formula type_enc superclass ty_arg]) + |> mk_aquant AForall + [(tvar_a_name, atype_of_type_vars type_enc)], + isabelle_info format introN, NONE) + end + +fun formula_from_arity_atom type_enc (class, t, args) = + ATerm (t, map (fn arg => ATerm (arg, [])) args) + |> type_class_formula type_enc class + +fun formula_line_for_arity_clause format type_enc + ({name, prem_atoms, concl_atom} : arity_clause) = + Formula (arity_clause_prefix ^ name, Axiom, + mk_ahorn (map (formula_from_arity_atom type_enc) prem_atoms) + (formula_from_arity_atom type_enc concl_atom) + |> mk_aquant AForall + (map (rpair (atype_of_type_vars type_enc)) (#3 concl_atom)), + isabelle_info format introN, NONE) + +fun formula_line_for_conjecture ctxt polym_constrs format mono type_enc + ({name, kind, iformula, atomic_types, ...} : translated_formula) = + Formula (conjecture_prefix ^ name, kind, + iformula + |> formula_from_iformula ctxt polym_constrs format mono type_enc + should_guard_var_in_formula (SOME false) + |> close_formula_universally + |> bound_tvars type_enc true atomic_types, NONE, NONE) + +fun formula_line_for_free_type j phi = + Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, phi, NONE, NONE) +fun formula_lines_for_free_types type_enc (facts : translated_formula list) = + let + val phis = + fold (union (op =)) (map #atomic_types facts) [] + |> formulas_for_types type_enc add_sorts_on_tfree + in map2 formula_line_for_free_type (0 upto length phis - 1) phis end + +(** Symbol declarations **) + +fun decl_line_for_class order s = + let val name as (s, _) = `make_type_class s in + Decl (sym_decl_prefix ^ s, name, + if order = First_Order then + ATyAbs ([tvar_a_name], + if avoid_first_order_ghost_type_vars then + AFun (a_itself_atype, bool_atype) + else + bool_atype) + else + AFun (atype_of_types, bool_atype)) + end + +fun decl_lines_for_classes type_enc classes = + case type_enc of + Simple_Types (order, Polymorphic, _) => + map (decl_line_for_class order) classes + | _ => [] + +fun sym_decl_table_for_facts ctxt format type_enc sym_tab (conjs, facts) = + let + fun add_iterm_syms tm = + let val (head, args) = strip_iterm_comb tm in + (case head of + IConst ((s, s'), T, T_args) => + let + val (pred_sym, in_conj) = + case Symtab.lookup sym_tab s of + SOME ({pred_sym, in_conj, ...} : sym_info) => + (pred_sym, in_conj) + | NONE => (false, false) + val decl_sym = + (case type_enc of + Guards _ => not pred_sym + | _ => true) andalso + is_tptp_user_symbol s + in + if decl_sym then + Symtab.map_default (s, []) + (insert_type ctxt #3 (s', T_args, T, pred_sym, length args, + in_conj)) + else + I + end + | IAbs (_, tm) => add_iterm_syms tm + | _ => I) + #> fold add_iterm_syms args + end + val add_fact_syms = K add_iterm_syms |> formula_fold NONE |> fact_lift + fun add_formula_var_types (AQuant (_, xs, phi)) = + fold (fn (_, SOME T) => insert_type ctxt I T | _ => I) xs + #> add_formula_var_types phi + | add_formula_var_types (AConn (_, phis)) = + fold add_formula_var_types phis + | add_formula_var_types _ = I + fun var_types () = + if polymorphism_of_type_enc type_enc = Polymorphic then [tvar_a] + else fold (fact_lift add_formula_var_types) (conjs @ facts) [] + fun add_undefined_const T = + let + val (s, s') = + `(make_fixed_const NONE) @{const_name undefined} + |> (case type_arg_policy [] type_enc @{const_name undefined} of + Mangled_Type_Args => mangled_const_name format type_enc [T] + | _ => I) + in + Symtab.map_default (s, []) + (insert_type ctxt #3 (s', [T], T, false, 0, false)) + end + fun add_TYPE_const () = + let val (s, s') = TYPE_name in + Symtab.map_default (s, []) + (insert_type ctxt #3 + (s', [tvar_a], @{typ "'a itself"}, false, 0, false)) + end + in + Symtab.empty + |> is_type_enc_fairly_sound type_enc + ? (fold (fold add_fact_syms) [conjs, facts] + #> (case type_enc of + Simple_Types (First_Order, Polymorphic, _) => + if avoid_first_order_ghost_type_vars then add_TYPE_const () + else I + | Simple_Types _ => I + | _ => fold add_undefined_const (var_types ()))) + end + +(* We add "bool" in case the helper "True_or_False" is included later. *) +fun default_mono level = + {maybe_finite_Ts = [@{typ bool}], + surely_finite_Ts = [@{typ bool}], + maybe_infinite_Ts = known_infinite_types, + surely_infinite_Ts = + case level of + Noninf_Nonmono_Types (Strict, _) => [] + | _ => known_infinite_types, + maybe_nonmono_Ts = [@{typ bool}]} + +(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it + out with monotonicity" paper presented at CADE 2011. *) +fun add_iterm_mononotonicity_info _ _ (SOME false) _ mono = mono + | add_iterm_mononotonicity_info ctxt level _ + (IApp (IApp (IConst ((s, _), Type (_, [T, _]), _), tm1), tm2)) + (mono as {maybe_finite_Ts, surely_finite_Ts, maybe_infinite_Ts, + surely_infinite_Ts, maybe_nonmono_Ts}) = + if is_tptp_equal s andalso exists is_maybe_universal_var [tm1, tm2] then + case level of + Noninf_Nonmono_Types (strictness, _) => + if exists (type_instance ctxt T) surely_infinite_Ts orelse + member (type_equiv ctxt) maybe_finite_Ts T then + mono + else if is_type_kind_of_surely_infinite ctxt strictness + surely_infinite_Ts T then + {maybe_finite_Ts = maybe_finite_Ts, + surely_finite_Ts = surely_finite_Ts, + maybe_infinite_Ts = maybe_infinite_Ts, + surely_infinite_Ts = surely_infinite_Ts |> insert_type ctxt I T, + maybe_nonmono_Ts = maybe_nonmono_Ts} + else + {maybe_finite_Ts = maybe_finite_Ts |> insert (type_equiv ctxt) T, + surely_finite_Ts = surely_finite_Ts, + maybe_infinite_Ts = maybe_infinite_Ts, + surely_infinite_Ts = surely_infinite_Ts, + maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T} + | Fin_Nonmono_Types _ => + if exists (type_instance ctxt T) surely_finite_Ts orelse + member (type_equiv ctxt) maybe_infinite_Ts T then + mono + else if is_type_surely_finite ctxt T then + {maybe_finite_Ts = maybe_finite_Ts, + surely_finite_Ts = surely_finite_Ts |> insert_type ctxt I T, + maybe_infinite_Ts = maybe_infinite_Ts, + surely_infinite_Ts = surely_infinite_Ts, + maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T} + else + {maybe_finite_Ts = maybe_finite_Ts, + surely_finite_Ts = surely_finite_Ts, + maybe_infinite_Ts = maybe_infinite_Ts |> insert (type_equiv ctxt) T, + surely_infinite_Ts = surely_infinite_Ts, + maybe_nonmono_Ts = maybe_nonmono_Ts} + | _ => mono + else + mono + | add_iterm_mononotonicity_info _ _ _ _ mono = mono +fun add_fact_mononotonicity_info ctxt level + ({kind, iformula, ...} : translated_formula) = + formula_fold (SOME (kind <> Conjecture)) + (add_iterm_mononotonicity_info ctxt level) iformula +fun mononotonicity_info_for_facts ctxt type_enc facts = + let val level = level_of_type_enc type_enc in + default_mono level + |> is_type_level_monotonicity_based level + ? fold (add_fact_mononotonicity_info ctxt level) facts + end + +fun add_iformula_monotonic_types ctxt mono type_enc = + let + val level = level_of_type_enc type_enc + val should_encode = should_encode_type ctxt mono level + fun add_type T = not (should_encode T) ? insert_type ctxt I T + fun add_args (IApp (tm1, tm2)) = add_args tm1 #> add_term tm2 + | add_args _ = I + and add_term tm = add_type (ityp_of tm) #> add_args tm + in formula_fold NONE (K add_term) end +fun add_fact_monotonic_types ctxt mono type_enc = + add_iformula_monotonic_types ctxt mono type_enc |> fact_lift +fun monotonic_types_for_facts ctxt mono type_enc facts = + let val level = level_of_type_enc type_enc in + [] |> (polymorphism_of_type_enc type_enc = Polymorphic andalso + is_type_level_monotonicity_based level andalso + granularity_of_type_level level <> Ghost_Type_Arg_Vars) + ? fold (add_fact_monotonic_types ctxt mono type_enc) facts + end + +fun formula_line_for_guards_mono_type ctxt format mono type_enc T = + Formula (guards_sym_formula_prefix ^ + ascii_of (mangled_type format type_enc T), + Axiom, + IConst (`make_bound_var "X", T, []) + |> type_guard_iterm format type_enc T + |> AAtom + |> formula_from_iformula ctxt [] format mono type_enc + always_guard_var_in_formula (SOME true) + |> close_formula_universally + |> bound_tvars type_enc true (atomic_types_of T), + isabelle_info format introN, NONE) + +fun formula_line_for_tags_mono_type ctxt format mono type_enc T = + let val x_var = ATerm (`make_bound_var "X", []) in + Formula (tags_sym_formula_prefix ^ + ascii_of (mangled_type format type_enc T), + Axiom, + eq_formula type_enc (atomic_types_of T) false + (tag_with_type ctxt format mono type_enc NONE T x_var) x_var, + isabelle_info format simpN, NONE) + end + +fun problem_lines_for_mono_types ctxt format mono type_enc Ts = + case type_enc of + Simple_Types _ => [] + | Guards _ => + map (formula_line_for_guards_mono_type ctxt format mono type_enc) Ts + | Tags _ => map (formula_line_for_tags_mono_type ctxt format mono type_enc) Ts + +fun decl_line_for_sym ctxt format mono type_enc s + (s', T_args, T, pred_sym, ary, _) = + let + val thy = Proof_Context.theory_of ctxt + val (T, T_args) = + if null T_args then + (T, []) + else case unprefix_and_unascii const_prefix s of + SOME s' => + let + val s' = s' |> invert_const + val T = s' |> robust_const_type thy + in (T, robust_const_typargs thy (s', T)) end + | NONE => raise Fail "unexpected type arguments" + in + Decl (sym_decl_prefix ^ s, (s, s'), + T |> fused_type ctxt mono (level_of_type_enc type_enc) ary + |> ho_type_from_typ format type_enc pred_sym ary + |> not (null T_args) + ? curry ATyAbs (map (tvar_name o fst o dest_TVar) T_args)) + end + +fun formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono type_enc n s + j (s', T_args, T, _, ary, in_conj) = + let + val thy = Proof_Context.theory_of ctxt + val (kind, maybe_negate) = + if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot) + else (Axiom, I) + val (arg_Ts, res_T) = chop_fun ary T + val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int) + val bounds = + bound_names ~~ arg_Ts |> map (fn (name, T) => IConst (name, T, [])) + val bound_Ts = + if exists (curry (op =) dummyT) T_args then + case level_of_type_enc type_enc of + All_Types => map SOME arg_Ts + | level => + if granularity_of_type_level level = Ghost_Type_Arg_Vars then + let val ghosts = ghost_type_args thy s ary in + map2 (fn j => if member (op =) ghosts j then SOME else K NONE) + (0 upto ary - 1) arg_Ts + end + else + replicate ary NONE + else + replicate ary NONE + in + Formula (guards_sym_formula_prefix ^ s ^ + (if n > 1 then "_" ^ string_of_int j else ""), kind, + IConst ((s, s'), T, T_args) + |> fold (curry (IApp o swap)) bounds + |> type_guard_iterm format type_enc res_T + |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts) + |> formula_from_iformula ctxt [] format mono type_enc + always_guard_var_in_formula (SOME true) + |> close_formula_universally + |> bound_tvars type_enc (n > 1) (atomic_types_of T) + |> maybe_negate, + isabelle_info format introN, NONE) + end + +fun formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono type_enc n s + (j, (s', T_args, T, pred_sym, ary, in_conj)) = + let + val thy = Proof_Context.theory_of ctxt + val level = level_of_type_enc type_enc + val grain = granularity_of_type_level level + val ident_base = + tags_sym_formula_prefix ^ s ^ + (if n > 1 then "_" ^ string_of_int j else "") + val (kind, maybe_negate) = + if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot) + else (Axiom, I) + val (arg_Ts, res_T) = chop_fun ary T + val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int) + val bounds = bound_names |> map (fn name => ATerm (name, [])) + val cst = mk_aterm format type_enc (s, s') T_args + val eq = maybe_negate oo eq_formula type_enc (atomic_types_of T) pred_sym + val should_encode = should_encode_type ctxt mono level + val tag_with = tag_with_type ctxt format mono type_enc NONE + val add_formula_for_res = + if should_encode res_T then + let + val tagged_bounds = + if grain = Ghost_Type_Arg_Vars then + let val ghosts = ghost_type_args thy s ary in + map2 (fn (j, arg_T) => member (op =) ghosts j ? tag_with arg_T) + (0 upto ary - 1 ~~ arg_Ts) bounds + end + else + bounds + in + cons (Formula (ident_base ^ "_res", kind, + eq (tag_with res_T (cst bounds)) (cst tagged_bounds), + isabelle_info format simpN, NONE)) + end + else + I + fun add_formula_for_arg k = + let val arg_T = nth arg_Ts k in + if should_encode arg_T then + case chop k bounds of + (bounds1, bound :: bounds2) => + cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind, + eq (cst (bounds1 @ tag_with arg_T bound :: bounds2)) + (cst bounds), + isabelle_info format simpN, NONE)) + | _ => raise Fail "expected nonempty tail" + else + I + end + in + [] |> not pred_sym ? add_formula_for_res + |> (Config.get ctxt type_tag_arguments andalso + grain = Positively_Naked_Vars) + ? fold add_formula_for_arg (ary - 1 downto 0) + end + +fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd + +fun rationalize_decls ctxt (decls as decl :: (decls' as _ :: _)) = + let + val T = result_type_of_decl decl + |> map_type_tvar (fn (z, _) => TVar (z, HOLogic.typeS)) + in + if forall (type_generalization ctxt T o result_type_of_decl) decls' then + [decl] + else + decls + end + | rationalize_decls _ decls = decls + +fun problem_lines_for_sym_decls ctxt format conj_sym_kind mono type_enc + (s, decls) = + case type_enc of + Simple_Types _ => [decl_line_for_sym ctxt format mono type_enc s (hd decls)] + | Guards (_, level) => + let + val decls = decls |> rationalize_decls ctxt + val n = length decls + val decls = + decls |> filter (should_encode_type ctxt mono level + o result_type_of_decl) + in + (0 upto length decls - 1, decls) + |-> map2 (formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono + type_enc n s) + end + | Tags (_, level) => + if granularity_of_type_level level = All_Vars then + [] + else + let val n = length decls in + (0 upto n - 1 ~~ decls) + |> maps (formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono + type_enc n s) + end + +fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono type_enc + mono_Ts sym_decl_tab = + let + val syms = sym_decl_tab |> Symtab.dest |> sort_wrt fst + val mono_lines = + problem_lines_for_mono_types ctxt format mono type_enc mono_Ts + val decl_lines = + fold_rev (append o problem_lines_for_sym_decls ctxt format conj_sym_kind + mono type_enc) + syms [] + in mono_lines @ decl_lines end + +fun needs_type_tag_idempotence ctxt (Tags (poly, level)) = + Config.get ctxt type_tag_idempotence andalso + is_type_level_monotonicity_based level andalso + poly <> Mangled_Monomorphic + | needs_type_tag_idempotence _ _ = false + +val implicit_declsN = "Should-be-implicit typings" +val explicit_declsN = "Explicit typings" +val factsN = "Relevant facts" +val class_relsN = "Class relationships" +val aritiesN = "Arities" +val helpersN = "Helper facts" +val conjsN = "Conjectures" +val free_typesN = "Type variables" + +(* TFF allows implicit declarations of types, function symbols, and predicate + symbols (with "$i" as the type of individuals), but some provers (e.g., + SNARK) require explicit declarations. The situation is similar for THF. *) + +fun default_type type_enc pred_sym s = + let + val ind = + case type_enc of + Simple_Types _ => + if String.isPrefix type_const_prefix s then atype_of_types + else individual_atype + | _ => individual_atype + fun typ 0 = if pred_sym then bool_atype else ind + | typ ary = AFun (ind, typ (ary - 1)) + in typ end + +fun nary_type_constr_type n = + funpow n (curry AFun atype_of_types) atype_of_types + +fun undeclared_syms_in_problem type_enc problem = + let + val declared = declared_syms_in_problem problem + fun do_sym name ty = + if member (op =) declared name then I else AList.default (op =) (name, ty) + fun do_type (AType (name as (s, _), tys)) = + is_tptp_user_symbol s + ? do_sym name (fn () => nary_type_constr_type (length tys)) + #> fold do_type tys + | do_type (AFun (ty1, ty2)) = do_type ty1 #> do_type ty2 + | do_type (ATyAbs (_, ty)) = do_type ty + fun do_term pred_sym (ATerm (name as (s, _), tms)) = + is_tptp_user_symbol s + ? do_sym name (fn _ => default_type type_enc pred_sym s (length tms)) + #> fold (do_term false) tms + | do_term _ (AAbs ((_, ty), tm)) = do_type ty #> do_term false tm + fun do_formula (AQuant (_, xs, phi)) = + fold do_type (map_filter snd xs) #> do_formula phi + | do_formula (AConn (_, phis)) = fold do_formula phis + | do_formula (AAtom tm) = do_term true tm + fun do_problem_line (Decl (_, _, ty)) = do_type ty + | do_problem_line (Formula (_, _, phi, _, _)) = do_formula phi + in + fold (fold do_problem_line o snd) problem [] + |> filter_out (is_built_in_tptp_symbol o fst o fst) + end + +fun declare_undeclared_syms_in_atp_problem type_enc problem = + let + val decls = + problem + |> undeclared_syms_in_problem type_enc + |> sort_wrt (fst o fst) + |> map (fn (x as (s, _), ty) => Decl (type_decl_prefix ^ s, x, ty ())) + in (implicit_declsN, decls) :: problem end + +fun exists_subdtype P = + let + fun ex U = P U orelse + (case U of Datatype.DtType (_, Us) => exists ex Us | _ => false) + in ex end + +fun is_poly_constr (_, Us) = + exists (exists_subdtype (fn Datatype.DtTFree _ => true | _ => false)) Us + +fun all_constrs_of_polymorphic_datatypes thy = + Symtab.fold (snd + #> #descr + #> maps (snd #> #3) + #> (fn cs => exists is_poly_constr cs ? append cs)) + (Datatype.get_all thy) [] + |> List.partition is_poly_constr + |> pairself (map fst) + +(* Forcing explicit applications is expensive for polymorphic encodings, because + it takes only one existential variable ranging over "'a => 'b" to ruin + everything. Hence we do it only if there are few facts (is normally the case + for "metis" and the minimizer. *) +val explicit_apply_threshold = 50 + +fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_enc exporter + lam_trans readable_names preproc hyp_ts concl_t facts = + let + val thy = Proof_Context.theory_of ctxt + val type_enc = type_enc |> adjust_type_enc format + val explicit_apply = + if polymorphism_of_type_enc type_enc <> Polymorphic orelse + length facts <= explicit_apply_threshold then + NONE + else + SOME false + val lam_trans = + if lam_trans = keep_lamsN andalso + not (is_type_enc_higher_order type_enc) then + error ("Lambda translation scheme incompatible with first-order \ + \encoding.") + else + lam_trans + val (fact_names, classes, conjs, facts, class_rel_clauses, arity_clauses, + lifted) = + translate_formulas ctxt format prem_kind type_enc lam_trans preproc hyp_ts + concl_t facts + val sym_tab = sym_table_for_facts ctxt type_enc explicit_apply conjs facts + val mono = conjs @ facts |> mononotonicity_info_for_facts ctxt type_enc + val (polym_constrs, monom_constrs) = + all_constrs_of_polymorphic_datatypes thy + |>> map (make_fixed_const (SOME format)) + val firstorderize = + firstorderize_fact thy monom_constrs format type_enc sym_tab + val (conjs, facts) = (conjs, facts) |> pairself (map firstorderize) + val sym_tab = sym_table_for_facts ctxt type_enc (SOME false) conjs facts + val helpers = + sym_tab |> helper_facts_for_sym_table ctxt format type_enc + |> map firstorderize + val mono_Ts = + helpers @ conjs @ facts |> monotonic_types_for_facts ctxt mono type_enc + val class_decl_lines = decl_lines_for_classes type_enc classes + val sym_decl_lines = + (conjs, helpers @ facts) + |> sym_decl_table_for_facts ctxt format type_enc sym_tab + |> problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono + type_enc mono_Ts + val helper_lines = + 0 upto length helpers - 1 ~~ helpers + |> map (formula_line_for_fact ctxt polym_constrs format helper_prefix I + false true mono type_enc) + |> (if needs_type_tag_idempotence ctxt type_enc then + cons (type_tag_idempotence_fact format type_enc) + else + I) + (* Reordering these might confuse the proof reconstruction code or the SPASS + FLOTTER hack. *) + val problem = + [(explicit_declsN, class_decl_lines @ sym_decl_lines), + (factsN, + map (formula_line_for_fact ctxt polym_constrs format fact_prefix + ascii_of (not exporter) (not exporter) mono type_enc) + (0 upto length facts - 1 ~~ facts)), + (class_relsN, + map (formula_line_for_class_rel_clause format type_enc) + class_rel_clauses), + (aritiesN, + map (formula_line_for_arity_clause format type_enc) arity_clauses), + (helpersN, helper_lines), + (conjsN, + map (formula_line_for_conjecture ctxt polym_constrs format mono + type_enc) conjs), + (free_typesN, formula_lines_for_free_types type_enc (facts @ conjs))] + val problem = + problem + |> (case format of + CNF => ensure_cnf_problem + | CNF_UEQ => filter_cnf_ueq_problem + | FOF => I + | TFF (_, TPTP_Implicit) => I + | THF (_, TPTP_Implicit, _) => I + | _ => declare_undeclared_syms_in_atp_problem type_enc) + val (problem, pool) = problem |> nice_atp_problem readable_names format + fun add_sym_ary (s, {min_ary, ...} : sym_info) = + min_ary > 0 ? Symtab.insert (op =) (s, min_ary) + in + (problem, + case pool of SOME the_pool => snd the_pool | NONE => Symtab.empty, + fact_names |> Vector.fromList, + lifted, + Symtab.empty |> Symtab.fold add_sym_ary sym_tab) + end + +(* FUDGE *) +val conj_weight = 0.0 +val hyp_weight = 0.1 +val fact_min_weight = 0.2 +val fact_max_weight = 1.0 +val type_info_default_weight = 0.8 + +fun add_term_weights weight (ATerm (s, tms)) = + is_tptp_user_symbol s ? Symtab.default (s, weight) + #> fold (add_term_weights weight) tms + | add_term_weights weight (AAbs (_, tm)) = add_term_weights weight tm +fun add_problem_line_weights weight (Formula (_, _, phi, _, _)) = + formula_fold NONE (K (add_term_weights weight)) phi + | add_problem_line_weights _ _ = I + +fun add_conjectures_weights [] = I + | add_conjectures_weights conjs = + let val (hyps, conj) = split_last conjs in + add_problem_line_weights conj_weight conj + #> fold (add_problem_line_weights hyp_weight) hyps + end + +fun add_facts_weights facts = + let + val num_facts = length facts + fun weight_of j = + fact_min_weight + (fact_max_weight - fact_min_weight) * Real.fromInt j + / Real.fromInt num_facts + in + map weight_of (0 upto num_facts - 1) ~~ facts + |> fold (uncurry add_problem_line_weights) + end + +(* Weights are from 0.0 (most important) to 1.0 (least important). *) +fun atp_problem_weights problem = + let val get = these o AList.lookup (op =) problem in + Symtab.empty + |> add_conjectures_weights (get free_typesN @ get conjsN) + |> add_facts_weights (get factsN) + |> fold (fold (add_problem_line_weights type_info_default_weight) o get) + [explicit_declsN, class_relsN, aritiesN] + |> Symtab.dest + |> sort (prod_ord Real.compare string_ord o pairself swap) + end + +end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_proof_reconstruct.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP/atp_proof_reconstruct.ML Mon Jan 23 17:40:32 2012 +0100 @@ -0,0 +1,951 @@ +(* Title: HOL/Tools/ATP/atp_proof_reconstruct.ML + Author: Lawrence C. Paulson, Cambridge University Computer Laboratory + Author: Claire Quigley, Cambridge University Computer Laboratory + Author: Jasmin Blanchette, TU Muenchen + +Proof reconstruction from ATP proofs. +*) + +signature ATP_PROOF_RECONSTRUCT = +sig + type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term + type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula + type 'a proof = 'a ATP_Proof.proof + type locality = ATP_Problem_Generate.locality + + datatype reconstructor = + Metis of string * string | + SMT + + datatype play = + Played of reconstructor * Time.time | + Trust_Playable of reconstructor * Time.time option | + Failed_to_Play of reconstructor + + type minimize_command = string list -> string + type one_line_params = + play * string * (string * locality) list * minimize_command * int * int + type isar_params = + bool * int * string Symtab.table * (string * locality) list vector + * int Symtab.table * string proof * thm + + val metisN : string + val smtN : string + val full_typesN : string + val partial_typesN : string + val no_typesN : string + val really_full_type_enc : string + val full_type_enc : string + val partial_type_enc : string + val no_type_enc : string + val full_type_encs : string list + val partial_type_encs : string list + val metis_default_lam_trans : string + val metis_call : string -> string -> string + val string_for_reconstructor : reconstructor -> string + val used_facts_in_atp_proof : + Proof.context -> (string * locality) list vector -> string proof + -> (string * locality) list + val lam_trans_from_atp_proof : string proof -> string -> string + val is_typed_helper_used_in_atp_proof : string proof -> bool + val used_facts_in_unsound_atp_proof : + Proof.context -> (string * locality) list vector -> 'a proof + -> string list option + val unalias_type_enc : string -> string list + val one_line_proof_text : one_line_params -> string + val make_tvar : string -> typ + val make_tfree : Proof.context -> string -> typ + val term_from_atp : + Proof.context -> bool -> int Symtab.table -> typ option + -> (string, string) ho_term -> term + val prop_from_atp : + Proof.context -> bool -> int Symtab.table + -> (string, string, (string, string) ho_term) formula -> term + val isar_proof_text : + Proof.context -> bool -> isar_params -> one_line_params -> string + val proof_text : + Proof.context -> bool -> isar_params -> one_line_params -> string +end; + +structure ATP_Proof_Reconstruct : ATP_PROOF_RECONSTRUCT = +struct + +open ATP_Util +open ATP_Problem +open ATP_Proof +open ATP_Problem_Generate + +structure String_Redirect = ATP_Proof_Redirect( + type key = step_name + val ord = fn ((s, _ : string list), (s', _)) => fast_string_ord (s, s') + val string_of = fst) + +open String_Redirect + +datatype reconstructor = + Metis of string * string | + SMT + +datatype play = + Played of reconstructor * Time.time | + Trust_Playable of reconstructor * Time.time option | + Failed_to_Play of reconstructor + +type minimize_command = string list -> string +type one_line_params = + play * string * (string * locality) list * minimize_command * int * int +type isar_params = + bool * int * string Symtab.table * (string * locality) list vector + * int Symtab.table * string proof * thm + +val metisN = "metis" +val smtN = "smt" + +val full_typesN = "full_types" +val partial_typesN = "partial_types" +val no_typesN = "no_types" + +val really_full_type_enc = "mono_tags" +val full_type_enc = "poly_guards_query" +val partial_type_enc = "poly_args" +val no_type_enc = "erased" + +val full_type_encs = [full_type_enc, really_full_type_enc] +val partial_type_encs = partial_type_enc :: full_type_encs + +val type_enc_aliases = + [(full_typesN, full_type_encs), + (partial_typesN, partial_type_encs), + (no_typesN, [no_type_enc])] + +fun unalias_type_enc s = + AList.lookup (op =) type_enc_aliases s |> the_default [s] + +val metis_default_lam_trans = combinatorsN + +fun metis_call type_enc lam_trans = + let + val type_enc = + case AList.find (fn (enc, encs) => enc = hd encs) type_enc_aliases + type_enc of + [alias] => alias + | _ => type_enc + val opts = [] |> type_enc <> partial_typesN ? cons type_enc + |> lam_trans <> metis_default_lam_trans ? cons lam_trans + in metisN ^ (if null opts then "" else " (" ^ commas opts ^ ")") end + +fun string_for_reconstructor (Metis (type_enc, lam_trans)) = + metis_call type_enc lam_trans + | string_for_reconstructor SMT = smtN + +fun find_first_in_list_vector vec key = + Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key + | (_, value) => value) NONE vec + +val unprefix_fact_number = space_implode "_" o tl o space_explode "_" + +fun resolve_one_named_fact fact_names s = + case try (unprefix fact_prefix) s of + SOME s' => + let val s' = s' |> unprefix_fact_number |> unascii_of in + s' |> find_first_in_list_vector fact_names |> Option.map (pair s') + end + | NONE => NONE +fun resolve_fact fact_names = map_filter (resolve_one_named_fact fact_names) +fun is_fact fact_names = not o null o resolve_fact fact_names + +fun resolve_one_named_conjecture s = + case try (unprefix conjecture_prefix) s of + SOME s' => Int.fromString s' + | NONE => NONE + +val resolve_conjecture = map_filter resolve_one_named_conjecture +val is_conjecture = not o null o resolve_conjecture + +fun is_axiom_used_in_proof pred = + exists (fn Inference ((_, ss), _, _, []) => exists pred ss | _ => false) + +val is_combinator_def = String.isPrefix (helper_prefix ^ combinator_prefix) + +val ascii_of_lam_fact_prefix = ascii_of lam_fact_prefix + +(* overapproximation (good enough) *) +fun is_lam_lifted s = + String.isPrefix fact_prefix s andalso + String.isSubstring ascii_of_lam_fact_prefix s + +fun lam_trans_from_atp_proof atp_proof default = + if is_axiom_used_in_proof is_combinator_def atp_proof then combinatorsN + else if is_axiom_used_in_proof is_lam_lifted atp_proof then lam_liftingN + else default + +val is_typed_helper_name = + String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix +fun is_typed_helper_used_in_atp_proof atp_proof = + is_axiom_used_in_proof is_typed_helper_name atp_proof + +val leo2_ext = "extcnf_equal_neg" +val isa_ext = Thm.get_name_hint @{thm ext} +val isa_short_ext = Long_Name.base_name isa_ext + +fun ext_name ctxt = + if Thm.eq_thm_prop (@{thm ext}, + singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then + isa_short_ext + else + isa_ext + +fun add_fact _ fact_names (Inference ((_, ss), _, _, [])) = + union (op =) (resolve_fact fact_names ss) + | add_fact ctxt _ (Inference (_, _, rule, _)) = + if rule = leo2_ext then insert (op =) (ext_name ctxt, General) else I + | add_fact _ _ _ = I + +fun used_facts_in_atp_proof ctxt fact_names atp_proof = + if null atp_proof then Vector.foldl (uncurry (union (op =))) [] fact_names + else fold (add_fact ctxt fact_names) atp_proof [] + +(* (quasi-)underapproximation of the truth *) +fun is_locality_global Local = false + | is_locality_global Assum = false + | is_locality_global Chained = false + | is_locality_global _ = true + +fun used_facts_in_unsound_atp_proof _ _ [] = NONE + | used_facts_in_unsound_atp_proof ctxt fact_names atp_proof = + let + val used_facts = used_facts_in_atp_proof ctxt fact_names atp_proof + in + if forall (is_locality_global o snd) used_facts andalso + not (is_axiom_used_in_proof (is_conjecture o single) atp_proof) then + SOME (map fst used_facts) + else + NONE + end + + +(** Soft-core proof reconstruction: one-liners **) + +fun string_for_label (s, num) = s ^ string_of_int num + +fun show_time NONE = "" + | show_time (SOME ext_time) = " (" ^ string_from_ext_time ext_time ^ ")" + +fun apply_on_subgoal _ 1 = "by " + | apply_on_subgoal 1 _ = "apply " + | apply_on_subgoal i n = + "prefer " ^ string_of_int i ^ " " ^ apply_on_subgoal 1 n +fun command_call name [] = + name |> not (Lexicon.is_identifier name) ? enclose "(" ")" + | command_call name args = "(" ^ name ^ " " ^ space_implode " " args ^ ")" +fun try_command_line banner time command = + banner ^ ": " ^ Markup.markup Isabelle_Markup.sendback command ^ show_time time ^ "." +fun using_labels [] = "" + | using_labels ls = + "using " ^ space_implode " " (map string_for_label ls) ^ " " +fun reconstructor_command reconstr i n (ls, ss) = + using_labels ls ^ apply_on_subgoal i n ^ + command_call (string_for_reconstructor reconstr) ss +fun minimize_line _ [] = "" + | minimize_line minimize_command ss = + case minimize_command ss of + "" => "" + | command => "\nTo minimize: " ^ Markup.markup Isabelle_Markup.sendback command ^ "." + +val split_used_facts = + List.partition (curry (op =) Chained o snd) + #> pairself (sort_distinct (string_ord o pairself fst)) + +fun one_line_proof_text (preplay, banner, used_facts, minimize_command, + subgoal, subgoal_count) = + let + val (chained, extra) = split_used_facts used_facts + val (failed, reconstr, ext_time) = + case preplay of + Played (reconstr, time) => (false, reconstr, (SOME (false, time))) + | Trust_Playable (reconstr, time) => + (false, reconstr, + case time of + NONE => NONE + | SOME time => + if time = Time.zeroTime then NONE else SOME (true, time)) + | Failed_to_Play reconstr => (true, reconstr, NONE) + val try_line = + ([], map fst extra) + |> reconstructor_command reconstr subgoal subgoal_count + |> (if failed then enclose "One-line proof reconstruction failed: " "." + else try_command_line banner ext_time) + in try_line ^ minimize_line minimize_command (map fst (extra @ chained)) end + +(** Hard-core proof reconstruction: structured Isar proofs **) + +fun forall_of v t = HOLogic.all_const (fastype_of v) $ lambda v t +fun exists_of v t = HOLogic.exists_const (fastype_of v) $ lambda v t + +fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS) +fun make_tfree ctxt w = + let val ww = "'" ^ w in + TFree (ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1))) + end + +val indent_size = 2 +val no_label = ("", ~1) + +val raw_prefix = "x" +val assum_prefix = "a" +val have_prefix = "f" + +fun raw_label_for_name (num, ss) = + case resolve_conjecture ss of + [j] => (conjecture_prefix, j) + | _ => case Int.fromString num of + SOME j => (raw_prefix, j) + | NONE => (raw_prefix ^ num, 0) + +(**** INTERPRETATION OF TSTP SYNTAX TREES ****) + +exception HO_TERM of (string, string) ho_term list +exception FORMULA of (string, string, (string, string) ho_term) formula list +exception SAME of unit + +(* Type variables are given the basic sort "HOL.type". Some will later be + constrained by information from type literals, or by type inference. *) +fun typ_from_atp ctxt (u as ATerm (a, us)) = + let val Ts = map (typ_from_atp ctxt) us in + case unprefix_and_unascii type_const_prefix a of + SOME b => Type (invert_const b, Ts) + | NONE => + if not (null us) then + raise HO_TERM [u] (* only "tconst"s have type arguments *) + else case unprefix_and_unascii tfree_prefix a of + SOME b => make_tfree ctxt b + | NONE => + (* Could be an Isabelle variable or a variable from the ATP, say "X1" + or "_5018". Sometimes variables from the ATP are indistinguishable + from Isabelle variables, which forces us to use a type parameter in + all cases. *) + (a |> perhaps (unprefix_and_unascii tvar_prefix), HOLogic.typeS) + |> Type_Infer.param 0 + end + +(* Type class literal applied to a type. Returns triple of polarity, class, + type. *) +fun type_constraint_from_term ctxt (u as ATerm (a, us)) = + case (unprefix_and_unascii class_prefix a, map (typ_from_atp ctxt) us) of + (SOME b, [T]) => (b, T) + | _ => raise HO_TERM [u] + +(* Accumulate type constraints in a formula: negative type literals. *) +fun add_var (key, z) = Vartab.map_default (key, []) (cons z) +fun add_type_constraint false (cl, TFree (a ,_)) = add_var ((a, ~1), cl) + | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl) + | add_type_constraint _ _ = I + +fun repair_variable_name f s = + let + fun subscript_name s n = s ^ nat_subscript n + val s = String.map f s + in + case space_explode "_" s of + [_] => (case take_suffix Char.isDigit (String.explode s) of + (cs1 as _ :: _, cs2 as _ :: _) => + subscript_name (String.implode cs1) + (the (Int.fromString (String.implode cs2))) + | (_, _) => s) + | [s1, s2] => (case Int.fromString s2 of + SOME n => subscript_name s1 n + | NONE => s) + | _ => s + end + +(* The number of type arguments of a constant, zero if it's monomorphic. For + (instances of) Skolem pseudoconstants, this information is encoded in the + constant name. *) +fun num_type_args thy s = + if String.isPrefix skolem_const_prefix s then + s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the + else if String.isPrefix lam_lifted_prefix s then + if String.isPrefix lam_lifted_poly_prefix s then 2 else 0 + else + (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length + +fun slack_fastype_of t = fastype_of t handle TERM _ => HOLogic.typeT + +(* First-order translation. No types are known for variables. "HOLogic.typeT" + should allow them to be inferred. *) +fun term_from_atp ctxt textual sym_tab = + let + val thy = Proof_Context.theory_of ctxt + (* For Metis, we use 1 rather than 0 because variable references in clauses + may otherwise conflict with variable constraints in the goal. At least, + type inference often fails otherwise. See also "axiom_inference" in + "Metis_Reconstruct". *) + val var_index = if textual then 0 else 1 + fun do_term extra_ts opt_T u = + case u of + ATerm (s, us) => + if String.isPrefix simple_type_prefix s then + @{const True} (* ignore TPTP type information *) + else if s = tptp_equal then + let val ts = map (do_term [] NONE) us in + if textual andalso length ts = 2 andalso + hd ts aconv List.last ts then + (* Vampire is keen on producing these. *) + @{const True} + else + list_comb (Const (@{const_name HOL.eq}, HOLogic.typeT), ts) + end + else case unprefix_and_unascii const_prefix s of + SOME s' => + let + val ((s', s''), mangled_us) = + s' |> unmangled_const |>> `invert_const + in + if s' = type_tag_name then + case mangled_us @ us of + [typ_u, term_u] => + do_term extra_ts (SOME (typ_from_atp ctxt typ_u)) term_u + | _ => raise HO_TERM us + else if s' = predicator_name then + do_term [] (SOME @{typ bool}) (hd us) + else if s' = app_op_name then + let val extra_t = do_term [] NONE (List.last us) in + do_term (extra_t :: extra_ts) + (case opt_T of + SOME T => SOME (slack_fastype_of extra_t --> T) + | NONE => NONE) + (nth us (length us - 2)) + end + else if s' = type_guard_name then + @{const True} (* ignore type predicates *) + else + let + val new_skolem = String.isPrefix new_skolem_const_prefix s'' + val num_ty_args = + length us - the_default 0 (Symtab.lookup sym_tab s) + val (type_us, term_us) = + chop num_ty_args us |>> append mangled_us + val term_ts = map (do_term [] NONE) term_us + val T = + (if not (null type_us) andalso + num_type_args thy s' = length type_us then + let val Ts = type_us |> map (typ_from_atp ctxt) in + if new_skolem then + SOME (Type_Infer.paramify_vars (tl Ts ---> hd Ts)) + else if textual then + try (Sign.const_instance thy) (s', Ts) + else + NONE + end + else + NONE) + |> (fn SOME T => T + | NONE => map slack_fastype_of term_ts ---> + (case opt_T of + SOME T => T + | NONE => HOLogic.typeT)) + val t = + if new_skolem then + Var ((new_skolem_var_name_from_const s'', var_index), T) + else + Const (unproxify_const s', T) + in list_comb (t, term_ts @ extra_ts) end + end + | NONE => (* a free or schematic variable *) + let + val term_ts = map (do_term [] NONE) us + val ts = term_ts @ extra_ts + val T = + case opt_T of + SOME T => map slack_fastype_of term_ts ---> T + | NONE => map slack_fastype_of ts ---> HOLogic.typeT + val t = + case unprefix_and_unascii fixed_var_prefix s of + SOME s => Free (s, T) + | NONE => + case unprefix_and_unascii schematic_var_prefix s of + SOME s => Var ((s, var_index), T) + | NONE => + Var ((s |> textual ? repair_variable_name Char.toLower, + var_index), T) + in list_comb (t, ts) end + in do_term [] end + +fun term_from_atom ctxt textual sym_tab pos (u as ATerm (s, _)) = + if String.isPrefix class_prefix s then + add_type_constraint pos (type_constraint_from_term ctxt u) + #> pair @{const True} + else + pair (term_from_atp ctxt textual sym_tab (SOME @{typ bool}) u) + +val combinator_table = + [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}), + (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}), + (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}), + (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}), + (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})] + +fun uncombine_term thy = + let + fun aux (t1 $ t2) = betapply (pairself aux (t1, t2)) + | aux (Abs (s, T, t')) = Abs (s, T, aux t') + | aux (t as Const (x as (s, _))) = + (case AList.lookup (op =) combinator_table s of + SOME thm => thm |> prop_of |> specialize_type thy x + |> Logic.dest_equals |> snd + | NONE => t) + | aux t = t + in aux end + +(* Update schematic type variables with detected sort constraints. It's not + totally clear whether this code is necessary. *) +fun repair_tvar_sorts (t, tvar_tab) = + let + fun do_type (Type (a, Ts)) = Type (a, map do_type Ts) + | do_type (TVar (xi, s)) = + TVar (xi, the_default s (Vartab.lookup tvar_tab xi)) + | do_type (TFree z) = TFree z + fun do_term (Const (a, T)) = Const (a, do_type T) + | do_term (Free (a, T)) = Free (a, do_type T) + | do_term (Var (xi, T)) = Var (xi, do_type T) + | do_term (t as Bound _) = t + | do_term (Abs (a, T, t)) = Abs (a, do_type T, do_term t) + | do_term (t1 $ t2) = do_term t1 $ do_term t2 + in t |> not (Vartab.is_empty tvar_tab) ? do_term end + +fun quantify_over_var quant_of var_s t = + let + val vars = [] |> Term.add_vars t |> filter (fn ((s, _), _) => s = var_s) + |> map Var + in fold_rev quant_of vars t end + +(* Interpret an ATP formula as a HOL term, extracting sort constraints as they + appear in the formula. *) +fun prop_from_atp ctxt textual sym_tab phi = + let + fun do_formula pos phi = + case phi of + AQuant (_, [], phi) => do_formula pos phi + | AQuant (q, (s, _) :: xs, phi') => + do_formula pos (AQuant (q, xs, phi')) + (* FIXME: TFF *) + #>> quantify_over_var (case q of + AForall => forall_of + | AExists => exists_of) + (s |> textual ? repair_variable_name Char.toLower) + | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not + | AConn (c, [phi1, phi2]) => + do_formula (pos |> c = AImplies ? not) phi1 + ##>> do_formula pos phi2 + #>> (case c of + AAnd => s_conj + | AOr => s_disj + | AImplies => s_imp + | AIff => s_iff + | ANot => raise Fail "impossible connective") + | AAtom tm => term_from_atom ctxt textual sym_tab pos tm + | _ => raise FORMULA [phi] + in repair_tvar_sorts (do_formula true phi Vartab.empty) end + +fun infer_formula_types ctxt = + Type.constraint HOLogic.boolT + #> Syntax.check_term + (Proof_Context.set_mode Proof_Context.mode_schematic ctxt) + +fun uncombined_etc_prop_from_atp ctxt textual sym_tab = + let val thy = Proof_Context.theory_of ctxt in + prop_from_atp ctxt textual sym_tab + #> textual ? uncombine_term thy #> infer_formula_types ctxt + end + +(**** Translation of TSTP files to Isar proofs ****) + +fun unvarify_term (Var ((s, 0), T)) = Free (s, T) + | unvarify_term t = raise TERM ("unvarify_term: non-Var", [t]) + +fun decode_line sym_tab (Definition (name, phi1, phi2)) ctxt = + let + val thy = Proof_Context.theory_of ctxt + val t1 = prop_from_atp ctxt true sym_tab phi1 + val vars = snd (strip_comb t1) + val frees = map unvarify_term vars + val unvarify_args = subst_atomic (vars ~~ frees) + val t2 = prop_from_atp ctxt true sym_tab phi2 + val (t1, t2) = + HOLogic.eq_const HOLogic.typeT $ t1 $ t2 + |> unvarify_args |> uncombine_term thy |> infer_formula_types ctxt + |> HOLogic.dest_eq + in + (Definition (name, t1, t2), + fold Variable.declare_term (maps Misc_Legacy.term_frees [t1, t2]) ctxt) + end + | decode_line sym_tab (Inference (name, u, rule, deps)) ctxt = + let val t = u |> uncombined_etc_prop_from_atp ctxt true sym_tab in + (Inference (name, t, rule, deps), + fold Variable.declare_term (Misc_Legacy.term_frees t) ctxt) + end +fun decode_lines ctxt sym_tab lines = + fst (fold_map (decode_line sym_tab) lines ctxt) + +fun is_same_inference _ (Definition _) = false + | is_same_inference t (Inference (_, t', _, _)) = t aconv t' + +(* No "real" literals means only type information (tfree_tcs, clsrel, or + clsarity). *) +val is_only_type_information = curry (op aconv) @{term True} + +fun replace_one_dependency (old, new) dep = + if is_same_atp_step dep old then new else [dep] +fun replace_dependencies_in_line _ (line as Definition _) = line + | replace_dependencies_in_line p (Inference (name, t, rule, deps)) = + Inference (name, t, rule, + fold (union (op =) o replace_one_dependency p) deps []) + +(* Discard facts; consolidate adjacent lines that prove the same formula, since + they differ only in type information.*) +fun add_line _ (line as Definition _) lines = line :: lines + | add_line fact_names (Inference (name as (_, ss), t, rule, [])) lines = + (* No dependencies: fact, conjecture, or (for Vampire) internal facts or + definitions. *) + if is_fact fact_names ss then + (* Facts are not proof lines. *) + if is_only_type_information t then + map (replace_dependencies_in_line (name, [])) lines + (* Is there a repetition? If so, replace later line by earlier one. *) + else case take_prefix (not o is_same_inference t) lines of + (_, []) => lines (* no repetition of proof line *) + | (pre, Inference (name', _, _, _) :: post) => + pre @ map (replace_dependencies_in_line (name', [name])) post + | _ => raise Fail "unexpected inference" + else if is_conjecture ss then + Inference (name, s_not t, rule, []) :: lines + else + map (replace_dependencies_in_line (name, [])) lines + | add_line _ (Inference (name, t, rule, deps)) lines = + (* Type information will be deleted later; skip repetition test. *) + if is_only_type_information t then + Inference (name, t, rule, deps) :: lines + (* Is there a repetition? If so, replace later line by earlier one. *) + else case take_prefix (not o is_same_inference t) lines of + (* FIXME: Doesn't this code risk conflating proofs involving different + types? *) + (_, []) => Inference (name, t, rule, deps) :: lines + | (pre, Inference (name', t', rule, _) :: post) => + Inference (name, t', rule, deps) :: + pre @ map (replace_dependencies_in_line (name', [name])) post + | _ => raise Fail "unexpected inference" + +(* Recursively delete empty lines (type information) from the proof. *) +fun add_nontrivial_line (line as Inference (name, t, _, [])) lines = + if is_only_type_information t then delete_dependency name lines + else line :: lines + | add_nontrivial_line line lines = line :: lines +and delete_dependency name lines = + fold_rev add_nontrivial_line + (map (replace_dependencies_in_line (name, [])) lines) [] + +(* ATPs sometimes reuse free variable names in the strangest ways. Removing + offending lines often does the trick. *) +fun is_bad_free frees (Free x) = not (member (op =) frees x) + | is_bad_free _ _ = false + +fun add_desired_line _ _ _ (line as Definition (name, _, _)) (j, lines) = + (j, line :: map (replace_dependencies_in_line (name, [])) lines) + | add_desired_line isar_shrink_factor fact_names frees + (Inference (name as (_, ss), t, rule, deps)) (j, lines) = + (j + 1, + if is_fact fact_names ss orelse + is_conjecture ss orelse + (* the last line must be kept *) + j = 0 orelse + (not (is_only_type_information t) andalso + null (Term.add_tvars t []) andalso + not (exists_subterm (is_bad_free frees) t) andalso + length deps >= 2 andalso j mod isar_shrink_factor = 0 andalso + (* kill next to last line, which usually results in a trivial step *) + j <> 1) then + Inference (name, t, rule, deps) :: lines (* keep line *) + else + map (replace_dependencies_in_line (name, deps)) lines) (* drop line *) + +(** Isar proof construction and manipulation **) + +type label = string * int +type facts = label list * string list + +datatype isar_qualifier = Show | Then | Moreover | Ultimately + +datatype isar_step = + Fix of (string * typ) list | + Let of term * term | + Assume of label * term | + Prove of isar_qualifier list * label * term * byline +and byline = + By_Metis of facts | + Case_Split of isar_step list list * facts + +fun add_fact_from_dependency fact_names (name as (_, ss)) = + if is_fact fact_names ss then + apsnd (union (op =) (map fst (resolve_fact fact_names ss))) + else + apfst (insert (op =) (raw_label_for_name name)) + +fun repair_name "$true" = "c_True" + | repair_name "$false" = "c_False" + | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *) + | repair_name s = + if is_tptp_equal s orelse + (* seen in Vampire proofs *) + (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then + tptp_equal + else + s + +(* FIXME: Still needed? Try with SPASS proofs perhaps. *) +val kill_duplicate_assumptions_in_proof = + let + fun relabel_facts subst = + apfst (map (fn l => AList.lookup (op =) subst l |> the_default l)) + fun do_step (step as Assume (l, t)) (proof, subst, assums) = + (case AList.lookup (op aconv) assums t of + SOME l' => (proof, (l, l') :: subst, assums) + | NONE => (step :: proof, subst, (t, l) :: assums)) + | do_step (Prove (qs, l, t, by)) (proof, subst, assums) = + (Prove (qs, l, t, + case by of + By_Metis facts => By_Metis (relabel_facts subst facts) + | Case_Split (proofs, facts) => + Case_Split (map do_proof proofs, + relabel_facts subst facts)) :: + proof, subst, assums) + | do_step step (proof, subst, assums) = (step :: proof, subst, assums) + and do_proof proof = fold do_step proof ([], [], []) |> #1 |> rev + in do_proof end + +fun used_labels_of_step (Prove (_, _, _, by)) = + (case by of + By_Metis (ls, _) => ls + | Case_Split (proofs, (ls, _)) => + fold (union (op =) o used_labels_of) proofs ls) + | used_labels_of_step _ = [] +and used_labels_of proof = fold (union (op =) o used_labels_of_step) proof [] + +fun kill_useless_labels_in_proof proof = + let + val used_ls = used_labels_of proof + fun do_label l = if member (op =) used_ls l then l else no_label + fun do_step (Assume (l, t)) = Assume (do_label l, t) + | do_step (Prove (qs, l, t, by)) = + Prove (qs, do_label l, t, + case by of + Case_Split (proofs, facts) => + Case_Split (map (map do_step) proofs, facts) + | _ => by) + | do_step step = step + in map do_step proof end + +fun prefix_for_depth n = replicate_string (n + 1) + +val relabel_proof = + let + fun aux _ _ _ [] = [] + | aux subst depth (next_assum, next_fact) (Assume (l, t) :: proof) = + if l = no_label then + Assume (l, t) :: aux subst depth (next_assum, next_fact) proof + else + let val l' = (prefix_for_depth depth assum_prefix, next_assum) in + Assume (l', t) :: + aux ((l, l') :: subst) depth (next_assum + 1, next_fact) proof + end + | aux subst depth (next_assum, next_fact) + (Prove (qs, l, t, by) :: proof) = + let + val (l', subst, next_fact) = + if l = no_label then + (l, subst, next_fact) + else + let + val l' = (prefix_for_depth depth have_prefix, next_fact) + in (l', (l, l') :: subst, next_fact + 1) end + val relabel_facts = + apfst (maps (the_list o AList.lookup (op =) subst)) + val by = + case by of + By_Metis facts => By_Metis (relabel_facts facts) + | Case_Split (proofs, facts) => + Case_Split (map (aux subst (depth + 1) (1, 1)) proofs, + relabel_facts facts) + in + Prove (qs, l', t, by) :: aux subst depth (next_assum, next_fact) proof + end + | aux subst depth nextp (step :: proof) = + step :: aux subst depth nextp proof + in aux [] 0 (1, 1) end + +fun string_for_proof ctxt0 type_enc lam_trans i n = + let + val ctxt = + ctxt0 |> Config.put show_free_types false + |> Config.put show_types true + |> Config.put show_sorts true + fun fix_print_mode f x = + Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN) + (print_mode_value ())) f x + fun do_indent ind = replicate_string (ind * indent_size) " " + fun do_free (s, T) = + maybe_quote s ^ " :: " ^ + maybe_quote (fix_print_mode (Syntax.string_of_typ ctxt) T) + fun do_label l = if l = no_label then "" else string_for_label l ^ ": " + fun do_have qs = + (if member (op =) qs Moreover then "moreover " else "") ^ + (if member (op =) qs Ultimately then "ultimately " else "") ^ + (if member (op =) qs Then then + if member (op =) qs Show then "thus" else "hence" + else + if member (op =) qs Show then "show" else "have") + val do_term = maybe_quote o fix_print_mode (Syntax.string_of_term ctxt) + val reconstr = Metis (type_enc, lam_trans) + fun do_facts (ls, ss) = + reconstructor_command reconstr 1 1 + (ls |> sort_distinct (prod_ord string_ord int_ord), + ss |> sort_distinct string_ord) + and do_step ind (Fix xs) = + do_indent ind ^ "fix " ^ space_implode " and " (map do_free xs) ^ "\n" + | do_step ind (Let (t1, t2)) = + do_indent ind ^ "let " ^ do_term t1 ^ " = " ^ do_term t2 ^ "\n" + | do_step ind (Assume (l, t)) = + do_indent ind ^ "assume " ^ do_label l ^ do_term t ^ "\n" + | do_step ind (Prove (qs, l, t, By_Metis facts)) = + do_indent ind ^ do_have qs ^ " " ^ + do_label l ^ do_term t ^ " " ^ do_facts facts ^ "\n" + | do_step ind (Prove (qs, l, t, Case_Split (proofs, facts))) = + implode (map (prefix (do_indent ind ^ "moreover\n") o do_block ind) + proofs) ^ + do_indent ind ^ do_have qs ^ " " ^ do_label l ^ do_term t ^ " " ^ + do_facts facts ^ "\n" + and do_steps prefix suffix ind steps = + let val s = implode (map (do_step ind) steps) in + replicate_string (ind * indent_size - size prefix) " " ^ prefix ^ + String.extract (s, ind * indent_size, + SOME (size s - ind * indent_size - 1)) ^ + suffix ^ "\n" + end + and do_block ind proof = do_steps "{ " " }" (ind + 1) proof + (* One-step proofs are pointless; better use the Metis one-liner + directly. *) + and do_proof [Prove (_, _, _, By_Metis _)] = "" + | do_proof proof = + (if i <> 1 then "prefer " ^ string_of_int i ^ "\n" else "") ^ + do_indent 0 ^ "proof -\n" ^ do_steps "" "" 1 proof ^ do_indent 0 ^ + (if n <> 1 then "next" else "qed") + in do_proof end + +fun isar_proof_text ctxt isar_proof_requested + (debug, isar_shrink_factor, pool, fact_names, sym_tab, atp_proof, goal) + (one_line_params as (_, _, _, _, subgoal, subgoal_count)) = + let + val isar_shrink_factor = + (if isar_proof_requested then 1 else 2) * isar_shrink_factor + val (params, hyp_ts, concl_t) = strip_subgoal ctxt goal subgoal + val frees = fold Term.add_frees (concl_t :: hyp_ts) [] + val one_line_proof = one_line_proof_text one_line_params + val type_enc = + if is_typed_helper_used_in_atp_proof atp_proof then full_typesN + else partial_typesN + val lam_trans = lam_trans_from_atp_proof atp_proof metis_default_lam_trans + + fun isar_proof_of () = + let + val atp_proof = + atp_proof + |> clean_up_atp_proof_dependencies + |> nasty_atp_proof pool + |> map_term_names_in_atp_proof repair_name + |> decode_lines ctxt sym_tab + |> rpair [] |-> fold_rev (add_line fact_names) + |> rpair [] |-> fold_rev add_nontrivial_line + |> rpair (0, []) + |-> fold_rev (add_desired_line isar_shrink_factor fact_names frees) + |> snd + val conj_name = conjecture_prefix ^ string_of_int (length hyp_ts) + val conjs = + atp_proof + |> map_filter (fn Inference (name as (_, ss), _, _, []) => + if member (op =) ss conj_name then SOME name else NONE + | _ => NONE) + fun dep_of_step (Definition _) = NONE + | dep_of_step (Inference (name, _, _, from)) = SOME (from, name) + val ref_graph = atp_proof |> map_filter dep_of_step |> make_ref_graph + val axioms = axioms_of_ref_graph ref_graph conjs + val tainted = tainted_atoms_of_ref_graph ref_graph conjs + val props = + Symtab.empty + |> fold (fn Definition _ => I (* FIXME *) + | Inference ((s, _), t, _, _) => + Symtab.update_new (s, + t |> member (op = o apsnd fst) tainted s ? s_not)) + atp_proof + (* FIXME: add "fold_rev forall_of (map Var (Term.add_vars t []))"? *) + fun prop_of_clause c = + fold (curry s_disj) (map_filter (Symtab.lookup props o fst) c) + @{term False} + fun label_of_clause c = (space_implode "___" (map fst c), 0) + fun maybe_show outer c = + (outer andalso length c = 1 andalso subset (op =) (c, conjs)) + ? cons Show + fun do_have outer qs (gamma, c) = + Prove (maybe_show outer c qs, label_of_clause c, prop_of_clause c, + By_Metis (fold (add_fact_from_dependency fact_names + o the_single) gamma ([], []))) + fun do_inf outer (Have z) = do_have outer [] z + | do_inf outer (Hence z) = do_have outer [Then] z + | do_inf outer (Cases cases) = + let val c = succedent_of_cases cases in + Prove (maybe_show outer c [Ultimately], label_of_clause c, + prop_of_clause c, + Case_Split (map (do_case false) cases, ([], []))) + end + and do_case outer (c, infs) = + Assume (label_of_clause c, prop_of_clause c) :: + map (do_inf outer) infs + val isar_proof = + (if null params then [] else [Fix params]) @ + (ref_graph + |> redirect_graph axioms tainted + |> chain_direct_proof + |> map (do_inf true) + |> kill_duplicate_assumptions_in_proof + |> kill_useless_labels_in_proof + |> relabel_proof) + |> string_for_proof ctxt type_enc lam_trans subgoal subgoal_count + in + case isar_proof of + "" => + if isar_proof_requested then + "\nNo structured proof available (proof too short)." + else + "" + | _ => + "\n\n" ^ (if isar_proof_requested then "Structured proof" + else "Perhaps this will work") ^ + ":\n" ^ Markup.markup Isabelle_Markup.sendback isar_proof + end + val isar_proof = + if debug then + isar_proof_of () + else case try isar_proof_of () of + SOME s => s + | NONE => if isar_proof_requested then + "\nWarning: The Isar proof construction failed." + else + "" + in one_line_proof ^ isar_proof end + +fun proof_text ctxt isar_proof isar_params + (one_line_params as (preplay, _, _, _, _, _)) = + (if case preplay of Failed_to_Play _ => true | _ => isar_proof then + isar_proof_text ctxt isar_proof isar_params + else + one_line_proof_text) one_line_params + +end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_proof_redirect.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP/atp_proof_redirect.ML Mon Jan 23 17:40:32 2012 +0100 @@ -0,0 +1,223 @@ +(* Title: HOL/Tools/ATP/atp_proof_redirect.ML + Author: Jasmin Blanchette, TU Muenchen + +Transformation of a proof by contradiction into a direct proof. +*) + +signature ATP_ATOM = +sig + type key + val ord : key * key -> order + val string_of : key -> string +end; + +signature ATP_PROOF_REDIRECT = +sig + type atom + + structure Atom_Graph : GRAPH + + type ref_sequent = atom list * atom + type ref_graph = unit Atom_Graph.T + + type clause = atom list + type direct_sequent = atom list * clause + type direct_graph = unit Atom_Graph.T + + type rich_sequent = clause list * clause + + datatype direct_inference = + Have of rich_sequent | + Hence of rich_sequent | + Cases of (clause * direct_inference list) list + + type direct_proof = direct_inference list + + val make_ref_graph : (atom list * atom) list -> ref_graph + val axioms_of_ref_graph : ref_graph -> atom list -> atom list + val tainted_atoms_of_ref_graph : ref_graph -> atom list -> atom list + val sequents_of_ref_graph : ref_graph -> ref_sequent list + val redirect_sequent : atom list -> atom -> ref_sequent -> direct_sequent + val direct_graph : direct_sequent list -> direct_graph + val redirect_graph : atom list -> atom list -> ref_graph -> direct_proof + val succedent_of_cases : (clause * direct_inference list) list -> clause + val chain_direct_proof : direct_proof -> direct_proof + val string_of_direct_proof : direct_proof -> string +end; + +functor ATP_Proof_Redirect(Atom : ATP_ATOM): ATP_PROOF_REDIRECT = +struct + +type atom = Atom.key + +structure Atom_Graph = Graph(Atom) + +type ref_sequent = atom list * atom +type ref_graph = unit Atom_Graph.T + +type clause = atom list +type direct_sequent = atom list * clause +type direct_graph = unit Atom_Graph.T + +type rich_sequent = clause list * clause + +datatype direct_inference = + Have of rich_sequent | + Hence of rich_sequent | + Cases of (clause * direct_inference list) list + +type direct_proof = direct_inference list + +fun atom_eq p = (Atom.ord p = EQUAL) +fun clause_eq (c, d) = (length c = length d andalso forall atom_eq (c ~~ d)) +fun direct_sequent_eq ((gamma, c), (delta, d)) = + clause_eq (gamma, delta) andalso clause_eq (c, d) + +fun make_ref_graph infers = + let + fun add_edge to from = + Atom_Graph.default_node (from, ()) + #> Atom_Graph.default_node (to, ()) + #> Atom_Graph.add_edge_acyclic (from, to) + fun add_infer (froms, to) = fold (add_edge to) froms + in Atom_Graph.empty |> fold add_infer infers end + +fun axioms_of_ref_graph ref_graph conjs = + subtract atom_eq conjs (Atom_Graph.minimals ref_graph) +fun tainted_atoms_of_ref_graph ref_graph = Atom_Graph.all_succs ref_graph + +fun sequents_of_ref_graph ref_graph = + map (`(Atom_Graph.immediate_preds ref_graph)) + (filter_out (Atom_Graph.is_minimal ref_graph) (Atom_Graph.keys ref_graph)) + +fun redirect_sequent tainted bot (gamma, c) = + if member atom_eq tainted c then + gamma |> List.partition (not o member atom_eq tainted) + |>> not (atom_eq (c, bot)) ? cons c + else + (gamma, [c]) + +fun direct_graph seqs = + let + fun add_edge from to = + Atom_Graph.default_node (from, ()) + #> Atom_Graph.default_node (to, ()) + #> Atom_Graph.add_edge_acyclic (from, to) + fun add_seq (gamma, c) = fold (fn l => fold (add_edge l) c) gamma + in Atom_Graph.empty |> fold add_seq seqs end + +fun disj cs = fold (union atom_eq) cs [] |> sort Atom.ord + +fun succedent_of_inference (Have (_, c)) = c + | succedent_of_inference (Hence (_, c)) = c + | succedent_of_inference (Cases cases) = succedent_of_cases cases +and succedent_of_case (c, []) = c + | succedent_of_case (_, infs) = succedent_of_inference (List.last infs) +and succedent_of_cases cases = disj (map succedent_of_case cases) + +fun dest_Have (Have z) = z + | dest_Have _ = raise Fail "non-Have" + +fun enrich_Have nontrivs trivs (cs, c) = + (cs |> map (fn c => if member clause_eq nontrivs c then disj (c :: trivs) + else c), + disj (c :: trivs)) + |> Have + +fun s_cases cases = + case cases |> List.partition (null o snd) of + (trivs, nontrivs as [(nontriv0, proof)]) => + if forall (can dest_Have) proof then + let val seqs = proof |> map dest_Have in + seqs |> map (enrich_Have (nontriv0 :: map snd seqs) (map fst trivs)) + end + else + [Cases nontrivs] + | (_, nontrivs) => [Cases nontrivs] + +fun descendants direct_graph = + these o try (Atom_Graph.all_succs direct_graph) o single + +fun zones_of 0 _ = [] + | zones_of n (bs :: bss) = + (fold (subtract atom_eq) bss) bs :: zones_of (n - 1) (bss @ [bs]) + +fun redirect_graph axioms tainted ref_graph = + let + val [bot] = Atom_Graph.maximals ref_graph + val seqs = + map (redirect_sequent tainted bot) (sequents_of_ref_graph ref_graph) + val direct_graph = direct_graph seqs + + fun redirect c proved seqs = + if null seqs then + [] + else if length c < 2 then + let + val proved = c @ proved + val provable = + filter (fn (gamma, _) => subset atom_eq (gamma, proved)) seqs + val horn_provable = filter (fn (_, [_]) => true | _ => false) provable + val seq as (gamma, c) = hd (horn_provable @ provable) + in + Have (map single gamma, c) :: + redirect c proved (filter (curry (not o direct_sequent_eq) seq) seqs) + end + else + let + fun subsequents seqs zone = + filter (fn (gamma, _) => subset atom_eq (gamma, zone @ proved)) seqs + val zones = zones_of (length c) (map (descendants direct_graph) c) + val subseqss = map (subsequents seqs) zones + val seqs = fold (subtract direct_sequent_eq) subseqss seqs + val cases = + map2 (fn l => fn subseqs => ([l], redirect [l] proved subseqs)) + c subseqss + in s_cases cases @ redirect (succedent_of_cases cases) proved seqs end + in redirect [] axioms seqs end + +val chain_direct_proof = + let + fun chain_inf cl0 (seq as Have (cs, c)) = + if member clause_eq cs cl0 then + Hence (filter_out (curry clause_eq cl0) cs, c) + else + seq + | chain_inf _ (Cases cases) = Cases (map chain_case cases) + and chain_case (c, is) = (c, chain_proof (SOME c) is) + and chain_proof _ [] = [] + | chain_proof (SOME prev) (i :: is) = + chain_inf prev i :: chain_proof (SOME (succedent_of_inference i)) is + | chain_proof _ (i :: is) = + i :: chain_proof (SOME (succedent_of_inference i)) is + in chain_proof NONE end + +fun indent 0 = "" + | indent n = " " ^ indent (n - 1) + +fun string_of_clause [] = "\" + | string_of_clause ls = space_implode " \ " (map Atom.string_of ls) + +fun string_of_rich_sequent ch ([], c) = ch ^ " " ^ string_of_clause c + | string_of_rich_sequent ch (cs, c) = + commas (map string_of_clause cs) ^ " " ^ ch ^ " " ^ string_of_clause c + +fun string_of_case depth (c, proof) = + indent (depth + 1) ^ "[" ^ string_of_clause c ^ "]" + |> not (null proof) ? suffix ("\n" ^ string_of_subproof (depth + 1) proof) + +and string_of_inference depth (Have seq) = + indent depth ^ string_of_rich_sequent "\" seq + | string_of_inference depth (Hence seq) = + indent depth ^ string_of_rich_sequent "\" seq + | string_of_inference depth (Cases cases) = + indent depth ^ "[\n" ^ + space_implode ("\n" ^ indent depth ^ "|\n") + (map (string_of_case depth) cases) ^ "\n" ^ + indent depth ^ "]" + +and string_of_subproof depth = cat_lines o map (string_of_inference depth) + +val string_of_direct_proof = string_of_subproof 0 + +end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_reconstruct.ML --- a/src/HOL/Tools/ATP/atp_reconstruct.ML Mon Jan 23 17:40:31 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,951 +0,0 @@ -(* Title: HOL/Tools/ATP/atp_reconstruct.ML - Author: Lawrence C. Paulson, Cambridge University Computer Laboratory - Author: Claire Quigley, Cambridge University Computer Laboratory - Author: Jasmin Blanchette, TU Muenchen - -Proof reconstruction from ATP proofs. -*) - -signature ATP_RECONSTRUCT = -sig - type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term - type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula - type 'a proof = 'a ATP_Proof.proof - type locality = ATP_Translate.locality - - datatype reconstructor = - Metis of string * string | - SMT - - datatype play = - Played of reconstructor * Time.time | - Trust_Playable of reconstructor * Time.time option | - Failed_to_Play of reconstructor - - type minimize_command = string list -> string - type one_line_params = - play * string * (string * locality) list * minimize_command * int * int - type isar_params = - bool * int * string Symtab.table * (string * locality) list vector - * int Symtab.table * string proof * thm - - val metisN : string - val smtN : string - val full_typesN : string - val partial_typesN : string - val no_typesN : string - val really_full_type_enc : string - val full_type_enc : string - val partial_type_enc : string - val no_type_enc : string - val full_type_encs : string list - val partial_type_encs : string list - val metis_default_lam_trans : string - val metis_call : string -> string -> string - val string_for_reconstructor : reconstructor -> string - val used_facts_in_atp_proof : - Proof.context -> (string * locality) list vector -> string proof - -> (string * locality) list - val lam_trans_from_atp_proof : string proof -> string -> string - val is_typed_helper_used_in_atp_proof : string proof -> bool - val used_facts_in_unsound_atp_proof : - Proof.context -> (string * locality) list vector -> 'a proof - -> string list option - val unalias_type_enc : string -> string list - val one_line_proof_text : one_line_params -> string - val make_tvar : string -> typ - val make_tfree : Proof.context -> string -> typ - val term_from_atp : - Proof.context -> bool -> int Symtab.table -> typ option - -> (string, string) ho_term -> term - val prop_from_atp : - Proof.context -> bool -> int Symtab.table - -> (string, string, (string, string) ho_term) formula -> term - val isar_proof_text : - Proof.context -> bool -> isar_params -> one_line_params -> string - val proof_text : - Proof.context -> bool -> isar_params -> one_line_params -> string -end; - -structure ATP_Reconstruct : ATP_RECONSTRUCT = -struct - -open ATP_Util -open ATP_Problem -open ATP_Proof -open ATP_Translate - -structure String_Redirect = ATP_Redirect( - type key = step_name - val ord = fn ((s, _ : string list), (s', _)) => fast_string_ord (s, s') - val string_of = fst) - -open String_Redirect - -datatype reconstructor = - Metis of string * string | - SMT - -datatype play = - Played of reconstructor * Time.time | - Trust_Playable of reconstructor * Time.time option | - Failed_to_Play of reconstructor - -type minimize_command = string list -> string -type one_line_params = - play * string * (string * locality) list * minimize_command * int * int -type isar_params = - bool * int * string Symtab.table * (string * locality) list vector - * int Symtab.table * string proof * thm - -val metisN = "metis" -val smtN = "smt" - -val full_typesN = "full_types" -val partial_typesN = "partial_types" -val no_typesN = "no_types" - -val really_full_type_enc = "mono_tags" -val full_type_enc = "poly_guards_query" -val partial_type_enc = "poly_args" -val no_type_enc = "erased" - -val full_type_encs = [full_type_enc, really_full_type_enc] -val partial_type_encs = partial_type_enc :: full_type_encs - -val type_enc_aliases = - [(full_typesN, full_type_encs), - (partial_typesN, partial_type_encs), - (no_typesN, [no_type_enc])] - -fun unalias_type_enc s = - AList.lookup (op =) type_enc_aliases s |> the_default [s] - -val metis_default_lam_trans = combinatorsN - -fun metis_call type_enc lam_trans = - let - val type_enc = - case AList.find (fn (enc, encs) => enc = hd encs) type_enc_aliases - type_enc of - [alias] => alias - | _ => type_enc - val opts = [] |> type_enc <> partial_typesN ? cons type_enc - |> lam_trans <> metis_default_lam_trans ? cons lam_trans - in metisN ^ (if null opts then "" else " (" ^ commas opts ^ ")") end - -fun string_for_reconstructor (Metis (type_enc, lam_trans)) = - metis_call type_enc lam_trans - | string_for_reconstructor SMT = smtN - -fun find_first_in_list_vector vec key = - Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key - | (_, value) => value) NONE vec - -val unprefix_fact_number = space_implode "_" o tl o space_explode "_" - -fun resolve_one_named_fact fact_names s = - case try (unprefix fact_prefix) s of - SOME s' => - let val s' = s' |> unprefix_fact_number |> unascii_of in - s' |> find_first_in_list_vector fact_names |> Option.map (pair s') - end - | NONE => NONE -fun resolve_fact fact_names = map_filter (resolve_one_named_fact fact_names) -fun is_fact fact_names = not o null o resolve_fact fact_names - -fun resolve_one_named_conjecture s = - case try (unprefix conjecture_prefix) s of - SOME s' => Int.fromString s' - | NONE => NONE - -val resolve_conjecture = map_filter resolve_one_named_conjecture -val is_conjecture = not o null o resolve_conjecture - -fun is_axiom_used_in_proof pred = - exists (fn Inference ((_, ss), _, _, []) => exists pred ss | _ => false) - -val is_combinator_def = String.isPrefix (helper_prefix ^ combinator_prefix) - -val ascii_of_lam_fact_prefix = ascii_of lam_fact_prefix - -(* overapproximation (good enough) *) -fun is_lam_lifted s = - String.isPrefix fact_prefix s andalso - String.isSubstring ascii_of_lam_fact_prefix s - -fun lam_trans_from_atp_proof atp_proof default = - if is_axiom_used_in_proof is_combinator_def atp_proof then combinatorsN - else if is_axiom_used_in_proof is_lam_lifted atp_proof then lam_liftingN - else default - -val is_typed_helper_name = - String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix -fun is_typed_helper_used_in_atp_proof atp_proof = - is_axiom_used_in_proof is_typed_helper_name atp_proof - -val leo2_ext = "extcnf_equal_neg" -val isa_ext = Thm.get_name_hint @{thm ext} -val isa_short_ext = Long_Name.base_name isa_ext - -fun ext_name ctxt = - if Thm.eq_thm_prop (@{thm ext}, - singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then - isa_short_ext - else - isa_ext - -fun add_fact _ fact_names (Inference ((_, ss), _, _, [])) = - union (op =) (resolve_fact fact_names ss) - | add_fact ctxt _ (Inference (_, _, rule, _)) = - if rule = leo2_ext then insert (op =) (ext_name ctxt, General) else I - | add_fact _ _ _ = I - -fun used_facts_in_atp_proof ctxt fact_names atp_proof = - if null atp_proof then Vector.foldl (uncurry (union (op =))) [] fact_names - else fold (add_fact ctxt fact_names) atp_proof [] - -(* (quasi-)underapproximation of the truth *) -fun is_locality_global Local = false - | is_locality_global Assum = false - | is_locality_global Chained = false - | is_locality_global _ = true - -fun used_facts_in_unsound_atp_proof _ _ [] = NONE - | used_facts_in_unsound_atp_proof ctxt fact_names atp_proof = - let - val used_facts = used_facts_in_atp_proof ctxt fact_names atp_proof - in - if forall (is_locality_global o snd) used_facts andalso - not (is_axiom_used_in_proof (is_conjecture o single) atp_proof) then - SOME (map fst used_facts) - else - NONE - end - - -(** Soft-core proof reconstruction: one-liners **) - -fun string_for_label (s, num) = s ^ string_of_int num - -fun show_time NONE = "" - | show_time (SOME ext_time) = " (" ^ string_from_ext_time ext_time ^ ")" - -fun apply_on_subgoal _ 1 = "by " - | apply_on_subgoal 1 _ = "apply " - | apply_on_subgoal i n = - "prefer " ^ string_of_int i ^ " " ^ apply_on_subgoal 1 n -fun command_call name [] = - name |> not (Lexicon.is_identifier name) ? enclose "(" ")" - | command_call name args = "(" ^ name ^ " " ^ space_implode " " args ^ ")" -fun try_command_line banner time command = - banner ^ ": " ^ Markup.markup Isabelle_Markup.sendback command ^ show_time time ^ "." -fun using_labels [] = "" - | using_labels ls = - "using " ^ space_implode " " (map string_for_label ls) ^ " " -fun reconstructor_command reconstr i n (ls, ss) = - using_labels ls ^ apply_on_subgoal i n ^ - command_call (string_for_reconstructor reconstr) ss -fun minimize_line _ [] = "" - | minimize_line minimize_command ss = - case minimize_command ss of - "" => "" - | command => "\nTo minimize: " ^ Markup.markup Isabelle_Markup.sendback command ^ "." - -val split_used_facts = - List.partition (curry (op =) Chained o snd) - #> pairself (sort_distinct (string_ord o pairself fst)) - -fun one_line_proof_text (preplay, banner, used_facts, minimize_command, - subgoal, subgoal_count) = - let - val (chained, extra) = split_used_facts used_facts - val (failed, reconstr, ext_time) = - case preplay of - Played (reconstr, time) => (false, reconstr, (SOME (false, time))) - | Trust_Playable (reconstr, time) => - (false, reconstr, - case time of - NONE => NONE - | SOME time => - if time = Time.zeroTime then NONE else SOME (true, time)) - | Failed_to_Play reconstr => (true, reconstr, NONE) - val try_line = - ([], map fst extra) - |> reconstructor_command reconstr subgoal subgoal_count - |> (if failed then enclose "One-line proof reconstruction failed: " "." - else try_command_line banner ext_time) - in try_line ^ minimize_line minimize_command (map fst (extra @ chained)) end - -(** Hard-core proof reconstruction: structured Isar proofs **) - -fun forall_of v t = HOLogic.all_const (fastype_of v) $ lambda v t -fun exists_of v t = HOLogic.exists_const (fastype_of v) $ lambda v t - -fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS) -fun make_tfree ctxt w = - let val ww = "'" ^ w in - TFree (ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1))) - end - -val indent_size = 2 -val no_label = ("", ~1) - -val raw_prefix = "x" -val assum_prefix = "a" -val have_prefix = "f" - -fun raw_label_for_name (num, ss) = - case resolve_conjecture ss of - [j] => (conjecture_prefix, j) - | _ => case Int.fromString num of - SOME j => (raw_prefix, j) - | NONE => (raw_prefix ^ num, 0) - -(**** INTERPRETATION OF TSTP SYNTAX TREES ****) - -exception HO_TERM of (string, string) ho_term list -exception FORMULA of (string, string, (string, string) ho_term) formula list -exception SAME of unit - -(* Type variables are given the basic sort "HOL.type". Some will later be - constrained by information from type literals, or by type inference. *) -fun typ_from_atp ctxt (u as ATerm (a, us)) = - let val Ts = map (typ_from_atp ctxt) us in - case unprefix_and_unascii type_const_prefix a of - SOME b => Type (invert_const b, Ts) - | NONE => - if not (null us) then - raise HO_TERM [u] (* only "tconst"s have type arguments *) - else case unprefix_and_unascii tfree_prefix a of - SOME b => make_tfree ctxt b - | NONE => - (* Could be an Isabelle variable or a variable from the ATP, say "X1" - or "_5018". Sometimes variables from the ATP are indistinguishable - from Isabelle variables, which forces us to use a type parameter in - all cases. *) - (a |> perhaps (unprefix_and_unascii tvar_prefix), HOLogic.typeS) - |> Type_Infer.param 0 - end - -(* Type class literal applied to a type. Returns triple of polarity, class, - type. *) -fun type_constraint_from_term ctxt (u as ATerm (a, us)) = - case (unprefix_and_unascii class_prefix a, map (typ_from_atp ctxt) us) of - (SOME b, [T]) => (b, T) - | _ => raise HO_TERM [u] - -(* Accumulate type constraints in a formula: negative type literals. *) -fun add_var (key, z) = Vartab.map_default (key, []) (cons z) -fun add_type_constraint false (cl, TFree (a ,_)) = add_var ((a, ~1), cl) - | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl) - | add_type_constraint _ _ = I - -fun repair_variable_name f s = - let - fun subscript_name s n = s ^ nat_subscript n - val s = String.map f s - in - case space_explode "_" s of - [_] => (case take_suffix Char.isDigit (String.explode s) of - (cs1 as _ :: _, cs2 as _ :: _) => - subscript_name (String.implode cs1) - (the (Int.fromString (String.implode cs2))) - | (_, _) => s) - | [s1, s2] => (case Int.fromString s2 of - SOME n => subscript_name s1 n - | NONE => s) - | _ => s - end - -(* The number of type arguments of a constant, zero if it's monomorphic. For - (instances of) Skolem pseudoconstants, this information is encoded in the - constant name. *) -fun num_type_args thy s = - if String.isPrefix skolem_const_prefix s then - s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the - else if String.isPrefix lam_lifted_prefix s then - if String.isPrefix lam_lifted_poly_prefix s then 2 else 0 - else - (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length - -fun slack_fastype_of t = fastype_of t handle TERM _ => HOLogic.typeT - -(* First-order translation. No types are known for variables. "HOLogic.typeT" - should allow them to be inferred. *) -fun term_from_atp ctxt textual sym_tab = - let - val thy = Proof_Context.theory_of ctxt - (* For Metis, we use 1 rather than 0 because variable references in clauses - may otherwise conflict with variable constraints in the goal. At least, - type inference often fails otherwise. See also "axiom_inference" in - "Metis_Reconstruct". *) - val var_index = if textual then 0 else 1 - fun do_term extra_ts opt_T u = - case u of - ATerm (s, us) => - if String.isPrefix simple_type_prefix s then - @{const True} (* ignore TPTP type information *) - else if s = tptp_equal then - let val ts = map (do_term [] NONE) us in - if textual andalso length ts = 2 andalso - hd ts aconv List.last ts then - (* Vampire is keen on producing these. *) - @{const True} - else - list_comb (Const (@{const_name HOL.eq}, HOLogic.typeT), ts) - end - else case unprefix_and_unascii const_prefix s of - SOME s' => - let - val ((s', s''), mangled_us) = - s' |> unmangled_const |>> `invert_const - in - if s' = type_tag_name then - case mangled_us @ us of - [typ_u, term_u] => - do_term extra_ts (SOME (typ_from_atp ctxt typ_u)) term_u - | _ => raise HO_TERM us - else if s' = predicator_name then - do_term [] (SOME @{typ bool}) (hd us) - else if s' = app_op_name then - let val extra_t = do_term [] NONE (List.last us) in - do_term (extra_t :: extra_ts) - (case opt_T of - SOME T => SOME (slack_fastype_of extra_t --> T) - | NONE => NONE) - (nth us (length us - 2)) - end - else if s' = type_guard_name then - @{const True} (* ignore type predicates *) - else - let - val new_skolem = String.isPrefix new_skolem_const_prefix s'' - val num_ty_args = - length us - the_default 0 (Symtab.lookup sym_tab s) - val (type_us, term_us) = - chop num_ty_args us |>> append mangled_us - val term_ts = map (do_term [] NONE) term_us - val T = - (if not (null type_us) andalso - num_type_args thy s' = length type_us then - let val Ts = type_us |> map (typ_from_atp ctxt) in - if new_skolem then - SOME (Type_Infer.paramify_vars (tl Ts ---> hd Ts)) - else if textual then - try (Sign.const_instance thy) (s', Ts) - else - NONE - end - else - NONE) - |> (fn SOME T => T - | NONE => map slack_fastype_of term_ts ---> - (case opt_T of - SOME T => T - | NONE => HOLogic.typeT)) - val t = - if new_skolem then - Var ((new_skolem_var_name_from_const s'', var_index), T) - else - Const (unproxify_const s', T) - in list_comb (t, term_ts @ extra_ts) end - end - | NONE => (* a free or schematic variable *) - let - val term_ts = map (do_term [] NONE) us - val ts = term_ts @ extra_ts - val T = - case opt_T of - SOME T => map slack_fastype_of term_ts ---> T - | NONE => map slack_fastype_of ts ---> HOLogic.typeT - val t = - case unprefix_and_unascii fixed_var_prefix s of - SOME s => Free (s, T) - | NONE => - case unprefix_and_unascii schematic_var_prefix s of - SOME s => Var ((s, var_index), T) - | NONE => - Var ((s |> textual ? repair_variable_name Char.toLower, - var_index), T) - in list_comb (t, ts) end - in do_term [] end - -fun term_from_atom ctxt textual sym_tab pos (u as ATerm (s, _)) = - if String.isPrefix class_prefix s then - add_type_constraint pos (type_constraint_from_term ctxt u) - #> pair @{const True} - else - pair (term_from_atp ctxt textual sym_tab (SOME @{typ bool}) u) - -val combinator_table = - [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}), - (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}), - (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}), - (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}), - (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})] - -fun uncombine_term thy = - let - fun aux (t1 $ t2) = betapply (pairself aux (t1, t2)) - | aux (Abs (s, T, t')) = Abs (s, T, aux t') - | aux (t as Const (x as (s, _))) = - (case AList.lookup (op =) combinator_table s of - SOME thm => thm |> prop_of |> specialize_type thy x - |> Logic.dest_equals |> snd - | NONE => t) - | aux t = t - in aux end - -(* Update schematic type variables with detected sort constraints. It's not - totally clear whether this code is necessary. *) -fun repair_tvar_sorts (t, tvar_tab) = - let - fun do_type (Type (a, Ts)) = Type (a, map do_type Ts) - | do_type (TVar (xi, s)) = - TVar (xi, the_default s (Vartab.lookup tvar_tab xi)) - | do_type (TFree z) = TFree z - fun do_term (Const (a, T)) = Const (a, do_type T) - | do_term (Free (a, T)) = Free (a, do_type T) - | do_term (Var (xi, T)) = Var (xi, do_type T) - | do_term (t as Bound _) = t - | do_term (Abs (a, T, t)) = Abs (a, do_type T, do_term t) - | do_term (t1 $ t2) = do_term t1 $ do_term t2 - in t |> not (Vartab.is_empty tvar_tab) ? do_term end - -fun quantify_over_var quant_of var_s t = - let - val vars = [] |> Term.add_vars t |> filter (fn ((s, _), _) => s = var_s) - |> map Var - in fold_rev quant_of vars t end - -(* Interpret an ATP formula as a HOL term, extracting sort constraints as they - appear in the formula. *) -fun prop_from_atp ctxt textual sym_tab phi = - let - fun do_formula pos phi = - case phi of - AQuant (_, [], phi) => do_formula pos phi - | AQuant (q, (s, _) :: xs, phi') => - do_formula pos (AQuant (q, xs, phi')) - (* FIXME: TFF *) - #>> quantify_over_var (case q of - AForall => forall_of - | AExists => exists_of) - (s |> textual ? repair_variable_name Char.toLower) - | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not - | AConn (c, [phi1, phi2]) => - do_formula (pos |> c = AImplies ? not) phi1 - ##>> do_formula pos phi2 - #>> (case c of - AAnd => s_conj - | AOr => s_disj - | AImplies => s_imp - | AIff => s_iff - | ANot => raise Fail "impossible connective") - | AAtom tm => term_from_atom ctxt textual sym_tab pos tm - | _ => raise FORMULA [phi] - in repair_tvar_sorts (do_formula true phi Vartab.empty) end - -fun infer_formula_types ctxt = - Type.constraint HOLogic.boolT - #> Syntax.check_term - (Proof_Context.set_mode Proof_Context.mode_schematic ctxt) - -fun uncombined_etc_prop_from_atp ctxt textual sym_tab = - let val thy = Proof_Context.theory_of ctxt in - prop_from_atp ctxt textual sym_tab - #> textual ? uncombine_term thy #> infer_formula_types ctxt - end - -(**** Translation of TSTP files to Isar proofs ****) - -fun unvarify_term (Var ((s, 0), T)) = Free (s, T) - | unvarify_term t = raise TERM ("unvarify_term: non-Var", [t]) - -fun decode_line sym_tab (Definition (name, phi1, phi2)) ctxt = - let - val thy = Proof_Context.theory_of ctxt - val t1 = prop_from_atp ctxt true sym_tab phi1 - val vars = snd (strip_comb t1) - val frees = map unvarify_term vars - val unvarify_args = subst_atomic (vars ~~ frees) - val t2 = prop_from_atp ctxt true sym_tab phi2 - val (t1, t2) = - HOLogic.eq_const HOLogic.typeT $ t1 $ t2 - |> unvarify_args |> uncombine_term thy |> infer_formula_types ctxt - |> HOLogic.dest_eq - in - (Definition (name, t1, t2), - fold Variable.declare_term (maps Misc_Legacy.term_frees [t1, t2]) ctxt) - end - | decode_line sym_tab (Inference (name, u, rule, deps)) ctxt = - let val t = u |> uncombined_etc_prop_from_atp ctxt true sym_tab in - (Inference (name, t, rule, deps), - fold Variable.declare_term (Misc_Legacy.term_frees t) ctxt) - end -fun decode_lines ctxt sym_tab lines = - fst (fold_map (decode_line sym_tab) lines ctxt) - -fun is_same_inference _ (Definition _) = false - | is_same_inference t (Inference (_, t', _, _)) = t aconv t' - -(* No "real" literals means only type information (tfree_tcs, clsrel, or - clsarity). *) -val is_only_type_information = curry (op aconv) @{term True} - -fun replace_one_dependency (old, new) dep = - if is_same_atp_step dep old then new else [dep] -fun replace_dependencies_in_line _ (line as Definition _) = line - | replace_dependencies_in_line p (Inference (name, t, rule, deps)) = - Inference (name, t, rule, - fold (union (op =) o replace_one_dependency p) deps []) - -(* Discard facts; consolidate adjacent lines that prove the same formula, since - they differ only in type information.*) -fun add_line _ (line as Definition _) lines = line :: lines - | add_line fact_names (Inference (name as (_, ss), t, rule, [])) lines = - (* No dependencies: fact, conjecture, or (for Vampire) internal facts or - definitions. *) - if is_fact fact_names ss then - (* Facts are not proof lines. *) - if is_only_type_information t then - map (replace_dependencies_in_line (name, [])) lines - (* Is there a repetition? If so, replace later line by earlier one. *) - else case take_prefix (not o is_same_inference t) lines of - (_, []) => lines (* no repetition of proof line *) - | (pre, Inference (name', _, _, _) :: post) => - pre @ map (replace_dependencies_in_line (name', [name])) post - | _ => raise Fail "unexpected inference" - else if is_conjecture ss then - Inference (name, s_not t, rule, []) :: lines - else - map (replace_dependencies_in_line (name, [])) lines - | add_line _ (Inference (name, t, rule, deps)) lines = - (* Type information will be deleted later; skip repetition test. *) - if is_only_type_information t then - Inference (name, t, rule, deps) :: lines - (* Is there a repetition? If so, replace later line by earlier one. *) - else case take_prefix (not o is_same_inference t) lines of - (* FIXME: Doesn't this code risk conflating proofs involving different - types? *) - (_, []) => Inference (name, t, rule, deps) :: lines - | (pre, Inference (name', t', rule, _) :: post) => - Inference (name, t', rule, deps) :: - pre @ map (replace_dependencies_in_line (name', [name])) post - | _ => raise Fail "unexpected inference" - -(* Recursively delete empty lines (type information) from the proof. *) -fun add_nontrivial_line (line as Inference (name, t, _, [])) lines = - if is_only_type_information t then delete_dependency name lines - else line :: lines - | add_nontrivial_line line lines = line :: lines -and delete_dependency name lines = - fold_rev add_nontrivial_line - (map (replace_dependencies_in_line (name, [])) lines) [] - -(* ATPs sometimes reuse free variable names in the strangest ways. Removing - offending lines often does the trick. *) -fun is_bad_free frees (Free x) = not (member (op =) frees x) - | is_bad_free _ _ = false - -fun add_desired_line _ _ _ (line as Definition (name, _, _)) (j, lines) = - (j, line :: map (replace_dependencies_in_line (name, [])) lines) - | add_desired_line isar_shrink_factor fact_names frees - (Inference (name as (_, ss), t, rule, deps)) (j, lines) = - (j + 1, - if is_fact fact_names ss orelse - is_conjecture ss orelse - (* the last line must be kept *) - j = 0 orelse - (not (is_only_type_information t) andalso - null (Term.add_tvars t []) andalso - not (exists_subterm (is_bad_free frees) t) andalso - length deps >= 2 andalso j mod isar_shrink_factor = 0 andalso - (* kill next to last line, which usually results in a trivial step *) - j <> 1) then - Inference (name, t, rule, deps) :: lines (* keep line *) - else - map (replace_dependencies_in_line (name, deps)) lines) (* drop line *) - -(** Isar proof construction and manipulation **) - -type label = string * int -type facts = label list * string list - -datatype isar_qualifier = Show | Then | Moreover | Ultimately - -datatype isar_step = - Fix of (string * typ) list | - Let of term * term | - Assume of label * term | - Prove of isar_qualifier list * label * term * byline -and byline = - By_Metis of facts | - Case_Split of isar_step list list * facts - -fun add_fact_from_dependency fact_names (name as (_, ss)) = - if is_fact fact_names ss then - apsnd (union (op =) (map fst (resolve_fact fact_names ss))) - else - apfst (insert (op =) (raw_label_for_name name)) - -fun repair_name "$true" = "c_True" - | repair_name "$false" = "c_False" - | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *) - | repair_name s = - if is_tptp_equal s orelse - (* seen in Vampire proofs *) - (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then - tptp_equal - else - s - -(* FIXME: Still needed? Try with SPASS proofs perhaps. *) -val kill_duplicate_assumptions_in_proof = - let - fun relabel_facts subst = - apfst (map (fn l => AList.lookup (op =) subst l |> the_default l)) - fun do_step (step as Assume (l, t)) (proof, subst, assums) = - (case AList.lookup (op aconv) assums t of - SOME l' => (proof, (l, l') :: subst, assums) - | NONE => (step :: proof, subst, (t, l) :: assums)) - | do_step (Prove (qs, l, t, by)) (proof, subst, assums) = - (Prove (qs, l, t, - case by of - By_Metis facts => By_Metis (relabel_facts subst facts) - | Case_Split (proofs, facts) => - Case_Split (map do_proof proofs, - relabel_facts subst facts)) :: - proof, subst, assums) - | do_step step (proof, subst, assums) = (step :: proof, subst, assums) - and do_proof proof = fold do_step proof ([], [], []) |> #1 |> rev - in do_proof end - -fun used_labels_of_step (Prove (_, _, _, by)) = - (case by of - By_Metis (ls, _) => ls - | Case_Split (proofs, (ls, _)) => - fold (union (op =) o used_labels_of) proofs ls) - | used_labels_of_step _ = [] -and used_labels_of proof = fold (union (op =) o used_labels_of_step) proof [] - -fun kill_useless_labels_in_proof proof = - let - val used_ls = used_labels_of proof - fun do_label l = if member (op =) used_ls l then l else no_label - fun do_step (Assume (l, t)) = Assume (do_label l, t) - | do_step (Prove (qs, l, t, by)) = - Prove (qs, do_label l, t, - case by of - Case_Split (proofs, facts) => - Case_Split (map (map do_step) proofs, facts) - | _ => by) - | do_step step = step - in map do_step proof end - -fun prefix_for_depth n = replicate_string (n + 1) - -val relabel_proof = - let - fun aux _ _ _ [] = [] - | aux subst depth (next_assum, next_fact) (Assume (l, t) :: proof) = - if l = no_label then - Assume (l, t) :: aux subst depth (next_assum, next_fact) proof - else - let val l' = (prefix_for_depth depth assum_prefix, next_assum) in - Assume (l', t) :: - aux ((l, l') :: subst) depth (next_assum + 1, next_fact) proof - end - | aux subst depth (next_assum, next_fact) - (Prove (qs, l, t, by) :: proof) = - let - val (l', subst, next_fact) = - if l = no_label then - (l, subst, next_fact) - else - let - val l' = (prefix_for_depth depth have_prefix, next_fact) - in (l', (l, l') :: subst, next_fact + 1) end - val relabel_facts = - apfst (maps (the_list o AList.lookup (op =) subst)) - val by = - case by of - By_Metis facts => By_Metis (relabel_facts facts) - | Case_Split (proofs, facts) => - Case_Split (map (aux subst (depth + 1) (1, 1)) proofs, - relabel_facts facts) - in - Prove (qs, l', t, by) :: aux subst depth (next_assum, next_fact) proof - end - | aux subst depth nextp (step :: proof) = - step :: aux subst depth nextp proof - in aux [] 0 (1, 1) end - -fun string_for_proof ctxt0 type_enc lam_trans i n = - let - val ctxt = - ctxt0 |> Config.put show_free_types false - |> Config.put show_types true - |> Config.put show_sorts true - fun fix_print_mode f x = - Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN) - (print_mode_value ())) f x - fun do_indent ind = replicate_string (ind * indent_size) " " - fun do_free (s, T) = - maybe_quote s ^ " :: " ^ - maybe_quote (fix_print_mode (Syntax.string_of_typ ctxt) T) - fun do_label l = if l = no_label then "" else string_for_label l ^ ": " - fun do_have qs = - (if member (op =) qs Moreover then "moreover " else "") ^ - (if member (op =) qs Ultimately then "ultimately " else "") ^ - (if member (op =) qs Then then - if member (op =) qs Show then "thus" else "hence" - else - if member (op =) qs Show then "show" else "have") - val do_term = maybe_quote o fix_print_mode (Syntax.string_of_term ctxt) - val reconstr = Metis (type_enc, lam_trans) - fun do_facts (ls, ss) = - reconstructor_command reconstr 1 1 - (ls |> sort_distinct (prod_ord string_ord int_ord), - ss |> sort_distinct string_ord) - and do_step ind (Fix xs) = - do_indent ind ^ "fix " ^ space_implode " and " (map do_free xs) ^ "\n" - | do_step ind (Let (t1, t2)) = - do_indent ind ^ "let " ^ do_term t1 ^ " = " ^ do_term t2 ^ "\n" - | do_step ind (Assume (l, t)) = - do_indent ind ^ "assume " ^ do_label l ^ do_term t ^ "\n" - | do_step ind (Prove (qs, l, t, By_Metis facts)) = - do_indent ind ^ do_have qs ^ " " ^ - do_label l ^ do_term t ^ " " ^ do_facts facts ^ "\n" - | do_step ind (Prove (qs, l, t, Case_Split (proofs, facts))) = - implode (map (prefix (do_indent ind ^ "moreover\n") o do_block ind) - proofs) ^ - do_indent ind ^ do_have qs ^ " " ^ do_label l ^ do_term t ^ " " ^ - do_facts facts ^ "\n" - and do_steps prefix suffix ind steps = - let val s = implode (map (do_step ind) steps) in - replicate_string (ind * indent_size - size prefix) " " ^ prefix ^ - String.extract (s, ind * indent_size, - SOME (size s - ind * indent_size - 1)) ^ - suffix ^ "\n" - end - and do_block ind proof = do_steps "{ " " }" (ind + 1) proof - (* One-step proofs are pointless; better use the Metis one-liner - directly. *) - and do_proof [Prove (_, _, _, By_Metis _)] = "" - | do_proof proof = - (if i <> 1 then "prefer " ^ string_of_int i ^ "\n" else "") ^ - do_indent 0 ^ "proof -\n" ^ do_steps "" "" 1 proof ^ do_indent 0 ^ - (if n <> 1 then "next" else "qed") - in do_proof end - -fun isar_proof_text ctxt isar_proof_requested - (debug, isar_shrink_factor, pool, fact_names, sym_tab, atp_proof, goal) - (one_line_params as (_, _, _, _, subgoal, subgoal_count)) = - let - val isar_shrink_factor = - (if isar_proof_requested then 1 else 2) * isar_shrink_factor - val (params, hyp_ts, concl_t) = strip_subgoal ctxt goal subgoal - val frees = fold Term.add_frees (concl_t :: hyp_ts) [] - val one_line_proof = one_line_proof_text one_line_params - val type_enc = - if is_typed_helper_used_in_atp_proof atp_proof then full_typesN - else partial_typesN - val lam_trans = lam_trans_from_atp_proof atp_proof metis_default_lam_trans - - fun isar_proof_of () = - let - val atp_proof = - atp_proof - |> clean_up_atp_proof_dependencies - |> nasty_atp_proof pool - |> map_term_names_in_atp_proof repair_name - |> decode_lines ctxt sym_tab - |> rpair [] |-> fold_rev (add_line fact_names) - |> rpair [] |-> fold_rev add_nontrivial_line - |> rpair (0, []) - |-> fold_rev (add_desired_line isar_shrink_factor fact_names frees) - |> snd - val conj_name = conjecture_prefix ^ string_of_int (length hyp_ts) - val conjs = - atp_proof - |> map_filter (fn Inference (name as (_, ss), _, _, []) => - if member (op =) ss conj_name then SOME name else NONE - | _ => NONE) - fun dep_of_step (Definition _) = NONE - | dep_of_step (Inference (name, _, _, from)) = SOME (from, name) - val ref_graph = atp_proof |> map_filter dep_of_step |> make_ref_graph - val axioms = axioms_of_ref_graph ref_graph conjs - val tainted = tainted_atoms_of_ref_graph ref_graph conjs - val props = - Symtab.empty - |> fold (fn Definition _ => I (* FIXME *) - | Inference ((s, _), t, _, _) => - Symtab.update_new (s, - t |> member (op = o apsnd fst) tainted s ? s_not)) - atp_proof - (* FIXME: add "fold_rev forall_of (map Var (Term.add_vars t []))"? *) - fun prop_of_clause c = - fold (curry s_disj) (map_filter (Symtab.lookup props o fst) c) - @{term False} - fun label_of_clause c = (space_implode "___" (map fst c), 0) - fun maybe_show outer c = - (outer andalso length c = 1 andalso subset (op =) (c, conjs)) - ? cons Show - fun do_have outer qs (gamma, c) = - Prove (maybe_show outer c qs, label_of_clause c, prop_of_clause c, - By_Metis (fold (add_fact_from_dependency fact_names - o the_single) gamma ([], []))) - fun do_inf outer (Have z) = do_have outer [] z - | do_inf outer (Hence z) = do_have outer [Then] z - | do_inf outer (Cases cases) = - let val c = succedent_of_cases cases in - Prove (maybe_show outer c [Ultimately], label_of_clause c, - prop_of_clause c, - Case_Split (map (do_case false) cases, ([], []))) - end - and do_case outer (c, infs) = - Assume (label_of_clause c, prop_of_clause c) :: - map (do_inf outer) infs - val isar_proof = - (if null params then [] else [Fix params]) @ - (ref_graph - |> redirect_graph axioms tainted - |> chain_direct_proof - |> map (do_inf true) - |> kill_duplicate_assumptions_in_proof - |> kill_useless_labels_in_proof - |> relabel_proof) - |> string_for_proof ctxt type_enc lam_trans subgoal subgoal_count - in - case isar_proof of - "" => - if isar_proof_requested then - "\nNo structured proof available (proof too short)." - else - "" - | _ => - "\n\n" ^ (if isar_proof_requested then "Structured proof" - else "Perhaps this will work") ^ - ":\n" ^ Markup.markup Isabelle_Markup.sendback isar_proof - end - val isar_proof = - if debug then - isar_proof_of () - else case try isar_proof_of () of - SOME s => s - | NONE => if isar_proof_requested then - "\nWarning: The Isar proof construction failed." - else - "" - in one_line_proof ^ isar_proof end - -fun proof_text ctxt isar_proof isar_params - (one_line_params as (preplay, _, _, _, _, _)) = - (if case preplay of Failed_to_Play _ => true | _ => isar_proof then - isar_proof_text ctxt isar_proof isar_params - else - one_line_proof_text) one_line_params - -end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_redirect.ML --- a/src/HOL/Tools/ATP/atp_redirect.ML Mon Jan 23 17:40:31 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,223 +0,0 @@ -(* Title: HOL/Tools/ATP/atp_redirect.ML - Author: Jasmin Blanchette, TU Muenchen - -Transformation of a proof by contradiction into a direct proof. -*) - -signature ATP_ATOM = -sig - type key - val ord : key * key -> order - val string_of : key -> string -end; - -signature ATP_REDIRECT = -sig - type atom - - structure Atom_Graph : GRAPH - - type ref_sequent = atom list * atom - type ref_graph = unit Atom_Graph.T - - type clause = atom list - type direct_sequent = atom list * clause - type direct_graph = unit Atom_Graph.T - - type rich_sequent = clause list * clause - - datatype direct_inference = - Have of rich_sequent | - Hence of rich_sequent | - Cases of (clause * direct_inference list) list - - type direct_proof = direct_inference list - - val make_ref_graph : (atom list * atom) list -> ref_graph - val axioms_of_ref_graph : ref_graph -> atom list -> atom list - val tainted_atoms_of_ref_graph : ref_graph -> atom list -> atom list - val sequents_of_ref_graph : ref_graph -> ref_sequent list - val redirect_sequent : atom list -> atom -> ref_sequent -> direct_sequent - val direct_graph : direct_sequent list -> direct_graph - val redirect_graph : atom list -> atom list -> ref_graph -> direct_proof - val succedent_of_cases : (clause * direct_inference list) list -> clause - val chain_direct_proof : direct_proof -> direct_proof - val string_of_direct_proof : direct_proof -> string -end; - -functor ATP_Redirect(Atom : ATP_ATOM): ATP_REDIRECT = -struct - -type atom = Atom.key - -structure Atom_Graph = Graph(Atom) - -type ref_sequent = atom list * atom -type ref_graph = unit Atom_Graph.T - -type clause = atom list -type direct_sequent = atom list * clause -type direct_graph = unit Atom_Graph.T - -type rich_sequent = clause list * clause - -datatype direct_inference = - Have of rich_sequent | - Hence of rich_sequent | - Cases of (clause * direct_inference list) list - -type direct_proof = direct_inference list - -fun atom_eq p = (Atom.ord p = EQUAL) -fun clause_eq (c, d) = (length c = length d andalso forall atom_eq (c ~~ d)) -fun direct_sequent_eq ((gamma, c), (delta, d)) = - clause_eq (gamma, delta) andalso clause_eq (c, d) - -fun make_ref_graph infers = - let - fun add_edge to from = - Atom_Graph.default_node (from, ()) - #> Atom_Graph.default_node (to, ()) - #> Atom_Graph.add_edge_acyclic (from, to) - fun add_infer (froms, to) = fold (add_edge to) froms - in Atom_Graph.empty |> fold add_infer infers end - -fun axioms_of_ref_graph ref_graph conjs = - subtract atom_eq conjs (Atom_Graph.minimals ref_graph) -fun tainted_atoms_of_ref_graph ref_graph = Atom_Graph.all_succs ref_graph - -fun sequents_of_ref_graph ref_graph = - map (`(Atom_Graph.immediate_preds ref_graph)) - (filter_out (Atom_Graph.is_minimal ref_graph) (Atom_Graph.keys ref_graph)) - -fun redirect_sequent tainted bot (gamma, c) = - if member atom_eq tainted c then - gamma |> List.partition (not o member atom_eq tainted) - |>> not (atom_eq (c, bot)) ? cons c - else - (gamma, [c]) - -fun direct_graph seqs = - let - fun add_edge from to = - Atom_Graph.default_node (from, ()) - #> Atom_Graph.default_node (to, ()) - #> Atom_Graph.add_edge_acyclic (from, to) - fun add_seq (gamma, c) = fold (fn l => fold (add_edge l) c) gamma - in Atom_Graph.empty |> fold add_seq seqs end - -fun disj cs = fold (union atom_eq) cs [] |> sort Atom.ord - -fun succedent_of_inference (Have (_, c)) = c - | succedent_of_inference (Hence (_, c)) = c - | succedent_of_inference (Cases cases) = succedent_of_cases cases -and succedent_of_case (c, []) = c - | succedent_of_case (_, infs) = succedent_of_inference (List.last infs) -and succedent_of_cases cases = disj (map succedent_of_case cases) - -fun dest_Have (Have z) = z - | dest_Have _ = raise Fail "non-Have" - -fun enrich_Have nontrivs trivs (cs, c) = - (cs |> map (fn c => if member clause_eq nontrivs c then disj (c :: trivs) - else c), - disj (c :: trivs)) - |> Have - -fun s_cases cases = - case cases |> List.partition (null o snd) of - (trivs, nontrivs as [(nontriv0, proof)]) => - if forall (can dest_Have) proof then - let val seqs = proof |> map dest_Have in - seqs |> map (enrich_Have (nontriv0 :: map snd seqs) (map fst trivs)) - end - else - [Cases nontrivs] - | (_, nontrivs) => [Cases nontrivs] - -fun descendants direct_graph = - these o try (Atom_Graph.all_succs direct_graph) o single - -fun zones_of 0 _ = [] - | zones_of n (bs :: bss) = - (fold (subtract atom_eq) bss) bs :: zones_of (n - 1) (bss @ [bs]) - -fun redirect_graph axioms tainted ref_graph = - let - val [bot] = Atom_Graph.maximals ref_graph - val seqs = - map (redirect_sequent tainted bot) (sequents_of_ref_graph ref_graph) - val direct_graph = direct_graph seqs - - fun redirect c proved seqs = - if null seqs then - [] - else if length c < 2 then - let - val proved = c @ proved - val provable = - filter (fn (gamma, _) => subset atom_eq (gamma, proved)) seqs - val horn_provable = filter (fn (_, [_]) => true | _ => false) provable - val seq as (gamma, c) = hd (horn_provable @ provable) - in - Have (map single gamma, c) :: - redirect c proved (filter (curry (not o direct_sequent_eq) seq) seqs) - end - else - let - fun subsequents seqs zone = - filter (fn (gamma, _) => subset atom_eq (gamma, zone @ proved)) seqs - val zones = zones_of (length c) (map (descendants direct_graph) c) - val subseqss = map (subsequents seqs) zones - val seqs = fold (subtract direct_sequent_eq) subseqss seqs - val cases = - map2 (fn l => fn subseqs => ([l], redirect [l] proved subseqs)) - c subseqss - in s_cases cases @ redirect (succedent_of_cases cases) proved seqs end - in redirect [] axioms seqs end - -val chain_direct_proof = - let - fun chain_inf cl0 (seq as Have (cs, c)) = - if member clause_eq cs cl0 then - Hence (filter_out (curry clause_eq cl0) cs, c) - else - seq - | chain_inf _ (Cases cases) = Cases (map chain_case cases) - and chain_case (c, is) = (c, chain_proof (SOME c) is) - and chain_proof _ [] = [] - | chain_proof (SOME prev) (i :: is) = - chain_inf prev i :: chain_proof (SOME (succedent_of_inference i)) is - | chain_proof _ (i :: is) = - i :: chain_proof (SOME (succedent_of_inference i)) is - in chain_proof NONE end - -fun indent 0 = "" - | indent n = " " ^ indent (n - 1) - -fun string_of_clause [] = "\" - | string_of_clause ls = space_implode " \ " (map Atom.string_of ls) - -fun string_of_rich_sequent ch ([], c) = ch ^ " " ^ string_of_clause c - | string_of_rich_sequent ch (cs, c) = - commas (map string_of_clause cs) ^ " " ^ ch ^ " " ^ string_of_clause c - -fun string_of_case depth (c, proof) = - indent (depth + 1) ^ "[" ^ string_of_clause c ^ "]" - |> not (null proof) ? suffix ("\n" ^ string_of_subproof (depth + 1) proof) - -and string_of_inference depth (Have seq) = - indent depth ^ string_of_rich_sequent "\" seq - | string_of_inference depth (Hence seq) = - indent depth ^ string_of_rich_sequent "\" seq - | string_of_inference depth (Cases cases) = - indent depth ^ "[\n" ^ - space_implode ("\n" ^ indent depth ^ "|\n") - (map (string_of_case depth) cases) ^ "\n" ^ - indent depth ^ "]" - -and string_of_subproof depth = cat_lines o map (string_of_inference depth) - -val string_of_direct_proof = string_of_subproof 0 - -end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_systems.ML --- a/src/HOL/Tools/ATP/atp_systems.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/ATP/atp_systems.ML Mon Jan 23 17:40:32 2012 +0100 @@ -71,7 +71,7 @@ open ATP_Problem open ATP_Proof -open ATP_Translate +open ATP_Problem_Generate (* ATP configuration *) diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/ATP/atp_translate.ML --- a/src/HOL/Tools/ATP/atp_translate.ML Mon Jan 23 17:40:31 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2557 +0,0 @@ -(* Title: HOL/Tools/ATP/atp_translate.ML - Author: Fabian Immler, TU Muenchen - Author: Makarius - Author: Jasmin Blanchette, TU Muenchen - -Translation of HOL to FOL for Metis and Sledgehammer. -*) - -signature ATP_TRANSLATE = -sig - type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term - type connective = ATP_Problem.connective - type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula - type atp_format = ATP_Problem.atp_format - type formula_kind = ATP_Problem.formula_kind - type 'a problem = 'a ATP_Problem.problem - - datatype locality = - General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained - - datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic - datatype strictness = Strict | Non_Strict - datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars - datatype type_level = - All_Types | - Noninf_Nonmono_Types of strictness * granularity | - Fin_Nonmono_Types of granularity | - Const_Arg_Types | - No_Types - type type_enc - - val type_tag_idempotence : bool Config.T - val type_tag_arguments : bool Config.T - val no_lamsN : string - val hide_lamsN : string - val lam_liftingN : string - val combinatorsN : string - val hybrid_lamsN : string - val keep_lamsN : string - val schematic_var_prefix : string - val fixed_var_prefix : string - val tvar_prefix : string - val tfree_prefix : string - val const_prefix : string - val type_const_prefix : string - val class_prefix : string - val lam_lifted_prefix : string - val lam_lifted_mono_prefix : string - val lam_lifted_poly_prefix : string - val skolem_const_prefix : string - val old_skolem_const_prefix : string - val new_skolem_const_prefix : string - val combinator_prefix : string - val type_decl_prefix : string - val sym_decl_prefix : string - val guards_sym_formula_prefix : string - val tags_sym_formula_prefix : string - val fact_prefix : string - val conjecture_prefix : string - val helper_prefix : string - val class_rel_clause_prefix : string - val arity_clause_prefix : string - val tfree_clause_prefix : string - val lam_fact_prefix : string - val typed_helper_suffix : string - val untyped_helper_suffix : string - val type_tag_idempotence_helper_name : string - val predicator_name : string - val app_op_name : string - val type_guard_name : string - val type_tag_name : string - val simple_type_prefix : string - val prefixed_predicator_name : string - val prefixed_app_op_name : string - val prefixed_type_tag_name : string - val ascii_of : string -> string - val unascii_of : string -> string - val unprefix_and_unascii : string -> string -> string option - val proxy_table : (string * (string * (thm * (string * string)))) list - val proxify_const : string -> (string * string) option - val invert_const : string -> string - val unproxify_const : string -> string - val new_skolem_var_name_from_const : string -> string - val atp_irrelevant_consts : string list - val atp_schematic_consts_of : term -> typ list Symtab.table - val is_type_enc_higher_order : type_enc -> bool - val polymorphism_of_type_enc : type_enc -> polymorphism - val level_of_type_enc : type_enc -> type_level - val is_type_enc_quasi_sound : type_enc -> bool - val is_type_enc_fairly_sound : type_enc -> bool - val type_enc_from_string : strictness -> string -> type_enc - val adjust_type_enc : atp_format -> type_enc -> type_enc - val mk_aconns : - connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula - val unmangled_const : string -> string * (string, 'b) ho_term list - val unmangled_const_name : string -> string - val helper_table : ((string * bool) * thm list) list - val trans_lams_from_string : - Proof.context -> type_enc -> string -> term list -> term list * term list - val factsN : string - val prepare_atp_problem : - Proof.context -> atp_format -> formula_kind -> formula_kind -> type_enc - -> bool -> string -> bool -> bool -> term list -> term - -> ((string * locality) * term) list - -> string problem * string Symtab.table * (string * locality) list vector - * (string * term) list * int Symtab.table - val atp_problem_weights : string problem -> (string * real) list -end; - -structure ATP_Translate : ATP_TRANSLATE = -struct - -open ATP_Util -open ATP_Problem - -type name = string * string - -val type_tag_idempotence = - Attrib.setup_config_bool @{binding atp_type_tag_idempotence} (K false) -val type_tag_arguments = - Attrib.setup_config_bool @{binding atp_type_tag_arguments} (K false) - -val no_lamsN = "no_lams" (* used internally; undocumented *) -val hide_lamsN = "hide_lams" -val lam_liftingN = "lam_lifting" -val combinatorsN = "combinators" -val hybrid_lamsN = "hybrid_lams" -val keep_lamsN = "keep_lams" - -(* It's still unclear whether all TFF1 implementations will support type - signatures such as "!>[A : $tType] : $o", with ghost type variables. *) -val avoid_first_order_ghost_type_vars = false - -val bound_var_prefix = "B_" -val all_bound_var_prefix = "BA_" -val exist_bound_var_prefix = "BE_" -val schematic_var_prefix = "V_" -val fixed_var_prefix = "v_" -val tvar_prefix = "T_" -val tfree_prefix = "t_" -val const_prefix = "c_" -val type_const_prefix = "tc_" -val simple_type_prefix = "s_" -val class_prefix = "cl_" - -(* Freshness almost guaranteed! *) -val atp_weak_prefix = "ATP:" - -val lam_lifted_prefix = atp_weak_prefix ^ "Lam" -val lam_lifted_mono_prefix = lam_lifted_prefix ^ "m" -val lam_lifted_poly_prefix = lam_lifted_prefix ^ "p" - -val skolem_const_prefix = "ATP" ^ Long_Name.separator ^ "Sko" -val old_skolem_const_prefix = skolem_const_prefix ^ "o" -val new_skolem_const_prefix = skolem_const_prefix ^ "n" - -val combinator_prefix = "COMB" - -val type_decl_prefix = "ty_" -val sym_decl_prefix = "sy_" -val guards_sym_formula_prefix = "gsy_" -val tags_sym_formula_prefix = "tsy_" -val fact_prefix = "fact_" -val conjecture_prefix = "conj_" -val helper_prefix = "help_" -val class_rel_clause_prefix = "clar_" -val arity_clause_prefix = "arity_" -val tfree_clause_prefix = "tfree_" - -val lam_fact_prefix = "ATP.lambda_" -val typed_helper_suffix = "_T" -val untyped_helper_suffix = "_U" -val type_tag_idempotence_helper_name = helper_prefix ^ "ti_idem" - -val predicator_name = "pp" -val app_op_name = "aa" -val type_guard_name = "gg" -val type_tag_name = "tt" - -val prefixed_predicator_name = const_prefix ^ predicator_name -val prefixed_app_op_name = const_prefix ^ app_op_name -val prefixed_type_tag_name = const_prefix ^ type_tag_name - -(*Escaping of special characters. - Alphanumeric characters are left unchanged. - The character _ goes to __ - Characters in the range ASCII space to / go to _A to _P, respectively. - Other characters go to _nnn where nnn is the decimal ASCII code.*) -val upper_a_minus_space = Char.ord #"A" - Char.ord #" " - -fun stringN_of_int 0 _ = "" - | stringN_of_int k n = - stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10) - -fun ascii_of_char c = - if Char.isAlphaNum c then - String.str c - else if c = #"_" then - "__" - else if #" " <= c andalso c <= #"/" then - "_" ^ String.str (Char.chr (Char.ord c + upper_a_minus_space)) - else - (* fixed width, in case more digits follow *) - "_" ^ stringN_of_int 3 (Char.ord c) - -val ascii_of = String.translate ascii_of_char - -(** Remove ASCII armoring from names in proof files **) - -(* We don't raise error exceptions because this code can run inside a worker - thread. Also, the errors are impossible. *) -val unascii_of = - let - fun un rcs [] = String.implode(rev rcs) - | un rcs [#"_"] = un (#"_" :: rcs) [] (* ERROR *) - (* Three types of _ escapes: __, _A to _P, _nnn *) - | un rcs (#"_" :: #"_" :: cs) = un (#"_" :: rcs) cs - | un rcs (#"_" :: c :: cs) = - if #"A" <= c andalso c<= #"P" then - (* translation of #" " to #"/" *) - un (Char.chr (Char.ord c - upper_a_minus_space) :: rcs) cs - else - let val digits = List.take (c :: cs, 3) handle General.Subscript => [] in - case Int.fromString (String.implode digits) of - SOME n => un (Char.chr n :: rcs) (List.drop (cs, 2)) - | NONE => un (c :: #"_" :: rcs) cs (* ERROR *) - end - | un rcs (c :: cs) = un (c :: rcs) cs - in un [] o String.explode end - -(* If string s has the prefix s1, return the result of deleting it, - un-ASCII'd. *) -fun unprefix_and_unascii s1 s = - if String.isPrefix s1 s then - SOME (unascii_of (String.extract (s, size s1, NONE))) - else - NONE - -val proxy_table = - [("c_False", (@{const_name False}, (@{thm fFalse_def}, - ("fFalse", @{const_name ATP.fFalse})))), - ("c_True", (@{const_name True}, (@{thm fTrue_def}, - ("fTrue", @{const_name ATP.fTrue})))), - ("c_Not", (@{const_name Not}, (@{thm fNot_def}, - ("fNot", @{const_name ATP.fNot})))), - ("c_conj", (@{const_name conj}, (@{thm fconj_def}, - ("fconj", @{const_name ATP.fconj})))), - ("c_disj", (@{const_name disj}, (@{thm fdisj_def}, - ("fdisj", @{const_name ATP.fdisj})))), - ("c_implies", (@{const_name implies}, (@{thm fimplies_def}, - ("fimplies", @{const_name ATP.fimplies})))), - ("equal", (@{const_name HOL.eq}, (@{thm fequal_def}, - ("fequal", @{const_name ATP.fequal})))), - ("c_All", (@{const_name All}, (@{thm fAll_def}, - ("fAll", @{const_name ATP.fAll})))), - ("c_Ex", (@{const_name Ex}, (@{thm fEx_def}, - ("fEx", @{const_name ATP.fEx}))))] - -val proxify_const = AList.lookup (op =) proxy_table #> Option.map (snd o snd) - -(* Readable names for the more common symbolic functions. Do not mess with the - table unless you know what you are doing. *) -val const_trans_table = - [(@{type_name Product_Type.prod}, "prod"), - (@{type_name Sum_Type.sum}, "sum"), - (@{const_name False}, "False"), - (@{const_name True}, "True"), - (@{const_name Not}, "Not"), - (@{const_name conj}, "conj"), - (@{const_name disj}, "disj"), - (@{const_name implies}, "implies"), - (@{const_name HOL.eq}, "equal"), - (@{const_name All}, "All"), - (@{const_name Ex}, "Ex"), - (@{const_name If}, "If"), - (@{const_name Set.member}, "member"), - (@{const_name Meson.COMBI}, combinator_prefix ^ "I"), - (@{const_name Meson.COMBK}, combinator_prefix ^ "K"), - (@{const_name Meson.COMBB}, combinator_prefix ^ "B"), - (@{const_name Meson.COMBC}, combinator_prefix ^ "C"), - (@{const_name Meson.COMBS}, combinator_prefix ^ "S")] - |> Symtab.make - |> fold (Symtab.update o swap o snd o snd o snd) proxy_table - -(* Invert the table of translations between Isabelle and ATPs. *) -val const_trans_table_inv = - const_trans_table |> Symtab.dest |> map swap |> Symtab.make -val const_trans_table_unprox = - Symtab.empty - |> fold (fn (_, (isa, (_, (_, atp)))) => Symtab.update (atp, isa)) proxy_table - -val invert_const = perhaps (Symtab.lookup const_trans_table_inv) -val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox) - -fun lookup_const c = - case Symtab.lookup const_trans_table c of - SOME c' => c' - | NONE => ascii_of c - -fun ascii_of_indexname (v, 0) = ascii_of v - | ascii_of_indexname (v, i) = ascii_of v ^ "_" ^ string_of_int i - -fun make_bound_var x = bound_var_prefix ^ ascii_of x -fun make_all_bound_var x = all_bound_var_prefix ^ ascii_of x -fun make_exist_bound_var x = exist_bound_var_prefix ^ ascii_of x -fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v -fun make_fixed_var x = fixed_var_prefix ^ ascii_of x - -fun make_schematic_type_var (x, i) = - tvar_prefix ^ (ascii_of_indexname (unprefix "'" x, i)) -fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (unprefix "'" x)) - -(* "HOL.eq" and choice are mapped to the ATP's equivalents *) -local - val choice_const = (fst o dest_Const o HOLogic.choice_const) Term.dummyT - fun default c = const_prefix ^ lookup_const c -in - fun make_fixed_const _ @{const_name HOL.eq} = tptp_old_equal - | make_fixed_const (SOME (THF (_, _, THF_With_Choice))) c = - if c = choice_const then tptp_choice else default c - | make_fixed_const _ c = default c -end - -fun make_fixed_type_const c = type_const_prefix ^ lookup_const c - -fun make_type_class clas = class_prefix ^ ascii_of clas - -fun new_skolem_var_name_from_const s = - let val ss = s |> space_explode Long_Name.separator in - nth ss (length ss - 2) - end - -(* These are either simplified away by "Meson.presimplify" (most of the time) or - handled specially via "fFalse", "fTrue", ..., "fequal". *) -val atp_irrelevant_consts = - [@{const_name False}, @{const_name True}, @{const_name Not}, - @{const_name conj}, @{const_name disj}, @{const_name implies}, - @{const_name HOL.eq}, @{const_name If}, @{const_name Let}] - -val atp_monomorph_bad_consts = - atp_irrelevant_consts @ - (* These are ignored anyway by the relevance filter (unless they appear in - higher-order places) but not by the monomorphizer. *) - [@{const_name all}, @{const_name "==>"}, @{const_name "=="}, - @{const_name Trueprop}, @{const_name All}, @{const_name Ex}, - @{const_name Ex1}, @{const_name Ball}, @{const_name Bex}] - -fun add_schematic_const (x as (_, T)) = - Monomorph.typ_has_tvars T ? Symtab.insert_list (op =) x -val add_schematic_consts_of = - Term.fold_aterms (fn Const (x as (s, _)) => - not (member (op =) atp_monomorph_bad_consts s) - ? add_schematic_const x - | _ => I) -fun atp_schematic_consts_of t = add_schematic_consts_of t Symtab.empty - -(** Definitions and functions for FOL clauses and formulas for TPTP **) - -(** Isabelle arities **) - -type arity_atom = name * name * name list - -val type_class = the_single @{sort type} - -type arity_clause = - {name : string, - prem_atoms : arity_atom list, - concl_atom : arity_atom} - -fun add_prem_atom tvar = - fold (fn s => s <> type_class ? cons (`make_type_class s, `I tvar, [])) - -(* Arity of type constructor "tcon :: (arg1, ..., argN) res" *) -fun make_axiom_arity_clause (tcons, name, (cls, args)) = - let - val tvars = map (prefix tvar_prefix o string_of_int) (1 upto length args) - val tvars_srts = ListPair.zip (tvars, args) - in - {name = name, - prem_atoms = [] |> fold (uncurry add_prem_atom) tvars_srts, - concl_atom = (`make_type_class cls, `make_fixed_type_const tcons, - tvars ~~ tvars)} - end - -fun arity_clause _ _ (_, []) = [] - | arity_clause seen n (tcons, ("HOL.type", _) :: ars) = (* ignore *) - arity_clause seen n (tcons, ars) - | arity_clause seen n (tcons, (ar as (class, _)) :: ars) = - if member (op =) seen class then - (* multiple arities for the same (tycon, class) pair *) - make_axiom_arity_clause (tcons, - lookup_const tcons ^ "___" ^ ascii_of class ^ "_" ^ string_of_int n, - ar) :: - arity_clause seen (n + 1) (tcons, ars) - else - make_axiom_arity_clause (tcons, lookup_const tcons ^ "___" ^ - ascii_of class, ar) :: - arity_clause (class :: seen) n (tcons, ars) - -fun multi_arity_clause [] = [] - | multi_arity_clause ((tcons, ars) :: tc_arlists) = - arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists - -(* Generate all pairs (tycon, class, sorts) such that tycon belongs to class in - theory thy provided its arguments have the corresponding sorts. *) -fun type_class_pairs thy tycons classes = - let - val alg = Sign.classes_of thy - fun domain_sorts tycon = Sorts.mg_domain alg tycon o single - fun add_class tycon class = - cons (class, domain_sorts tycon class) - handle Sorts.CLASS_ERROR _ => I - fun try_classes tycon = (tycon, fold (add_class tycon) classes []) - in map try_classes tycons end - -(*Proving one (tycon, class) membership may require proving others, so iterate.*) -fun iter_type_class_pairs _ _ [] = ([], []) - | iter_type_class_pairs thy tycons classes = - let - fun maybe_insert_class s = - (s <> type_class andalso not (member (op =) classes s)) - ? insert (op =) s - val cpairs = type_class_pairs thy tycons classes - val newclasses = - [] |> fold (fold (fold (fold maybe_insert_class) o snd) o snd) cpairs - val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses - in (classes' @ classes, union (op =) cpairs' cpairs) end - -fun make_arity_clauses thy tycons = - iter_type_class_pairs thy tycons ##> multi_arity_clause - - -(** Isabelle class relations **) - -type class_rel_clause = - {name : string, - subclass : name, - superclass : name} - -(* Generate all pairs (sub, super) such that sub is a proper subclass of super - in theory "thy". *) -fun class_pairs _ [] _ = [] - | class_pairs thy subs supers = - let - val class_less = Sorts.class_less (Sign.classes_of thy) - fun add_super sub super = class_less (sub, super) ? cons (sub, super) - fun add_supers sub = fold (add_super sub) supers - in fold add_supers subs [] end - -fun make_class_rel_clause (sub, super) = - {name = sub ^ "_" ^ super, subclass = `make_type_class sub, - superclass = `make_type_class super} - -fun make_class_rel_clauses thy subs supers = - map make_class_rel_clause (class_pairs thy subs supers) - -(* intermediate terms *) -datatype iterm = - IConst of name * typ * typ list | - IVar of name * typ | - IApp of iterm * iterm | - IAbs of (name * typ) * iterm - -fun ityp_of (IConst (_, T, _)) = T - | ityp_of (IVar (_, T)) = T - | ityp_of (IApp (t1, _)) = snd (dest_funT (ityp_of t1)) - | ityp_of (IAbs ((_, T), tm)) = T --> ityp_of tm - -(*gets the head of a combinator application, along with the list of arguments*) -fun strip_iterm_comb u = - let - fun stripc (IApp (t, u), ts) = stripc (t, u :: ts) - | stripc x = x - in stripc (u, []) end - -fun atomic_types_of T = fold_atyps (insert (op =)) T [] - -val tvar_a_str = "'a" -val tvar_a = TVar ((tvar_a_str, 0), HOLogic.typeS) -val tvar_a_name = (make_schematic_type_var (tvar_a_str, 0), tvar_a_str) -val itself_name = `make_fixed_type_const @{type_name itself} -val TYPE_name = `(make_fixed_const NONE) @{const_name TYPE} -val tvar_a_atype = AType (tvar_a_name, []) -val a_itself_atype = AType (itself_name, [tvar_a_atype]) - -fun new_skolem_const_name s num_T_args = - [new_skolem_const_prefix, s, string_of_int num_T_args] - |> space_implode Long_Name.separator - -fun robust_const_type thy s = - if s = app_op_name then - Logic.varifyT_global @{typ "('a => 'b) => 'a => 'b"} - else if String.isPrefix lam_lifted_prefix s then - Logic.varifyT_global @{typ "'a => 'b"} - else - (* Old Skolems throw a "TYPE" exception here, which will be caught. *) - s |> Sign.the_const_type thy - -(* This function only makes sense if "T" is as general as possible. *) -fun robust_const_typargs thy (s, T) = - if s = app_op_name then - let val (T1, T2) = T |> domain_type |> dest_funT in [T1, T2] end - else if String.isPrefix old_skolem_const_prefix s then - [] |> Term.add_tvarsT T |> rev |> map TVar - else if String.isPrefix lam_lifted_prefix s then - if String.isPrefix lam_lifted_poly_prefix s then - let val (T1, T2) = T |> dest_funT in [T1, T2] end - else - [] - else - (s, T) |> Sign.const_typargs thy - -(* Converts an Isabelle/HOL term (with combinators) into an intermediate term. - Also accumulates sort infomation. *) -fun iterm_from_term thy format bs (P $ Q) = - let - val (P', P_atomics_Ts) = iterm_from_term thy format bs P - val (Q', Q_atomics_Ts) = iterm_from_term thy format bs Q - in (IApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end - | iterm_from_term thy format _ (Const (c, T)) = - (IConst (`(make_fixed_const (SOME format)) c, T, - robust_const_typargs thy (c, T)), - atomic_types_of T) - | iterm_from_term _ _ _ (Free (s, T)) = - (IConst (`make_fixed_var s, T, []), atomic_types_of T) - | iterm_from_term _ format _ (Var (v as (s, _), T)) = - (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then - let - val Ts = T |> strip_type |> swap |> op :: - val s' = new_skolem_const_name s (length Ts) - in IConst (`(make_fixed_const (SOME format)) s', T, Ts) end - else - IVar ((make_schematic_var v, s), T), atomic_types_of T) - | iterm_from_term _ _ bs (Bound j) = - nth bs j |> (fn (_, (name, T)) => (IConst (name, T, []), atomic_types_of T)) - | iterm_from_term thy format bs (Abs (s, T, t)) = - let - fun vary s = s |> AList.defined (op =) bs s ? vary o Symbol.bump_string - val s = vary s - val name = `make_bound_var s - val (tm, atomic_Ts) = iterm_from_term thy format ((s, (name, T)) :: bs) t - in (IAbs ((name, T), tm), union (op =) atomic_Ts (atomic_types_of T)) end - -datatype locality = - General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained - -datatype order = First_Order | Higher_Order -datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic -datatype strictness = Strict | Non_Strict -datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars -datatype type_level = - All_Types | - Noninf_Nonmono_Types of strictness * granularity | - Fin_Nonmono_Types of granularity | - Const_Arg_Types | - No_Types - -datatype type_enc = - Simple_Types of order * polymorphism * type_level | - Guards of polymorphism * type_level | - Tags of polymorphism * type_level - -fun is_type_enc_higher_order (Simple_Types (Higher_Order, _, _)) = true - | is_type_enc_higher_order _ = false - -fun polymorphism_of_type_enc (Simple_Types (_, poly, _)) = poly - | polymorphism_of_type_enc (Guards (poly, _)) = poly - | polymorphism_of_type_enc (Tags (poly, _)) = poly - -fun level_of_type_enc (Simple_Types (_, _, level)) = level - | level_of_type_enc (Guards (_, level)) = level - | level_of_type_enc (Tags (_, level)) = level - -fun granularity_of_type_level (Noninf_Nonmono_Types (_, grain)) = grain - | granularity_of_type_level (Fin_Nonmono_Types grain) = grain - | granularity_of_type_level _ = All_Vars - -fun is_type_level_quasi_sound All_Types = true - | is_type_level_quasi_sound (Noninf_Nonmono_Types _) = true - | is_type_level_quasi_sound _ = false -val is_type_enc_quasi_sound = is_type_level_quasi_sound o level_of_type_enc - -fun is_type_level_fairly_sound (Fin_Nonmono_Types _) = true - | is_type_level_fairly_sound level = is_type_level_quasi_sound level -val is_type_enc_fairly_sound = is_type_level_fairly_sound o level_of_type_enc - -fun is_type_level_monotonicity_based (Noninf_Nonmono_Types _) = true - | is_type_level_monotonicity_based (Fin_Nonmono_Types _) = true - | is_type_level_monotonicity_based _ = false - -(* "_query", "_bang", and "_at" are for the ASCII-challenged Metis and - Mirabelle. *) -val queries = ["?", "_query"] -val bangs = ["!", "_bang"] -val ats = ["@", "_at"] - -fun try_unsuffixes ss s = - fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE - -fun try_nonmono constr suffixes fallback s = - case try_unsuffixes suffixes s of - SOME s => - (case try_unsuffixes suffixes s of - SOME s => (constr Positively_Naked_Vars, s) - | NONE => - case try_unsuffixes ats s of - SOME s => (constr Ghost_Type_Arg_Vars, s) - | NONE => (constr All_Vars, s)) - | NONE => fallback s - -fun type_enc_from_string strictness s = - (case try (unprefix "poly_") s of - SOME s => (SOME Polymorphic, s) - | NONE => - case try (unprefix "raw_mono_") s of - SOME s => (SOME Raw_Monomorphic, s) - | NONE => - case try (unprefix "mono_") s of - SOME s => (SOME Mangled_Monomorphic, s) - | NONE => (NONE, s)) - ||> (pair All_Types - |> try_nonmono Fin_Nonmono_Types bangs - |> try_nonmono (curry Noninf_Nonmono_Types strictness) queries) - |> (fn (poly, (level, core)) => - case (core, (poly, level)) of - ("simple", (SOME poly, _)) => - (case (poly, level) of - (Polymorphic, All_Types) => - Simple_Types (First_Order, Polymorphic, All_Types) - | (Mangled_Monomorphic, _) => - if granularity_of_type_level level = All_Vars then - Simple_Types (First_Order, Mangled_Monomorphic, level) - else - raise Same.SAME - | _ => raise Same.SAME) - | ("simple_higher", (SOME poly, _)) => - (case (poly, level) of - (Polymorphic, All_Types) => - Simple_Types (Higher_Order, Polymorphic, All_Types) - | (_, Noninf_Nonmono_Types _) => raise Same.SAME - | (Mangled_Monomorphic, _) => - if granularity_of_type_level level = All_Vars then - Simple_Types (Higher_Order, Mangled_Monomorphic, level) - else - raise Same.SAME - | _ => raise Same.SAME) - | ("guards", (SOME poly, _)) => - if poly = Mangled_Monomorphic andalso - granularity_of_type_level level = Ghost_Type_Arg_Vars then - raise Same.SAME - else - Guards (poly, level) - | ("tags", (SOME poly, _)) => - if granularity_of_type_level level = Ghost_Type_Arg_Vars then - raise Same.SAME - else - Tags (poly, level) - | ("args", (SOME poly, All_Types (* naja *))) => - Guards (poly, Const_Arg_Types) - | ("erased", (NONE, All_Types (* naja *))) => - Guards (Polymorphic, No_Types) - | _ => raise Same.SAME) - handle Same.SAME => error ("Unknown type encoding: " ^ quote s ^ ".") - -fun adjust_type_enc (THF (TPTP_Monomorphic, _, _)) - (Simple_Types (order, _, level)) = - Simple_Types (order, Mangled_Monomorphic, level) - | adjust_type_enc (THF _) type_enc = type_enc - | adjust_type_enc (TFF (TPTP_Monomorphic, _)) (Simple_Types (_, _, level)) = - Simple_Types (First_Order, Mangled_Monomorphic, level) - | adjust_type_enc (DFG DFG_Sorted) (Simple_Types (_, _, level)) = - Simple_Types (First_Order, Mangled_Monomorphic, level) - | adjust_type_enc (TFF _) (Simple_Types (_, poly, level)) = - Simple_Types (First_Order, poly, level) - | adjust_type_enc format (Simple_Types (_, poly, level)) = - adjust_type_enc format (Guards (poly, level)) - | adjust_type_enc CNF_UEQ (type_enc as Guards stuff) = - (if is_type_enc_fairly_sound type_enc then Tags else Guards) stuff - | adjust_type_enc _ type_enc = type_enc - -fun constify_lifted (t $ u) = constify_lifted t $ constify_lifted u - | constify_lifted (Abs (s, T, t)) = Abs (s, T, constify_lifted t) - | constify_lifted (Free (x as (s, _))) = - (if String.isPrefix lam_lifted_prefix s then Const else Free) x - | constify_lifted t = t - -(* Requires bound variables not to clash with any schematic variables (as should - be the case right after lambda-lifting). *) -fun open_form (Const (@{const_name All}, _) $ Abs (s, T, t)) = - let - val names = Name.make_context (map fst (Term.add_var_names t [])) - val (s, _) = Name.variant s names - in open_form (subst_bound (Var ((s, 0), T), t)) end - | open_form t = t - -fun lift_lams_part_1 ctxt type_enc = - map close_form #> rpair ctxt - #-> Lambda_Lifting.lift_lambdas - (SOME ((if polymorphism_of_type_enc type_enc = Polymorphic then - lam_lifted_poly_prefix - else - lam_lifted_mono_prefix) ^ "_a")) - Lambda_Lifting.is_quantifier - #> fst -val lift_lams_part_2 = pairself (map (open_form o constify_lifted)) -val lift_lams = lift_lams_part_2 ooo lift_lams_part_1 - -fun intentionalize_def (Const (@{const_name All}, _) $ Abs (_, _, t)) = - intentionalize_def t - | intentionalize_def (Const (@{const_name HOL.eq}, _) $ t $ u) = - let - fun lam T t = Abs (Name.uu, T, t) - val (head, args) = strip_comb t ||> rev - val head_T = fastype_of head - val n = length args - val arg_Ts = head_T |> binder_types |> take n |> rev - val u = u |> subst_atomic (args ~~ map Bound (0 upto n - 1)) - in HOLogic.eq_const head_T $ head $ fold lam arg_Ts u end - | intentionalize_def t = t - -type translated_formula = - {name : string, - locality : locality, - kind : formula_kind, - iformula : (name, typ, iterm) formula, - atomic_types : typ list} - -fun update_iformula f ({name, locality, kind, iformula, atomic_types} - : translated_formula) = - {name = name, locality = locality, kind = kind, iformula = f iformula, - atomic_types = atomic_types} : translated_formula - -fun fact_lift f ({iformula, ...} : translated_formula) = f iformula - -fun insert_type ctxt get_T x xs = - let val T = get_T x in - if exists (type_instance ctxt T o get_T) xs then xs - else x :: filter_out (type_generalization ctxt T o get_T) xs - end - -(* The Booleans indicate whether all type arguments should be kept. *) -datatype type_arg_policy = - Explicit_Type_Args of bool (* infer_from_term_args *) | - Mangled_Type_Args | - No_Type_Args - -fun type_arg_policy monom_constrs type_enc s = - let val poly = polymorphism_of_type_enc type_enc in - if s = type_tag_name then - if poly = Mangled_Monomorphic then Mangled_Type_Args - else Explicit_Type_Args false - else case type_enc of - Simple_Types (_, Polymorphic, _) => Explicit_Type_Args false - | Tags (_, All_Types) => No_Type_Args - | _ => - let val level = level_of_type_enc type_enc in - if level = No_Types orelse s = @{const_name HOL.eq} orelse - (s = app_op_name andalso level = Const_Arg_Types) then - No_Type_Args - else if poly = Mangled_Monomorphic then - Mangled_Type_Args - else if member (op =) monom_constrs s andalso - granularity_of_type_level level = Positively_Naked_Vars then - No_Type_Args - else - Explicit_Type_Args - (level = All_Types orelse - granularity_of_type_level level = Ghost_Type_Arg_Vars) - end - end - -(* Make atoms for sorted type variables. *) -fun generic_add_sorts_on_type (_, []) = I - | generic_add_sorts_on_type ((x, i), s :: ss) = - generic_add_sorts_on_type ((x, i), ss) - #> (if s = the_single @{sort HOL.type} then - I - else if i = ~1 then - insert (op =) (`make_type_class s, `make_fixed_type_var x) - else - insert (op =) (`make_type_class s, - (make_schematic_type_var (x, i), x))) -fun add_sorts_on_tfree (TFree (s, S)) = generic_add_sorts_on_type ((s, ~1), S) - | add_sorts_on_tfree _ = I -fun add_sorts_on_tvar (TVar z) = generic_add_sorts_on_type z - | add_sorts_on_tvar _ = I - -fun type_class_formula type_enc class arg = - AAtom (ATerm (class, arg :: - (case type_enc of - Simple_Types (First_Order, Polymorphic, _) => - if avoid_first_order_ghost_type_vars then [ATerm (TYPE_name, [arg])] - else [] - | _ => []))) -fun formulas_for_types type_enc add_sorts_on_typ Ts = - [] |> level_of_type_enc type_enc <> No_Types ? fold add_sorts_on_typ Ts - |> map (fn (class, name) => - type_class_formula type_enc class (ATerm (name, []))) - -fun mk_aconns c phis = - let val (phis', phi') = split_last phis in - fold_rev (mk_aconn c) phis' phi' - end -fun mk_ahorn [] phi = phi - | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi]) -fun mk_aquant _ [] phi = phi - | mk_aquant q xs (phi as AQuant (q', xs', phi')) = - if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi) - | mk_aquant q xs phi = AQuant (q, xs, phi) - -fun close_universally add_term_vars phi = - let - fun add_formula_vars bounds (AQuant (_, xs, phi)) = - add_formula_vars (map fst xs @ bounds) phi - | add_formula_vars bounds (AConn (_, phis)) = - fold (add_formula_vars bounds) phis - | add_formula_vars bounds (AAtom tm) = add_term_vars bounds tm - in mk_aquant AForall (add_formula_vars [] phi []) phi end - -fun add_term_vars bounds (ATerm (name as (s, _), tms)) = - (if is_tptp_variable s andalso - not (String.isPrefix tvar_prefix s) andalso - not (member (op =) bounds name) then - insert (op =) (name, NONE) - else - I) - #> fold (add_term_vars bounds) tms - | add_term_vars bounds (AAbs ((name, _), tm)) = - add_term_vars (name :: bounds) tm -fun close_formula_universally phi = close_universally add_term_vars phi - -fun add_iterm_vars bounds (IApp (tm1, tm2)) = - fold (add_iterm_vars bounds) [tm1, tm2] - | add_iterm_vars _ (IConst _) = I - | add_iterm_vars bounds (IVar (name, T)) = - not (member (op =) bounds name) ? insert (op =) (name, SOME T) - | add_iterm_vars bounds (IAbs (_, tm)) = add_iterm_vars bounds tm -fun close_iformula_universally phi = close_universally add_iterm_vars phi - -val fused_infinite_type_name = @{type_name ind} (* any infinite type *) -val fused_infinite_type = Type (fused_infinite_type_name, []) - -fun tvar_name (x as (s, _)) = (make_schematic_type_var x, s) - -fun ho_term_from_typ format type_enc = - let - fun term (Type (s, Ts)) = - ATerm (case (is_type_enc_higher_order type_enc, s) of - (true, @{type_name bool}) => `I tptp_bool_type - | (true, @{type_name fun}) => `I tptp_fun_type - | _ => if s = fused_infinite_type_name andalso - is_format_typed format then - `I tptp_individual_type - else - `make_fixed_type_const s, - map term Ts) - | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, []) - | term (TVar (x, _)) = ATerm (tvar_name x, []) - in term end - -fun ho_term_for_type_arg format type_enc T = - if T = dummyT then NONE else SOME (ho_term_from_typ format type_enc T) - -(* This shouldn't clash with anything else. *) -val mangled_type_sep = "\000" - -fun generic_mangled_type_name f (ATerm (name, [])) = f name - | generic_mangled_type_name f (ATerm (name, tys)) = - f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys) - ^ ")" - | generic_mangled_type_name _ _ = raise Fail "unexpected type abstraction" - -fun mangled_type format type_enc = - generic_mangled_type_name fst o ho_term_from_typ format type_enc - -fun make_simple_type s = - if s = tptp_bool_type orelse s = tptp_fun_type orelse - s = tptp_individual_type then - s - else - simple_type_prefix ^ ascii_of s - -fun ho_type_from_ho_term type_enc pred_sym ary = - let - fun to_mangled_atype ty = - AType ((make_simple_type (generic_mangled_type_name fst ty), - generic_mangled_type_name snd ty), []) - fun to_poly_atype (ATerm (name, tys)) = AType (name, map to_poly_atype tys) - | to_poly_atype _ = raise Fail "unexpected type abstraction" - val to_atype = - if polymorphism_of_type_enc type_enc = Polymorphic then to_poly_atype - else to_mangled_atype - fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1)) - fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty - | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys - | to_fo _ _ = raise Fail "unexpected type abstraction" - fun to_ho (ty as ATerm ((s, _), tys)) = - if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty - | to_ho _ = raise Fail "unexpected type abstraction" - in if is_type_enc_higher_order type_enc then to_ho else to_fo ary end - -fun ho_type_from_typ format type_enc pred_sym ary = - ho_type_from_ho_term type_enc pred_sym ary - o ho_term_from_typ format type_enc - -fun mangled_const_name format type_enc T_args (s, s') = - let - val ty_args = T_args |> map_filter (ho_term_for_type_arg format type_enc) - fun type_suffix f g = - fold_rev (curry (op ^) o g o prefix mangled_type_sep - o generic_mangled_type_name f) ty_args "" - in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end - -val parse_mangled_ident = - Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode - -fun parse_mangled_type x = - (parse_mangled_ident - -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")") - [] >> ATerm) x -and parse_mangled_types x = - (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x - -fun unmangled_type s = - s |> suffix ")" |> raw_explode - |> Scan.finite Symbol.stopper - (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^ - quote s)) parse_mangled_type)) - |> fst - -val unmangled_const_name = space_explode mangled_type_sep #> hd -fun unmangled_const s = - let val ss = space_explode mangled_type_sep s in - (hd ss, map unmangled_type (tl ss)) - end - -fun introduce_proxies_in_iterm type_enc = - let - fun tweak_ho_quant ho_quant T [IAbs _] = IConst (`I ho_quant, T, []) - | tweak_ho_quant ho_quant (T as Type (_, [p_T as Type (_, [x_T, _]), _])) - _ = - (* Eta-expand "!!" and "??", to work around LEO-II 1.2.8 parser - limitation. This works in conjuction with special code in - "ATP_Problem" that uses the syntactic sugar "!" and "?" whenever - possible. *) - IAbs ((`I "P", p_T), - IApp (IConst (`I ho_quant, T, []), - IAbs ((`I "X", x_T), - IApp (IConst (`I "P", p_T, []), - IConst (`I "X", x_T, []))))) - | tweak_ho_quant _ _ _ = raise Fail "unexpected type for quantifier" - fun intro top_level args (IApp (tm1, tm2)) = - IApp (intro top_level (tm2 :: args) tm1, intro false [] tm2) - | intro top_level args (IConst (name as (s, _), T, T_args)) = - (case proxify_const s of - SOME proxy_base => - if top_level orelse is_type_enc_higher_order type_enc then - case (top_level, s) of - (_, "c_False") => IConst (`I tptp_false, T, []) - | (_, "c_True") => IConst (`I tptp_true, T, []) - | (false, "c_Not") => IConst (`I tptp_not, T, []) - | (false, "c_conj") => IConst (`I tptp_and, T, []) - | (false, "c_disj") => IConst (`I tptp_or, T, []) - | (false, "c_implies") => IConst (`I tptp_implies, T, []) - | (false, "c_All") => tweak_ho_quant tptp_ho_forall T args - | (false, "c_Ex") => tweak_ho_quant tptp_ho_exists T args - | (false, s) => - if is_tptp_equal s andalso length args = 2 then - IConst (`I tptp_equal, T, []) - else - (* Use a proxy even for partially applied THF0 equality, - because the LEO-II and Satallax parsers complain about not - being able to infer the type of "=". *) - IConst (proxy_base |>> prefix const_prefix, T, T_args) - | _ => IConst (name, T, []) - else - IConst (proxy_base |>> prefix const_prefix, T, T_args) - | NONE => if s = tptp_choice then tweak_ho_quant tptp_choice T args - else IConst (name, T, T_args)) - | intro _ _ (IAbs (bound, tm)) = IAbs (bound, intro false [] tm) - | intro _ _ tm = tm - in intro true [] end - -fun mangle_type_args_in_iterm format type_enc = - if polymorphism_of_type_enc type_enc = Mangled_Monomorphic then - let - fun mangle (IApp (tm1, tm2)) = IApp (mangle tm1, mangle tm2) - | mangle (tm as IConst (_, _, [])) = tm - | mangle (tm as IConst (name as (s, _), T, T_args)) = - (case unprefix_and_unascii const_prefix s of - NONE => tm - | SOME s'' => - case type_arg_policy [] type_enc (invert_const s'') of - Mangled_Type_Args => - IConst (mangled_const_name format type_enc T_args name, T, []) - | _ => tm) - | mangle (IAbs (bound, tm)) = IAbs (bound, mangle tm) - | mangle tm = tm - in mangle end - else - I - -fun chop_fun 0 T = ([], T) - | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) = - chop_fun (n - 1) ran_T |>> cons dom_T - | chop_fun _ T = ([], T) - -fun filter_const_type_args _ _ _ [] = [] - | filter_const_type_args thy s ary T_args = - let - val U = robust_const_type thy s - val arg_U_vars = fold Term.add_tvarsT (U |> chop_fun ary |> fst) [] - val U_args = (s, U) |> robust_const_typargs thy - in - U_args ~~ T_args - |> map (fn (U, T) => - if member (op =) arg_U_vars (dest_TVar U) then dummyT else T) - end - handle TYPE _ => T_args - -fun filter_type_args_in_iterm thy monom_constrs type_enc = - let - fun filt ary (IApp (tm1, tm2)) = IApp (filt (ary + 1) tm1, filt 0 tm2) - | filt _ (tm as IConst (_, _, [])) = tm - | filt ary (IConst (name as (s, _), T, T_args)) = - (case unprefix_and_unascii const_prefix s of - NONE => - (name, - if level_of_type_enc type_enc = No_Types orelse s = tptp_choice then - [] - else - T_args) - | SOME s'' => - let - val s'' = invert_const s'' - fun filter_T_args false = T_args - | filter_T_args true = filter_const_type_args thy s'' ary T_args - in - case type_arg_policy monom_constrs type_enc s'' of - Explicit_Type_Args infer_from_term_args => - (name, filter_T_args infer_from_term_args) - | No_Type_Args => (name, []) - | Mangled_Type_Args => raise Fail "unexpected (un)mangled symbol" - end) - |> (fn (name, T_args) => IConst (name, T, T_args)) - | filt _ (IAbs (bound, tm)) = IAbs (bound, filt 0 tm) - | filt _ tm = tm - in filt 0 end - -fun iformula_from_prop ctxt format type_enc eq_as_iff = - let - val thy = Proof_Context.theory_of ctxt - fun do_term bs t atomic_Ts = - iterm_from_term thy format bs (Envir.eta_contract t) - |>> (introduce_proxies_in_iterm type_enc - #> mangle_type_args_in_iterm format type_enc - #> AAtom) - ||> union (op =) atomic_Ts - fun do_quant bs q pos s T t' = - let - val s = singleton (Name.variant_list (map fst bs)) s - val universal = Option.map (q = AExists ? not) pos - val name = - s |> `(case universal of - SOME true => make_all_bound_var - | SOME false => make_exist_bound_var - | NONE => make_bound_var) - in - do_formula ((s, (name, T)) :: bs) pos t' - #>> mk_aquant q [(name, SOME T)] - ##> union (op =) (atomic_types_of T) - end - and do_conn bs c pos1 t1 pos2 t2 = - do_formula bs pos1 t1 ##>> do_formula bs pos2 t2 #>> uncurry (mk_aconn c) - and do_formula bs pos t = - case t of - @{const Trueprop} $ t1 => do_formula bs pos t1 - | @{const Not} $ t1 => do_formula bs (Option.map not pos) t1 #>> mk_anot - | Const (@{const_name All}, _) $ Abs (s, T, t') => - do_quant bs AForall pos s T t' - | (t0 as Const (@{const_name All}, _)) $ t1 => - do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1) - | Const (@{const_name Ex}, _) $ Abs (s, T, t') => - do_quant bs AExists pos s T t' - | (t0 as Const (@{const_name Ex}, _)) $ t1 => - do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1) - | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd pos t1 pos t2 - | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr pos t1 pos t2 - | @{const HOL.implies} $ t1 $ t2 => - do_conn bs AImplies (Option.map not pos) t1 pos t2 - | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 => - if eq_as_iff then do_conn bs AIff NONE t1 NONE t2 else do_term bs t - | _ => do_term bs t - in do_formula [] end - -fun presimplify_term ctxt t = - t |> exists_Const (member (op =) Meson.presimplified_consts o fst) t - ? (Skip_Proof.make_thm (Proof_Context.theory_of ctxt) - #> Meson.presimplify - #> prop_of) - -fun concealed_bound_name j = atp_weak_prefix ^ string_of_int j -fun conceal_bounds Ts t = - subst_bounds (map (Free o apfst concealed_bound_name) - (0 upto length Ts - 1 ~~ Ts), t) -fun reveal_bounds Ts = - subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j)) - (0 upto length Ts - 1 ~~ Ts)) - -fun is_fun_equality (@{const_name HOL.eq}, - Type (_, [Type (@{type_name fun}, _), _])) = true - | is_fun_equality _ = false - -fun extensionalize_term ctxt t = - if exists_Const is_fun_equality t then - let val thy = Proof_Context.theory_of ctxt in - t |> cterm_of thy |> Meson.extensionalize_conv ctxt - |> prop_of |> Logic.dest_equals |> snd - end - else - t - -fun simple_translate_lambdas do_lambdas ctxt t = - let val thy = Proof_Context.theory_of ctxt in - if Meson.is_fol_term thy t then - t - else - let - fun trans Ts t = - case t of - @{const Not} $ t1 => @{const Not} $ trans Ts t1 - | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') => - t0 $ Abs (s, T, trans (T :: Ts) t') - | (t0 as Const (@{const_name All}, _)) $ t1 => - trans Ts (t0 $ eta_expand Ts t1 1) - | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') => - t0 $ Abs (s, T, trans (T :: Ts) t') - | (t0 as Const (@{const_name Ex}, _)) $ t1 => - trans Ts (t0 $ eta_expand Ts t1 1) - | (t0 as @{const HOL.conj}) $ t1 $ t2 => - t0 $ trans Ts t1 $ trans Ts t2 - | (t0 as @{const HOL.disj}) $ t1 $ t2 => - t0 $ trans Ts t1 $ trans Ts t2 - | (t0 as @{const HOL.implies}) $ t1 $ t2 => - t0 $ trans Ts t1 $ trans Ts t2 - | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _]))) - $ t1 $ t2 => - t0 $ trans Ts t1 $ trans Ts t2 - | _ => - if not (exists_subterm (fn Abs _ => true | _ => false) t) then t - else t |> Envir.eta_contract |> do_lambdas ctxt Ts - val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single - in t |> trans [] |> singleton (Variable.export_terms ctxt' ctxt) end - end - -fun do_cheaply_conceal_lambdas Ts (t1 $ t2) = - do_cheaply_conceal_lambdas Ts t1 - $ do_cheaply_conceal_lambdas Ts t2 - | do_cheaply_conceal_lambdas Ts (Abs (_, T, t)) = - Const (lam_lifted_poly_prefix ^ serial_string (), - T --> fastype_of1 (T :: Ts, t)) - | do_cheaply_conceal_lambdas _ t = t - -fun do_introduce_combinators ctxt Ts t = - let val thy = Proof_Context.theory_of ctxt in - t |> conceal_bounds Ts - |> cterm_of thy - |> Meson_Clausify.introduce_combinators_in_cterm - |> prop_of |> Logic.dest_equals |> snd - |> reveal_bounds Ts - end - (* A type variable of sort "{}" will make abstraction fail. *) - handle THM _ => t |> do_cheaply_conceal_lambdas Ts -val introduce_combinators = simple_translate_lambdas do_introduce_combinators - -fun preprocess_abstractions_in_terms trans_lams facts = - let - val (facts, lambda_ts) = - facts |> map (snd o snd) |> trans_lams - |>> map2 (fn (name, (kind, _)) => fn t => (name, (kind, t))) facts - val lam_facts = - map2 (fn t => fn j => - ((lam_fact_prefix ^ Int.toString j, Helper), (Axiom, t))) - lambda_ts (1 upto length lambda_ts) - in (facts, lam_facts) end - -(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the - same in Sledgehammer to prevent the discovery of unreplayable proofs. *) -fun freeze_term t = - let - fun freeze (t $ u) = freeze t $ freeze u - | freeze (Abs (s, T, t)) = Abs (s, T, freeze t) - | freeze (Var ((s, i), T)) = - Free (atp_weak_prefix ^ s ^ "_" ^ string_of_int i, T) - | freeze t = t - in t |> exists_subterm is_Var t ? freeze end - -fun presimp_prop ctxt role t = - (let - val thy = Proof_Context.theory_of ctxt - val t = t |> Envir.beta_eta_contract - |> transform_elim_prop - |> Object_Logic.atomize_term thy - val need_trueprop = (fastype_of t = @{typ bool}) - in - t |> need_trueprop ? HOLogic.mk_Trueprop - |> extensionalize_term ctxt - |> presimplify_term ctxt - |> HOLogic.dest_Trueprop - end - handle TERM _ => if role = Conjecture then @{term False} else @{term True}) - |> pair role - -fun make_formula ctxt format type_enc eq_as_iff name loc kind t = - let - val (iformula, atomic_Ts) = - iformula_from_prop ctxt format type_enc eq_as_iff - (SOME (kind <> Conjecture)) t [] - |>> close_iformula_universally - in - {name = name, locality = loc, kind = kind, iformula = iformula, - atomic_types = atomic_Ts} - end - -fun make_fact ctxt format type_enc eq_as_iff ((name, loc), t) = - case t |> make_formula ctxt format type_enc (eq_as_iff andalso format <> CNF) - name loc Axiom of - formula as {iformula = AAtom (IConst ((s, _), _, _)), ...} => - if s = tptp_true then NONE else SOME formula - | formula => SOME formula - -fun s_not_trueprop (@{const Trueprop} $ t) = @{const Trueprop} $ s_not t - | s_not_trueprop t = - if fastype_of t = @{typ bool} then s_not t else @{prop False} (* too meta *) - -fun make_conjecture ctxt format type_enc = - map (fn ((name, loc), (kind, t)) => - t |> kind = Conjecture ? s_not_trueprop - |> make_formula ctxt format type_enc (format <> CNF) name loc kind) - -(** Finite and infinite type inference **) - -fun tvar_footprint thy s ary = - (case unprefix_and_unascii const_prefix s of - SOME s => - s |> invert_const |> robust_const_type thy |> chop_fun ary |> fst - |> map (fn T => Term.add_tvarsT T [] |> map fst) - | NONE => []) - handle TYPE _ => [] - -fun ghost_type_args thy s ary = - if is_tptp_equal s then - 0 upto ary - 1 - else - let - val footprint = tvar_footprint thy s ary - val eq = (s = @{const_name HOL.eq}) - fun ghosts _ [] = [] - | ghosts seen ((i, tvars) :: args) = - ghosts (union (op =) seen tvars) args - |> (eq orelse exists (fn tvar => not (member (op =) seen tvar)) tvars) - ? cons i - in - if forall null footprint then - [] - else - 0 upto length footprint - 1 ~~ footprint - |> sort (rev_order o list_ord Term_Ord.indexname_ord o pairself snd) - |> ghosts [] - end - -type monotonicity_info = - {maybe_finite_Ts : typ list, - surely_finite_Ts : typ list, - maybe_infinite_Ts : typ list, - surely_infinite_Ts : typ list, - maybe_nonmono_Ts : typ list} - -(* These types witness that the type classes they belong to allow infinite - models and hence that any types with these type classes is monotonic. *) -val known_infinite_types = - [@{typ nat}, HOLogic.intT, HOLogic.realT, @{typ "nat => bool"}] - -fun is_type_kind_of_surely_infinite ctxt strictness cached_Ts T = - strictness <> Strict andalso is_type_surely_infinite ctxt true cached_Ts T - -(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are - dangerous because their "exhaust" properties can easily lead to unsound ATP - proofs. On the other hand, all HOL infinite types can be given the same - models in first-order logic (via Löwenheim-Skolem). *) - -fun should_encode_type _ (_ : monotonicity_info) All_Types _ = true - | should_encode_type ctxt {maybe_finite_Ts, surely_infinite_Ts, - maybe_nonmono_Ts, ...} - (Noninf_Nonmono_Types (strictness, grain)) T = - grain = Ghost_Type_Arg_Vars orelse - (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso - not (exists (type_instance ctxt T) surely_infinite_Ts orelse - (not (member (type_equiv ctxt) maybe_finite_Ts T) andalso - is_type_kind_of_surely_infinite ctxt strictness surely_infinite_Ts - T))) - | should_encode_type ctxt {surely_finite_Ts, maybe_infinite_Ts, - maybe_nonmono_Ts, ...} - (Fin_Nonmono_Types grain) T = - grain = Ghost_Type_Arg_Vars orelse - (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso - (exists (type_generalization ctxt T) surely_finite_Ts orelse - (not (member (type_equiv ctxt) maybe_infinite_Ts T) andalso - is_type_surely_finite ctxt T))) - | should_encode_type _ _ _ _ = false - -fun should_guard_type ctxt mono (Guards (_, level)) should_guard_var T = - should_guard_var () andalso should_encode_type ctxt mono level T - | should_guard_type _ _ _ _ _ = false - -fun is_maybe_universal_var (IConst ((s, _), _, _)) = - String.isPrefix bound_var_prefix s orelse - String.isPrefix all_bound_var_prefix s - | is_maybe_universal_var (IVar _) = true - | is_maybe_universal_var _ = false - -datatype site = - Top_Level of bool option | - Eq_Arg of bool option | - Elsewhere - -fun should_tag_with_type _ _ _ (Top_Level _) _ _ = false - | should_tag_with_type ctxt mono (Tags (_, level)) site u T = - if granularity_of_type_level level = All_Vars then - should_encode_type ctxt mono level T - else - (case (site, is_maybe_universal_var u) of - (Eq_Arg _, true) => should_encode_type ctxt mono level T - | _ => false) - | should_tag_with_type _ _ _ _ _ _ = false - -fun fused_type ctxt mono level = - let - val should_encode = should_encode_type ctxt mono level - fun fuse 0 T = if should_encode T then T else fused_infinite_type - | fuse ary (Type (@{type_name fun}, [T1, T2])) = - fuse 0 T1 --> fuse (ary - 1) T2 - | fuse _ _ = raise Fail "expected function type" - in fuse end - -(** predicators and application operators **) - -type sym_info = - {pred_sym : bool, min_ary : int, max_ary : int, types : typ list, - in_conj : bool} - -fun default_sym_tab_entries type_enc = - (make_fixed_const NONE @{const_name undefined}, - {pred_sym = false, min_ary = 0, max_ary = 0, types = [], - in_conj = false}) :: - ([tptp_false, tptp_true] - |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = [], - in_conj = false})) @ - ([tptp_equal, tptp_old_equal] - |> map (rpair {pred_sym = true, min_ary = 2, max_ary = 2, types = [], - in_conj = false})) - |> not (is_type_enc_higher_order type_enc) - ? cons (prefixed_predicator_name, - {pred_sym = true, min_ary = 1, max_ary = 1, types = [], - in_conj = false}) - -fun sym_table_for_facts ctxt type_enc explicit_apply conjs facts = - let - fun consider_var_ary const_T var_T max_ary = - let - fun iter ary T = - if ary = max_ary orelse type_instance ctxt var_T T orelse - type_instance ctxt T var_T then - ary - else - iter (ary + 1) (range_type T) - in iter 0 const_T end - fun add_universal_var T (accum as ((bool_vars, fun_var_Ts), sym_tab)) = - if explicit_apply = NONE andalso - (can dest_funT T orelse T = @{typ bool}) then - let - val bool_vars' = bool_vars orelse body_type T = @{typ bool} - fun repair_min_ary {pred_sym, min_ary, max_ary, types, in_conj} = - {pred_sym = pred_sym andalso not bool_vars', - min_ary = fold (fn T' => consider_var_ary T' T) types min_ary, - max_ary = max_ary, types = types, in_conj = in_conj} - val fun_var_Ts' = - fun_var_Ts |> can dest_funT T ? insert_type ctxt I T - in - if bool_vars' = bool_vars andalso - pointer_eq (fun_var_Ts', fun_var_Ts) then - accum - else - ((bool_vars', fun_var_Ts'), Symtab.map (K repair_min_ary) sym_tab) - end - else - accum - fun add_fact_syms conj_fact = - let - fun add_iterm_syms top_level tm - (accum as ((bool_vars, fun_var_Ts), sym_tab)) = - let val (head, args) = strip_iterm_comb tm in - (case head of - IConst ((s, _), T, _) => - if String.isPrefix bound_var_prefix s orelse - String.isPrefix all_bound_var_prefix s then - add_universal_var T accum - else if String.isPrefix exist_bound_var_prefix s then - accum - else - let val ary = length args in - ((bool_vars, fun_var_Ts), - case Symtab.lookup sym_tab s of - SOME {pred_sym, min_ary, max_ary, types, in_conj} => - let - val pred_sym = - pred_sym andalso top_level andalso not bool_vars - val types' = types |> insert_type ctxt I T - val in_conj = in_conj orelse conj_fact - val min_ary = - if is_some explicit_apply orelse - pointer_eq (types', types) then - min_ary - else - fold (consider_var_ary T) fun_var_Ts min_ary - in - Symtab.update (s, {pred_sym = pred_sym, - min_ary = Int.min (ary, min_ary), - max_ary = Int.max (ary, max_ary), - types = types', in_conj = in_conj}) - sym_tab - end - | NONE => - let - val pred_sym = top_level andalso not bool_vars - val min_ary = - case explicit_apply of - SOME true => 0 - | SOME false => ary - | NONE => fold (consider_var_ary T) fun_var_Ts ary - in - Symtab.update_new (s, - {pred_sym = pred_sym, min_ary = min_ary, - max_ary = ary, types = [T], in_conj = conj_fact}) - sym_tab - end) - end - | IVar (_, T) => add_universal_var T accum - | IAbs ((_, T), tm) => - accum |> add_universal_var T |> add_iterm_syms false tm - | _ => accum) - |> fold (add_iterm_syms false) args - end - in K (add_iterm_syms true) |> formula_fold NONE |> fact_lift end - in - ((false, []), Symtab.empty) - |> fold (add_fact_syms true) conjs - |> fold (add_fact_syms false) facts - |> snd - |> fold Symtab.update (default_sym_tab_entries type_enc) - end - -fun min_ary_of sym_tab s = - case Symtab.lookup sym_tab s of - SOME ({min_ary, ...} : sym_info) => min_ary - | NONE => - case unprefix_and_unascii const_prefix s of - SOME s => - let val s = s |> unmangled_const_name |> invert_const in - if s = predicator_name then 1 - else if s = app_op_name then 2 - else if s = type_guard_name then 1 - else 0 - end - | NONE => 0 - -(* True if the constant ever appears outside of the top-level position in - literals, or if it appears with different arities (e.g., because of different - type instantiations). If false, the constant always receives all of its - arguments and is used as a predicate. *) -fun is_pred_sym sym_tab s = - case Symtab.lookup sym_tab s of - SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) => - pred_sym andalso min_ary = max_ary - | NONE => false - -val app_op = `(make_fixed_const NONE) app_op_name -val predicator_combconst = - IConst (`(make_fixed_const NONE) predicator_name, @{typ "bool => bool"}, []) - -fun list_app head args = fold (curry (IApp o swap)) args head -fun predicator tm = IApp (predicator_combconst, tm) - -fun firstorderize_fact thy monom_constrs format type_enc sym_tab = - let - fun do_app arg head = - let - val head_T = ityp_of head - val (arg_T, res_T) = dest_funT head_T - val app = - IConst (app_op, head_T --> head_T, [arg_T, res_T]) - |> mangle_type_args_in_iterm format type_enc - in list_app app [head, arg] end - fun list_app_ops head args = fold do_app args head - fun introduce_app_ops tm = - case strip_iterm_comb tm of - (head as IConst ((s, _), _, _), args) => - args |> map introduce_app_ops - |> chop (min_ary_of sym_tab s) - |>> list_app head - |-> list_app_ops - | (head, args) => list_app_ops head (map introduce_app_ops args) - fun introduce_predicators tm = - case strip_iterm_comb tm of - (IConst ((s, _), _, _), _) => - if is_pred_sym sym_tab s then tm else predicator tm - | _ => predicator tm - val do_iterm = - not (is_type_enc_higher_order type_enc) - ? (introduce_app_ops #> introduce_predicators) - #> filter_type_args_in_iterm thy monom_constrs type_enc - in update_iformula (formula_map do_iterm) end - -(** Helper facts **) - -val not_ffalse = @{lemma "~ fFalse" by (unfold fFalse_def) fast} -val ftrue = @{lemma "fTrue" by (unfold fTrue_def) fast} - -(* The Boolean indicates that a fairly sound type encoding is needed. *) -val helper_table = - [(("COMBI", false), @{thms Meson.COMBI_def}), - (("COMBK", false), @{thms Meson.COMBK_def}), - (("COMBB", false), @{thms Meson.COMBB_def}), - (("COMBC", false), @{thms Meson.COMBC_def}), - (("COMBS", false), @{thms Meson.COMBS_def}), - ((predicator_name, false), [not_ffalse, ftrue]), - (("fFalse", false), [not_ffalse]), - (("fFalse", true), @{thms True_or_False}), - (("fTrue", false), [ftrue]), - (("fTrue", true), @{thms True_or_False}), - (("fNot", false), - @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1] - fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]}), - (("fconj", false), - @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q" - by (unfold fconj_def) fast+}), - (("fdisj", false), - @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q" - by (unfold fdisj_def) fast+}), - (("fimplies", false), - @{lemma "P | fimplies P Q" "~ Q | fimplies P Q" "~ fimplies P Q | ~ P | Q" - by (unfold fimplies_def) fast+}), - (("fequal", true), - (* This is a lie: Higher-order equality doesn't need a sound type encoding. - However, this is done so for backward compatibility: Including the - equality helpers by default in Metis breaks a few existing proofs. *) - @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1] - fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]}), - (* Partial characterization of "fAll" and "fEx". A complete characterization - would require the axiom of choice for replay with Metis. *) - (("fAll", false), [@{lemma "~ fAll P | P x" by (auto simp: fAll_def)}]), - (("fEx", false), [@{lemma "~ P x | fEx P" by (auto simp: fEx_def)}]), - (("If", true), @{thms if_True if_False True_or_False})] - |> map (apsnd (map zero_var_indexes)) - -fun atype_of_type_vars (Simple_Types (_, Polymorphic, _)) = SOME atype_of_types - | atype_of_type_vars _ = NONE - -fun bound_tvars type_enc sorts Ts = - (sorts ? mk_ahorn (formulas_for_types type_enc add_sorts_on_tvar Ts)) - #> mk_aquant AForall - (map_filter (fn TVar (x as (s, _), _) => - SOME ((make_schematic_type_var x, s), - atype_of_type_vars type_enc) - | _ => NONE) Ts) - -fun eq_formula type_enc atomic_Ts pred_sym tm1 tm2 = - (if pred_sym then AConn (AIff, [AAtom tm1, AAtom tm2]) - else AAtom (ATerm (`I tptp_equal, [tm1, tm2]))) - |> close_formula_universally - |> bound_tvars type_enc true atomic_Ts - -val type_tag = `(make_fixed_const NONE) type_tag_name - -fun type_tag_idempotence_fact format type_enc = - let - fun var s = ATerm (`I s, []) - fun tag tm = ATerm (type_tag, [var "A", tm]) - val tagged_var = tag (var "X") - in - Formula (type_tag_idempotence_helper_name, Axiom, - eq_formula type_enc [] false (tag tagged_var) tagged_var, - isabelle_info format simpN, NONE) - end - -fun should_specialize_helper type_enc t = - polymorphism_of_type_enc type_enc <> Polymorphic andalso - level_of_type_enc type_enc <> No_Types andalso - not (null (Term.hidden_polymorphism t)) - -fun helper_facts_for_sym ctxt format type_enc (s, {types, ...} : sym_info) = - case unprefix_and_unascii const_prefix s of - SOME mangled_s => - let - val thy = Proof_Context.theory_of ctxt - val unmangled_s = mangled_s |> unmangled_const_name - fun dub needs_fairly_sound j k = - (unmangled_s ^ "_" ^ string_of_int j ^ "_" ^ string_of_int k ^ - (if mangled_s = unmangled_s then "" else "_" ^ ascii_of mangled_s) ^ - (if needs_fairly_sound then typed_helper_suffix - else untyped_helper_suffix), - Helper) - fun dub_and_inst needs_fairly_sound (th, j) = - let val t = prop_of th in - if should_specialize_helper type_enc t then - map (fn T => specialize_type thy (invert_const unmangled_s, T) t) - types - else - [t] - end - |> map (fn (k, t) => (dub needs_fairly_sound j k, t)) o tag_list 1 - val make_facts = map_filter (make_fact ctxt format type_enc false) - val fairly_sound = is_type_enc_fairly_sound type_enc - in - helper_table - |> maps (fn ((helper_s, needs_fairly_sound), ths) => - if helper_s <> unmangled_s orelse - (needs_fairly_sound andalso not fairly_sound) then - [] - else - ths ~~ (1 upto length ths) - |> maps (dub_and_inst needs_fairly_sound) - |> make_facts) - end - | NONE => [] -fun helper_facts_for_sym_table ctxt format type_enc sym_tab = - Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_enc) sym_tab - [] - -(***************************************************************) -(* Type Classes Present in the Axiom or Conjecture Clauses *) -(***************************************************************) - -fun set_insert (x, s) = Symtab.update (x, ()) s - -fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts) - -(* Remove this trivial type class (FIXME: similar code elsewhere) *) -fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset - -fun classes_of_terms get_Ts = - map (map snd o get_Ts) - #> List.foldl add_classes Symtab.empty - #> delete_type #> Symtab.keys - -val tfree_classes_of_terms = classes_of_terms Misc_Legacy.term_tfrees -val tvar_classes_of_terms = classes_of_terms Misc_Legacy.term_tvars - -fun fold_type_constrs f (Type (s, Ts)) x = - fold (fold_type_constrs f) Ts (f (s, x)) - | fold_type_constrs _ _ x = x - -(* Type constructors used to instantiate overloaded constants are the only ones - needed. *) -fun add_type_constrs_in_term thy = - let - fun add (Const (@{const_name Meson.skolem}, _) $ _) = I - | add (t $ u) = add t #> add u - | add (Const x) = - x |> robust_const_typargs thy |> fold (fold_type_constrs set_insert) - | add (Abs (_, _, u)) = add u - | add _ = I - in add end - -fun type_constrs_of_terms thy ts = - Symtab.keys (fold (add_type_constrs_in_term thy) ts Symtab.empty) - -fun extract_lambda_def (Const (@{const_name HOL.eq}, _) $ t $ u) = - let val (head, args) = strip_comb t in - (head |> dest_Const |> fst, - fold_rev (fn t as Var ((s, _), T) => - (fn u => Abs (s, T, abstract_over (t, u))) - | _ => raise Fail "expected Var") args u) - end - | extract_lambda_def _ = raise Fail "malformed lifted lambda" - -fun trans_lams_from_string ctxt type_enc lam_trans = - if lam_trans = no_lamsN then - rpair [] - else if lam_trans = hide_lamsN then - lift_lams ctxt type_enc ##> K [] - else if lam_trans = lam_liftingN then - lift_lams ctxt type_enc - else if lam_trans = combinatorsN then - map (introduce_combinators ctxt) #> rpair [] - else if lam_trans = hybrid_lamsN then - lift_lams_part_1 ctxt type_enc - ##> maps (fn t => [t, introduce_combinators ctxt (intentionalize_def t)]) - #> lift_lams_part_2 - else if lam_trans = keep_lamsN then - map (Envir.eta_contract) #> rpair [] - else - error ("Unknown lambda translation scheme: " ^ quote lam_trans ^ ".") - -fun translate_formulas ctxt format prem_kind type_enc lam_trans presimp hyp_ts - concl_t facts = - let - val thy = Proof_Context.theory_of ctxt - val trans_lams = trans_lams_from_string ctxt type_enc lam_trans - val fact_ts = facts |> map snd - (* Remove existing facts from the conjecture, as this can dramatically - boost an ATP's performance (for some reason). *) - val hyp_ts = - hyp_ts - |> map (fn t => if member (op aconv) fact_ts t then @{prop True} else t) - val facts = facts |> map (apsnd (pair Axiom)) - val conjs = - map (pair prem_kind) hyp_ts @ [(Conjecture, s_not_trueprop concl_t)] - |> map (apsnd freeze_term) - |> map2 (pair o rpair Local o string_of_int) (0 upto length hyp_ts) - val ((conjs, facts), lam_facts) = - (conjs, facts) - |> presimp ? pairself (map (apsnd (uncurry (presimp_prop ctxt)))) - |> (if lam_trans = no_lamsN then - rpair [] - else - op @ - #> preprocess_abstractions_in_terms trans_lams - #>> chop (length conjs)) - val conjs = conjs |> make_conjecture ctxt format type_enc - val (fact_names, facts) = - facts - |> map_filter (fn (name, (_, t)) => - make_fact ctxt format type_enc true (name, t) - |> Option.map (pair name)) - |> ListPair.unzip - val lifted = lam_facts |> map (extract_lambda_def o snd o snd) - val lam_facts = - lam_facts |> map_filter (make_fact ctxt format type_enc true o apsnd snd) - val all_ts = concl_t :: hyp_ts @ fact_ts - val subs = tfree_classes_of_terms all_ts - val supers = tvar_classes_of_terms all_ts - val tycons = type_constrs_of_terms thy all_ts - val (supers, arity_clauses) = - if level_of_type_enc type_enc = No_Types then ([], []) - else make_arity_clauses thy tycons supers - val class_rel_clauses = make_class_rel_clauses thy subs supers - in - (fact_names |> map single, union (op =) subs supers, conjs, - facts @ lam_facts, class_rel_clauses, arity_clauses, lifted) - end - -val type_guard = `(make_fixed_const NONE) type_guard_name - -fun type_guard_iterm format type_enc T tm = - IApp (IConst (type_guard, T --> @{typ bool}, [T]) - |> mangle_type_args_in_iterm format type_enc, tm) - -fun is_var_positively_naked_in_term _ (SOME false) _ accum = accum - | is_var_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum = - accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, []))) - | is_var_positively_naked_in_term _ _ _ _ = true - -fun is_var_ghost_type_arg_in_term thy polym_constrs name pos tm accum = - is_var_positively_naked_in_term name pos tm accum orelse - let - val var = ATerm (name, []) - fun is_nasty_in_term (ATerm (_, [])) = false - | is_nasty_in_term (ATerm ((s, _), tms)) = - let - val ary = length tms - val polym_constr = member (op =) polym_constrs s - val ghosts = ghost_type_args thy s ary - in - exists (fn (j, tm) => - if polym_constr then - member (op =) ghosts j andalso - (tm = var orelse is_nasty_in_term tm) - else - tm = var andalso member (op =) ghosts j) - (0 upto ary - 1 ~~ tms) - orelse (not polym_constr andalso exists is_nasty_in_term tms) - end - | is_nasty_in_term _ = true - in is_nasty_in_term tm end - -fun should_guard_var_in_formula thy polym_constrs level pos phi (SOME true) - name = - (case granularity_of_type_level level of - All_Vars => true - | Positively_Naked_Vars => - formula_fold pos (is_var_positively_naked_in_term name) phi false - | Ghost_Type_Arg_Vars => - formula_fold pos (is_var_ghost_type_arg_in_term thy polym_constrs name) - phi false) - | should_guard_var_in_formula _ _ _ _ _ _ _ = true - -fun always_guard_var_in_formula _ _ _ _ _ _ _ = true - -fun should_generate_tag_bound_decl _ _ _ (SOME true) _ = false - | should_generate_tag_bound_decl ctxt mono (Tags (_, level)) _ T = - granularity_of_type_level level <> All_Vars andalso - should_encode_type ctxt mono level T - | should_generate_tag_bound_decl _ _ _ _ _ = false - -fun mk_aterm format type_enc name T_args args = - ATerm (name, map_filter (ho_term_for_type_arg format type_enc) T_args @ args) - -fun tag_with_type ctxt format mono type_enc pos T tm = - IConst (type_tag, T --> T, [T]) - |> mangle_type_args_in_iterm format type_enc - |> ho_term_from_iterm ctxt format mono type_enc pos - |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm]) - | _ => raise Fail "unexpected lambda-abstraction") -and ho_term_from_iterm ctxt format mono type_enc = - let - fun term site u = - let - val (head, args) = strip_iterm_comb u - val pos = - case site of - Top_Level pos => pos - | Eq_Arg pos => pos - | _ => NONE - val t = - case head of - IConst (name as (s, _), _, T_args) => - let - val arg_site = if is_tptp_equal s then Eq_Arg pos else Elsewhere - in - map (term arg_site) args |> mk_aterm format type_enc name T_args - end - | IVar (name, _) => - map (term Elsewhere) args |> mk_aterm format type_enc name [] - | IAbs ((name, T), tm) => - AAbs ((name, ho_type_from_typ format type_enc true 0 T), - term Elsewhere tm) - | IApp _ => raise Fail "impossible \"IApp\"" - val T = ityp_of u - in - if should_tag_with_type ctxt mono type_enc site u T then - tag_with_type ctxt format mono type_enc pos T t - else - t - end - in term o Top_Level end -and formula_from_iformula ctxt polym_constrs format mono type_enc - should_guard_var = - let - val thy = Proof_Context.theory_of ctxt - val level = level_of_type_enc type_enc - val do_term = ho_term_from_iterm ctxt format mono type_enc - val do_bound_type = - case type_enc of - Simple_Types _ => fused_type ctxt mono level 0 - #> ho_type_from_typ format type_enc false 0 #> SOME - | _ => K NONE - fun do_out_of_bound_type pos phi universal (name, T) = - if should_guard_type ctxt mono type_enc - (fn () => should_guard_var thy polym_constrs level pos phi - universal name) T then - IVar (name, T) - |> type_guard_iterm format type_enc T - |> do_term pos |> AAtom |> SOME - else if should_generate_tag_bound_decl ctxt mono type_enc universal T then - let - val var = ATerm (name, []) - val tagged_var = tag_with_type ctxt format mono type_enc pos T var - in SOME (AAtom (ATerm (`I tptp_equal, [tagged_var, var]))) end - else - NONE - fun do_formula pos (AQuant (q, xs, phi)) = - let - val phi = phi |> do_formula pos - val universal = Option.map (q = AExists ? not) pos - in - AQuant (q, xs |> map (apsnd (fn NONE => NONE - | SOME T => do_bound_type T)), - (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd)) - (map_filter - (fn (_, NONE) => NONE - | (s, SOME T) => - do_out_of_bound_type pos phi universal (s, T)) - xs) - phi) - end - | do_formula pos (AConn conn) = aconn_map pos do_formula conn - | do_formula pos (AAtom tm) = AAtom (do_term pos tm) - in do_formula end - -(* Each fact is given a unique fact number to avoid name clashes (e.g., because - of monomorphization). The TPTP explicitly forbids name clashes, and some of - the remote provers might care. *) -fun formula_line_for_fact ctxt polym_constrs format prefix encode freshen pos - mono type_enc (j, {name, locality, kind, iformula, atomic_types}) = - (prefix ^ (if freshen then string_of_int j ^ "_" else "") ^ encode name, kind, - iformula - |> formula_from_iformula ctxt polym_constrs format mono type_enc - should_guard_var_in_formula (if pos then SOME true else NONE) - |> close_formula_universally - |> bound_tvars type_enc true atomic_types, - NONE, - case locality of - Intro => isabelle_info format introN - | Elim => isabelle_info format elimN - | Simp => isabelle_info format simpN - | _ => NONE) - |> Formula - -fun formula_line_for_class_rel_clause format type_enc - ({name, subclass, superclass, ...} : class_rel_clause) = - let val ty_arg = ATerm (tvar_a_name, []) in - Formula (class_rel_clause_prefix ^ ascii_of name, Axiom, - AConn (AImplies, - [type_class_formula type_enc subclass ty_arg, - type_class_formula type_enc superclass ty_arg]) - |> mk_aquant AForall - [(tvar_a_name, atype_of_type_vars type_enc)], - isabelle_info format introN, NONE) - end - -fun formula_from_arity_atom type_enc (class, t, args) = - ATerm (t, map (fn arg => ATerm (arg, [])) args) - |> type_class_formula type_enc class - -fun formula_line_for_arity_clause format type_enc - ({name, prem_atoms, concl_atom} : arity_clause) = - Formula (arity_clause_prefix ^ name, Axiom, - mk_ahorn (map (formula_from_arity_atom type_enc) prem_atoms) - (formula_from_arity_atom type_enc concl_atom) - |> mk_aquant AForall - (map (rpair (atype_of_type_vars type_enc)) (#3 concl_atom)), - isabelle_info format introN, NONE) - -fun formula_line_for_conjecture ctxt polym_constrs format mono type_enc - ({name, kind, iformula, atomic_types, ...} : translated_formula) = - Formula (conjecture_prefix ^ name, kind, - iformula - |> formula_from_iformula ctxt polym_constrs format mono type_enc - should_guard_var_in_formula (SOME false) - |> close_formula_universally - |> bound_tvars type_enc true atomic_types, NONE, NONE) - -fun formula_line_for_free_type j phi = - Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, phi, NONE, NONE) -fun formula_lines_for_free_types type_enc (facts : translated_formula list) = - let - val phis = - fold (union (op =)) (map #atomic_types facts) [] - |> formulas_for_types type_enc add_sorts_on_tfree - in map2 formula_line_for_free_type (0 upto length phis - 1) phis end - -(** Symbol declarations **) - -fun decl_line_for_class order s = - let val name as (s, _) = `make_type_class s in - Decl (sym_decl_prefix ^ s, name, - if order = First_Order then - ATyAbs ([tvar_a_name], - if avoid_first_order_ghost_type_vars then - AFun (a_itself_atype, bool_atype) - else - bool_atype) - else - AFun (atype_of_types, bool_atype)) - end - -fun decl_lines_for_classes type_enc classes = - case type_enc of - Simple_Types (order, Polymorphic, _) => - map (decl_line_for_class order) classes - | _ => [] - -fun sym_decl_table_for_facts ctxt format type_enc sym_tab (conjs, facts) = - let - fun add_iterm_syms tm = - let val (head, args) = strip_iterm_comb tm in - (case head of - IConst ((s, s'), T, T_args) => - let - val (pred_sym, in_conj) = - case Symtab.lookup sym_tab s of - SOME ({pred_sym, in_conj, ...} : sym_info) => - (pred_sym, in_conj) - | NONE => (false, false) - val decl_sym = - (case type_enc of - Guards _ => not pred_sym - | _ => true) andalso - is_tptp_user_symbol s - in - if decl_sym then - Symtab.map_default (s, []) - (insert_type ctxt #3 (s', T_args, T, pred_sym, length args, - in_conj)) - else - I - end - | IAbs (_, tm) => add_iterm_syms tm - | _ => I) - #> fold add_iterm_syms args - end - val add_fact_syms = K add_iterm_syms |> formula_fold NONE |> fact_lift - fun add_formula_var_types (AQuant (_, xs, phi)) = - fold (fn (_, SOME T) => insert_type ctxt I T | _ => I) xs - #> add_formula_var_types phi - | add_formula_var_types (AConn (_, phis)) = - fold add_formula_var_types phis - | add_formula_var_types _ = I - fun var_types () = - if polymorphism_of_type_enc type_enc = Polymorphic then [tvar_a] - else fold (fact_lift add_formula_var_types) (conjs @ facts) [] - fun add_undefined_const T = - let - val (s, s') = - `(make_fixed_const NONE) @{const_name undefined} - |> (case type_arg_policy [] type_enc @{const_name undefined} of - Mangled_Type_Args => mangled_const_name format type_enc [T] - | _ => I) - in - Symtab.map_default (s, []) - (insert_type ctxt #3 (s', [T], T, false, 0, false)) - end - fun add_TYPE_const () = - let val (s, s') = TYPE_name in - Symtab.map_default (s, []) - (insert_type ctxt #3 - (s', [tvar_a], @{typ "'a itself"}, false, 0, false)) - end - in - Symtab.empty - |> is_type_enc_fairly_sound type_enc - ? (fold (fold add_fact_syms) [conjs, facts] - #> (case type_enc of - Simple_Types (First_Order, Polymorphic, _) => - if avoid_first_order_ghost_type_vars then add_TYPE_const () - else I - | Simple_Types _ => I - | _ => fold add_undefined_const (var_types ()))) - end - -(* We add "bool" in case the helper "True_or_False" is included later. *) -fun default_mono level = - {maybe_finite_Ts = [@{typ bool}], - surely_finite_Ts = [@{typ bool}], - maybe_infinite_Ts = known_infinite_types, - surely_infinite_Ts = - case level of - Noninf_Nonmono_Types (Strict, _) => [] - | _ => known_infinite_types, - maybe_nonmono_Ts = [@{typ bool}]} - -(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it - out with monotonicity" paper presented at CADE 2011. *) -fun add_iterm_mononotonicity_info _ _ (SOME false) _ mono = mono - | add_iterm_mononotonicity_info ctxt level _ - (IApp (IApp (IConst ((s, _), Type (_, [T, _]), _), tm1), tm2)) - (mono as {maybe_finite_Ts, surely_finite_Ts, maybe_infinite_Ts, - surely_infinite_Ts, maybe_nonmono_Ts}) = - if is_tptp_equal s andalso exists is_maybe_universal_var [tm1, tm2] then - case level of - Noninf_Nonmono_Types (strictness, _) => - if exists (type_instance ctxt T) surely_infinite_Ts orelse - member (type_equiv ctxt) maybe_finite_Ts T then - mono - else if is_type_kind_of_surely_infinite ctxt strictness - surely_infinite_Ts T then - {maybe_finite_Ts = maybe_finite_Ts, - surely_finite_Ts = surely_finite_Ts, - maybe_infinite_Ts = maybe_infinite_Ts, - surely_infinite_Ts = surely_infinite_Ts |> insert_type ctxt I T, - maybe_nonmono_Ts = maybe_nonmono_Ts} - else - {maybe_finite_Ts = maybe_finite_Ts |> insert (type_equiv ctxt) T, - surely_finite_Ts = surely_finite_Ts, - maybe_infinite_Ts = maybe_infinite_Ts, - surely_infinite_Ts = surely_infinite_Ts, - maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T} - | Fin_Nonmono_Types _ => - if exists (type_instance ctxt T) surely_finite_Ts orelse - member (type_equiv ctxt) maybe_infinite_Ts T then - mono - else if is_type_surely_finite ctxt T then - {maybe_finite_Ts = maybe_finite_Ts, - surely_finite_Ts = surely_finite_Ts |> insert_type ctxt I T, - maybe_infinite_Ts = maybe_infinite_Ts, - surely_infinite_Ts = surely_infinite_Ts, - maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T} - else - {maybe_finite_Ts = maybe_finite_Ts, - surely_finite_Ts = surely_finite_Ts, - maybe_infinite_Ts = maybe_infinite_Ts |> insert (type_equiv ctxt) T, - surely_infinite_Ts = surely_infinite_Ts, - maybe_nonmono_Ts = maybe_nonmono_Ts} - | _ => mono - else - mono - | add_iterm_mononotonicity_info _ _ _ _ mono = mono -fun add_fact_mononotonicity_info ctxt level - ({kind, iformula, ...} : translated_formula) = - formula_fold (SOME (kind <> Conjecture)) - (add_iterm_mononotonicity_info ctxt level) iformula -fun mononotonicity_info_for_facts ctxt type_enc facts = - let val level = level_of_type_enc type_enc in - default_mono level - |> is_type_level_monotonicity_based level - ? fold (add_fact_mononotonicity_info ctxt level) facts - end - -fun add_iformula_monotonic_types ctxt mono type_enc = - let - val level = level_of_type_enc type_enc - val should_encode = should_encode_type ctxt mono level - fun add_type T = not (should_encode T) ? insert_type ctxt I T - fun add_args (IApp (tm1, tm2)) = add_args tm1 #> add_term tm2 - | add_args _ = I - and add_term tm = add_type (ityp_of tm) #> add_args tm - in formula_fold NONE (K add_term) end -fun add_fact_monotonic_types ctxt mono type_enc = - add_iformula_monotonic_types ctxt mono type_enc |> fact_lift -fun monotonic_types_for_facts ctxt mono type_enc facts = - let val level = level_of_type_enc type_enc in - [] |> (polymorphism_of_type_enc type_enc = Polymorphic andalso - is_type_level_monotonicity_based level andalso - granularity_of_type_level level <> Ghost_Type_Arg_Vars) - ? fold (add_fact_monotonic_types ctxt mono type_enc) facts - end - -fun formula_line_for_guards_mono_type ctxt format mono type_enc T = - Formula (guards_sym_formula_prefix ^ - ascii_of (mangled_type format type_enc T), - Axiom, - IConst (`make_bound_var "X", T, []) - |> type_guard_iterm format type_enc T - |> AAtom - |> formula_from_iformula ctxt [] format mono type_enc - always_guard_var_in_formula (SOME true) - |> close_formula_universally - |> bound_tvars type_enc true (atomic_types_of T), - isabelle_info format introN, NONE) - -fun formula_line_for_tags_mono_type ctxt format mono type_enc T = - let val x_var = ATerm (`make_bound_var "X", []) in - Formula (tags_sym_formula_prefix ^ - ascii_of (mangled_type format type_enc T), - Axiom, - eq_formula type_enc (atomic_types_of T) false - (tag_with_type ctxt format mono type_enc NONE T x_var) x_var, - isabelle_info format simpN, NONE) - end - -fun problem_lines_for_mono_types ctxt format mono type_enc Ts = - case type_enc of - Simple_Types _ => [] - | Guards _ => - map (formula_line_for_guards_mono_type ctxt format mono type_enc) Ts - | Tags _ => map (formula_line_for_tags_mono_type ctxt format mono type_enc) Ts - -fun decl_line_for_sym ctxt format mono type_enc s - (s', T_args, T, pred_sym, ary, _) = - let - val thy = Proof_Context.theory_of ctxt - val (T, T_args) = - if null T_args then - (T, []) - else case unprefix_and_unascii const_prefix s of - SOME s' => - let - val s' = s' |> invert_const - val T = s' |> robust_const_type thy - in (T, robust_const_typargs thy (s', T)) end - | NONE => raise Fail "unexpected type arguments" - in - Decl (sym_decl_prefix ^ s, (s, s'), - T |> fused_type ctxt mono (level_of_type_enc type_enc) ary - |> ho_type_from_typ format type_enc pred_sym ary - |> not (null T_args) - ? curry ATyAbs (map (tvar_name o fst o dest_TVar) T_args)) - end - -fun formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono type_enc n s - j (s', T_args, T, _, ary, in_conj) = - let - val thy = Proof_Context.theory_of ctxt - val (kind, maybe_negate) = - if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot) - else (Axiom, I) - val (arg_Ts, res_T) = chop_fun ary T - val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int) - val bounds = - bound_names ~~ arg_Ts |> map (fn (name, T) => IConst (name, T, [])) - val bound_Ts = - if exists (curry (op =) dummyT) T_args then - case level_of_type_enc type_enc of - All_Types => map SOME arg_Ts - | level => - if granularity_of_type_level level = Ghost_Type_Arg_Vars then - let val ghosts = ghost_type_args thy s ary in - map2 (fn j => if member (op =) ghosts j then SOME else K NONE) - (0 upto ary - 1) arg_Ts - end - else - replicate ary NONE - else - replicate ary NONE - in - Formula (guards_sym_formula_prefix ^ s ^ - (if n > 1 then "_" ^ string_of_int j else ""), kind, - IConst ((s, s'), T, T_args) - |> fold (curry (IApp o swap)) bounds - |> type_guard_iterm format type_enc res_T - |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts) - |> formula_from_iformula ctxt [] format mono type_enc - always_guard_var_in_formula (SOME true) - |> close_formula_universally - |> bound_tvars type_enc (n > 1) (atomic_types_of T) - |> maybe_negate, - isabelle_info format introN, NONE) - end - -fun formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono type_enc n s - (j, (s', T_args, T, pred_sym, ary, in_conj)) = - let - val thy = Proof_Context.theory_of ctxt - val level = level_of_type_enc type_enc - val grain = granularity_of_type_level level - val ident_base = - tags_sym_formula_prefix ^ s ^ - (if n > 1 then "_" ^ string_of_int j else "") - val (kind, maybe_negate) = - if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot) - else (Axiom, I) - val (arg_Ts, res_T) = chop_fun ary T - val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int) - val bounds = bound_names |> map (fn name => ATerm (name, [])) - val cst = mk_aterm format type_enc (s, s') T_args - val eq = maybe_negate oo eq_formula type_enc (atomic_types_of T) pred_sym - val should_encode = should_encode_type ctxt mono level - val tag_with = tag_with_type ctxt format mono type_enc NONE - val add_formula_for_res = - if should_encode res_T then - let - val tagged_bounds = - if grain = Ghost_Type_Arg_Vars then - let val ghosts = ghost_type_args thy s ary in - map2 (fn (j, arg_T) => member (op =) ghosts j ? tag_with arg_T) - (0 upto ary - 1 ~~ arg_Ts) bounds - end - else - bounds - in - cons (Formula (ident_base ^ "_res", kind, - eq (tag_with res_T (cst bounds)) (cst tagged_bounds), - isabelle_info format simpN, NONE)) - end - else - I - fun add_formula_for_arg k = - let val arg_T = nth arg_Ts k in - if should_encode arg_T then - case chop k bounds of - (bounds1, bound :: bounds2) => - cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind, - eq (cst (bounds1 @ tag_with arg_T bound :: bounds2)) - (cst bounds), - isabelle_info format simpN, NONE)) - | _ => raise Fail "expected nonempty tail" - else - I - end - in - [] |> not pred_sym ? add_formula_for_res - |> (Config.get ctxt type_tag_arguments andalso - grain = Positively_Naked_Vars) - ? fold add_formula_for_arg (ary - 1 downto 0) - end - -fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd - -fun rationalize_decls ctxt (decls as decl :: (decls' as _ :: _)) = - let - val T = result_type_of_decl decl - |> map_type_tvar (fn (z, _) => TVar (z, HOLogic.typeS)) - in - if forall (type_generalization ctxt T o result_type_of_decl) decls' then - [decl] - else - decls - end - | rationalize_decls _ decls = decls - -fun problem_lines_for_sym_decls ctxt format conj_sym_kind mono type_enc - (s, decls) = - case type_enc of - Simple_Types _ => [decl_line_for_sym ctxt format mono type_enc s (hd decls)] - | Guards (_, level) => - let - val decls = decls |> rationalize_decls ctxt - val n = length decls - val decls = - decls |> filter (should_encode_type ctxt mono level - o result_type_of_decl) - in - (0 upto length decls - 1, decls) - |-> map2 (formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono - type_enc n s) - end - | Tags (_, level) => - if granularity_of_type_level level = All_Vars then - [] - else - let val n = length decls in - (0 upto n - 1 ~~ decls) - |> maps (formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono - type_enc n s) - end - -fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono type_enc - mono_Ts sym_decl_tab = - let - val syms = sym_decl_tab |> Symtab.dest |> sort_wrt fst - val mono_lines = - problem_lines_for_mono_types ctxt format mono type_enc mono_Ts - val decl_lines = - fold_rev (append o problem_lines_for_sym_decls ctxt format conj_sym_kind - mono type_enc) - syms [] - in mono_lines @ decl_lines end - -fun needs_type_tag_idempotence ctxt (Tags (poly, level)) = - Config.get ctxt type_tag_idempotence andalso - is_type_level_monotonicity_based level andalso - poly <> Mangled_Monomorphic - | needs_type_tag_idempotence _ _ = false - -val implicit_declsN = "Should-be-implicit typings" -val explicit_declsN = "Explicit typings" -val factsN = "Relevant facts" -val class_relsN = "Class relationships" -val aritiesN = "Arities" -val helpersN = "Helper facts" -val conjsN = "Conjectures" -val free_typesN = "Type variables" - -(* TFF allows implicit declarations of types, function symbols, and predicate - symbols (with "$i" as the type of individuals), but some provers (e.g., - SNARK) require explicit declarations. The situation is similar for THF. *) - -fun default_type type_enc pred_sym s = - let - val ind = - case type_enc of - Simple_Types _ => - if String.isPrefix type_const_prefix s then atype_of_types - else individual_atype - | _ => individual_atype - fun typ 0 = if pred_sym then bool_atype else ind - | typ ary = AFun (ind, typ (ary - 1)) - in typ end - -fun nary_type_constr_type n = - funpow n (curry AFun atype_of_types) atype_of_types - -fun undeclared_syms_in_problem type_enc problem = - let - val declared = declared_syms_in_problem problem - fun do_sym name ty = - if member (op =) declared name then I else AList.default (op =) (name, ty) - fun do_type (AType (name as (s, _), tys)) = - is_tptp_user_symbol s - ? do_sym name (fn () => nary_type_constr_type (length tys)) - #> fold do_type tys - | do_type (AFun (ty1, ty2)) = do_type ty1 #> do_type ty2 - | do_type (ATyAbs (_, ty)) = do_type ty - fun do_term pred_sym (ATerm (name as (s, _), tms)) = - is_tptp_user_symbol s - ? do_sym name (fn _ => default_type type_enc pred_sym s (length tms)) - #> fold (do_term false) tms - | do_term _ (AAbs ((_, ty), tm)) = do_type ty #> do_term false tm - fun do_formula (AQuant (_, xs, phi)) = - fold do_type (map_filter snd xs) #> do_formula phi - | do_formula (AConn (_, phis)) = fold do_formula phis - | do_formula (AAtom tm) = do_term true tm - fun do_problem_line (Decl (_, _, ty)) = do_type ty - | do_problem_line (Formula (_, _, phi, _, _)) = do_formula phi - in - fold (fold do_problem_line o snd) problem [] - |> filter_out (is_built_in_tptp_symbol o fst o fst) - end - -fun declare_undeclared_syms_in_atp_problem type_enc problem = - let - val decls = - problem - |> undeclared_syms_in_problem type_enc - |> sort_wrt (fst o fst) - |> map (fn (x as (s, _), ty) => Decl (type_decl_prefix ^ s, x, ty ())) - in (implicit_declsN, decls) :: problem end - -fun exists_subdtype P = - let - fun ex U = P U orelse - (case U of Datatype.DtType (_, Us) => exists ex Us | _ => false) - in ex end - -fun is_poly_constr (_, Us) = - exists (exists_subdtype (fn Datatype.DtTFree _ => true | _ => false)) Us - -fun all_constrs_of_polymorphic_datatypes thy = - Symtab.fold (snd - #> #descr - #> maps (snd #> #3) - #> (fn cs => exists is_poly_constr cs ? append cs)) - (Datatype.get_all thy) [] - |> List.partition is_poly_constr - |> pairself (map fst) - -(* Forcing explicit applications is expensive for polymorphic encodings, because - it takes only one existential variable ranging over "'a => 'b" to ruin - everything. Hence we do it only if there are few facts (is normally the case - for "metis" and the minimizer. *) -val explicit_apply_threshold = 50 - -fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_enc exporter - lam_trans readable_names preproc hyp_ts concl_t facts = - let - val thy = Proof_Context.theory_of ctxt - val type_enc = type_enc |> adjust_type_enc format - val explicit_apply = - if polymorphism_of_type_enc type_enc <> Polymorphic orelse - length facts <= explicit_apply_threshold then - NONE - else - SOME false - val lam_trans = - if lam_trans = keep_lamsN andalso - not (is_type_enc_higher_order type_enc) then - error ("Lambda translation scheme incompatible with first-order \ - \encoding.") - else - lam_trans - val (fact_names, classes, conjs, facts, class_rel_clauses, arity_clauses, - lifted) = - translate_formulas ctxt format prem_kind type_enc lam_trans preproc hyp_ts - concl_t facts - val sym_tab = sym_table_for_facts ctxt type_enc explicit_apply conjs facts - val mono = conjs @ facts |> mononotonicity_info_for_facts ctxt type_enc - val (polym_constrs, monom_constrs) = - all_constrs_of_polymorphic_datatypes thy - |>> map (make_fixed_const (SOME format)) - val firstorderize = - firstorderize_fact thy monom_constrs format type_enc sym_tab - val (conjs, facts) = (conjs, facts) |> pairself (map firstorderize) - val sym_tab = sym_table_for_facts ctxt type_enc (SOME false) conjs facts - val helpers = - sym_tab |> helper_facts_for_sym_table ctxt format type_enc - |> map firstorderize - val mono_Ts = - helpers @ conjs @ facts |> monotonic_types_for_facts ctxt mono type_enc - val class_decl_lines = decl_lines_for_classes type_enc classes - val sym_decl_lines = - (conjs, helpers @ facts) - |> sym_decl_table_for_facts ctxt format type_enc sym_tab - |> problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono - type_enc mono_Ts - val helper_lines = - 0 upto length helpers - 1 ~~ helpers - |> map (formula_line_for_fact ctxt polym_constrs format helper_prefix I - false true mono type_enc) - |> (if needs_type_tag_idempotence ctxt type_enc then - cons (type_tag_idempotence_fact format type_enc) - else - I) - (* Reordering these might confuse the proof reconstruction code or the SPASS - FLOTTER hack. *) - val problem = - [(explicit_declsN, class_decl_lines @ sym_decl_lines), - (factsN, - map (formula_line_for_fact ctxt polym_constrs format fact_prefix - ascii_of (not exporter) (not exporter) mono type_enc) - (0 upto length facts - 1 ~~ facts)), - (class_relsN, - map (formula_line_for_class_rel_clause format type_enc) - class_rel_clauses), - (aritiesN, - map (formula_line_for_arity_clause format type_enc) arity_clauses), - (helpersN, helper_lines), - (conjsN, - map (formula_line_for_conjecture ctxt polym_constrs format mono - type_enc) conjs), - (free_typesN, formula_lines_for_free_types type_enc (facts @ conjs))] - val problem = - problem - |> (case format of - CNF => ensure_cnf_problem - | CNF_UEQ => filter_cnf_ueq_problem - | FOF => I - | TFF (_, TPTP_Implicit) => I - | THF (_, TPTP_Implicit, _) => I - | _ => declare_undeclared_syms_in_atp_problem type_enc) - val (problem, pool) = problem |> nice_atp_problem readable_names format - fun add_sym_ary (s, {min_ary, ...} : sym_info) = - min_ary > 0 ? Symtab.insert (op =) (s, min_ary) - in - (problem, - case pool of SOME the_pool => snd the_pool | NONE => Symtab.empty, - fact_names |> Vector.fromList, - lifted, - Symtab.empty |> Symtab.fold add_sym_ary sym_tab) - end - -(* FUDGE *) -val conj_weight = 0.0 -val hyp_weight = 0.1 -val fact_min_weight = 0.2 -val fact_max_weight = 1.0 -val type_info_default_weight = 0.8 - -fun add_term_weights weight (ATerm (s, tms)) = - is_tptp_user_symbol s ? Symtab.default (s, weight) - #> fold (add_term_weights weight) tms - | add_term_weights weight (AAbs (_, tm)) = add_term_weights weight tm -fun add_problem_line_weights weight (Formula (_, _, phi, _, _)) = - formula_fold NONE (K (add_term_weights weight)) phi - | add_problem_line_weights _ _ = I - -fun add_conjectures_weights [] = I - | add_conjectures_weights conjs = - let val (hyps, conj) = split_last conjs in - add_problem_line_weights conj_weight conj - #> fold (add_problem_line_weights hyp_weight) hyps - end - -fun add_facts_weights facts = - let - val num_facts = length facts - fun weight_of j = - fact_min_weight + (fact_max_weight - fact_min_weight) * Real.fromInt j - / Real.fromInt num_facts - in - map weight_of (0 upto num_facts - 1) ~~ facts - |> fold (uncurry add_problem_line_weights) - end - -(* Weights are from 0.0 (most important) to 1.0 (least important). *) -fun atp_problem_weights problem = - let val get = these o AList.lookup (op =) problem in - Symtab.empty - |> add_conjectures_weights (get free_typesN @ get conjsN) - |> add_facts_weights (get factsN) - |> fold (fold (add_problem_line_weights type_info_default_weight) o get) - [explicit_declsN, class_relsN, aritiesN] - |> Symtab.dest - |> sort (prod_ord Real.compare string_ord o pairself swap) - end - -end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Metis/metis_generate.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/Metis/metis_generate.ML Mon Jan 23 17:40:32 2012 +0100 @@ -0,0 +1,256 @@ +(* Title: HOL/Tools/Metis/metis_generate.ML + Author: Jia Meng, Cambridge University Computer Laboratory and NICTA + Author: Kong W. Susanto, Cambridge University Computer Laboratory + Author: Lawrence C. Paulson, Cambridge University Computer Laboratory + Author: Jasmin Blanchette, TU Muenchen + +Translation of HOL to FOL for Metis. +*) + +signature METIS_GENERATE = +sig + type type_enc = ATP_Problem_Generate.type_enc + + datatype isa_thm = + Isa_Reflexive_or_Trivial | + Isa_Lambda_Lifted | + Isa_Raw of thm + + val metis_equal : string + val metis_predicator : string + val metis_app_op : string + val metis_systematic_type_tag : string + val metis_ad_hoc_type_tag : string + val metis_generated_var_prefix : string + val trace : bool Config.T + val verbose : bool Config.T + val trace_msg : Proof.context -> (unit -> string) -> unit + val verbose_warning : Proof.context -> string -> unit + val metis_name_table : ((string * int) * ((type_enc -> string) * bool)) list + val reveal_old_skolem_terms : (string * term) list -> term -> term + val reveal_lam_lifted : (string * term) list -> term -> term + val prepare_metis_problem : + Proof.context -> type_enc -> string -> thm list -> thm list + -> int Symtab.table * (Metis_Thm.thm * isa_thm) list + * ((string * term) list * (string * term) list) +end + +structure Metis_Generate : METIS_GENERATE = +struct + +open ATP_Problem +open ATP_Problem_Generate + +val metis_equal = "=" +val metis_predicator = "{}" +val metis_app_op = Metis_Name.toString Metis_Term.appName +val metis_systematic_type_tag = + Metis_Name.toString Metis_Term.hasTypeFunctionName +val metis_ad_hoc_type_tag = "**" +val metis_generated_var_prefix = "_" + +val trace = Attrib.setup_config_bool @{binding metis_trace} (K false) +val verbose = Attrib.setup_config_bool @{binding metis_verbose} (K true) + +fun trace_msg ctxt msg = if Config.get ctxt trace then tracing (msg ()) else () +fun verbose_warning ctxt msg = + if Config.get ctxt verbose then warning ("Metis: " ^ msg) else () + +val metis_name_table = + [((tptp_equal, 2), (K metis_equal, false)), + ((tptp_old_equal, 2), (K metis_equal, false)), + ((prefixed_predicator_name, 1), (K metis_predicator, false)), + ((prefixed_app_op_name, 2), (K metis_app_op, false)), + ((prefixed_type_tag_name, 2), + (fn type_enc => + if level_of_type_enc type_enc = All_Types then metis_systematic_type_tag + else metis_ad_hoc_type_tag, true))] + +fun old_skolem_const_name i j num_T_args = + old_skolem_const_prefix ^ Long_Name.separator ^ + (space_implode Long_Name.separator (map string_of_int [i, j, num_T_args])) + +fun conceal_old_skolem_terms i old_skolems t = + if exists_Const (curry (op =) @{const_name Meson.skolem} o fst) t then + let + fun aux old_skolems + (t as (Const (@{const_name Meson.skolem}, Type (_, [_, T])) $ _)) = + let + val (old_skolems, s) = + if i = ~1 then + (old_skolems, @{const_name undefined}) + else case AList.find (op aconv) old_skolems t of + s :: _ => (old_skolems, s) + | [] => + let + val s = old_skolem_const_name i (length old_skolems) + (length (Term.add_tvarsT T [])) + in ((s, t) :: old_skolems, s) end + in (old_skolems, Const (s, T)) end + | aux old_skolems (t1 $ t2) = + let + val (old_skolems, t1) = aux old_skolems t1 + val (old_skolems, t2) = aux old_skolems t2 + in (old_skolems, t1 $ t2) end + | aux old_skolems (Abs (s, T, t')) = + let val (old_skolems, t') = aux old_skolems t' in + (old_skolems, Abs (s, T, t')) + end + | aux old_skolems t = (old_skolems, t) + in aux old_skolems t end + else + (old_skolems, t) + +fun reveal_old_skolem_terms old_skolems = + map_aterms (fn t as Const (s, _) => + if String.isPrefix old_skolem_const_prefix s then + AList.lookup (op =) old_skolems s |> the + |> map_types (map_type_tvar (K dummyT)) + else + t + | t => t) + +fun reveal_lam_lifted lambdas = + map_aterms (fn t as Const (s, _) => + if String.isPrefix lam_lifted_prefix s then + case AList.lookup (op =) lambdas s of + SOME t => + Const (@{const_name Metis.lambda}, dummyT) + $ map_types (map_type_tvar (K dummyT)) + (reveal_lam_lifted lambdas t) + | NONE => t + else + t + | t => t) + + +(* ------------------------------------------------------------------------- *) +(* Logic maps manage the interface between HOL and first-order logic. *) +(* ------------------------------------------------------------------------- *) + +datatype isa_thm = + Isa_Reflexive_or_Trivial | + Isa_Lambda_Lifted | + Isa_Raw of thm + +val proxy_defs = map (fst o snd o snd) proxy_table +val prepare_helper = + Meson.make_meta_clause #> rewrite_rule (map safe_mk_meta_eq proxy_defs) + +fun metis_term_from_atp type_enc (ATerm (s, tms)) = + if is_tptp_variable s then + Metis_Term.Var (Metis_Name.fromString s) + else + (case AList.lookup (op =) metis_name_table (s, length tms) of + SOME (f, swap) => (f type_enc, swap) + | NONE => (s, false)) + |> (fn (s, swap) => + Metis_Term.Fn (Metis_Name.fromString s, + tms |> map (metis_term_from_atp type_enc) + |> swap ? rev)) +fun metis_atom_from_atp type_enc (AAtom tm) = + (case metis_term_from_atp type_enc tm of + Metis_Term.Fn x => x + | _ => raise Fail "non CNF -- expected function") + | metis_atom_from_atp _ _ = raise Fail "not CNF -- expected atom" +fun metis_literal_from_atp type_enc (AConn (ANot, [phi])) = + (false, metis_atom_from_atp type_enc phi) + | metis_literal_from_atp type_enc phi = + (true, metis_atom_from_atp type_enc phi) +fun metis_literals_from_atp type_enc (AConn (AOr, phis)) = + maps (metis_literals_from_atp type_enc) phis + | metis_literals_from_atp type_enc phi = [metis_literal_from_atp type_enc phi] +fun metis_axiom_from_atp type_enc clauses (Formula (ident, _, phi, _, _)) = + let + fun some isa = + SOME (phi |> metis_literals_from_atp type_enc + |> Metis_LiteralSet.fromList + |> Metis_Thm.axiom, isa) + in + if ident = type_tag_idempotence_helper_name orelse + String.isPrefix tags_sym_formula_prefix ident then + Isa_Reflexive_or_Trivial |> some + else if String.isPrefix conjecture_prefix ident then + NONE + else if String.isPrefix helper_prefix ident then + case (String.isSuffix typed_helper_suffix ident, + space_explode "_" ident) of + (needs_fairly_sound, _ :: const :: j :: _) => + nth ((const, needs_fairly_sound) + |> AList.lookup (op =) helper_table |> the) + (the (Int.fromString j) - 1) + |> prepare_helper + |> Isa_Raw |> some + | _ => raise Fail ("malformed helper identifier " ^ quote ident) + else case try (unprefix fact_prefix) ident of + SOME s => + let val s = s |> space_explode "_" |> tl |> space_implode "_" + in + case Int.fromString s of + SOME j => + Meson.make_meta_clause (snd (nth clauses j)) |> Isa_Raw |> some + | NONE => + if String.isPrefix lam_fact_prefix (unascii_of s) then + Isa_Lambda_Lifted |> some + else + raise Fail ("malformed fact identifier " ^ quote ident) + end + | NONE => TrueI |> Isa_Raw |> some + end + | metis_axiom_from_atp _ _ _ = raise Fail "not CNF -- expected formula" + +fun eliminate_lam_wrappers (Const (@{const_name Metis.lambda}, _) $ t) = + eliminate_lam_wrappers t + | eliminate_lam_wrappers (t $ u) = + eliminate_lam_wrappers t $ eliminate_lam_wrappers u + | eliminate_lam_wrappers (Abs (s, T, t)) = + Abs (s, T, eliminate_lam_wrappers t) + | eliminate_lam_wrappers t = t + +(* Function to generate metis clauses, including comb and type clauses *) +fun prepare_metis_problem ctxt type_enc lam_trans conj_clauses fact_clauses = + let + val (conj_clauses, fact_clauses) = + if polymorphism_of_type_enc type_enc = Polymorphic then + (conj_clauses, fact_clauses) + else + conj_clauses @ fact_clauses + |> map (pair 0) + |> rpair (ctxt |> Config.put Monomorph.keep_partial_instances false) + |-> Monomorph.monomorph atp_schematic_consts_of + |> fst |> chop (length conj_clauses) + |> pairself (maps (map (zero_var_indexes o snd))) + val num_conjs = length conj_clauses + val clauses = + map2 (fn j => pair (Int.toString j, Local)) + (0 upto num_conjs - 1) conj_clauses @ + (* "General" below isn't quite correct; the fact could be local. *) + map2 (fn j => pair (Int.toString (num_conjs + j), General)) + (0 upto length fact_clauses - 1) fact_clauses + val (old_skolems, props) = + fold_rev (fn (name, th) => fn (old_skolems, props) => + th |> prop_of |> Logic.strip_imp_concl + |> conceal_old_skolem_terms (length clauses) old_skolems + ||> lam_trans = lam_liftingN ? eliminate_lam_wrappers + ||> (fn prop => (name, prop) :: props)) + clauses ([], []) + (* + val _ = + tracing ("PROPS:\n" ^ + cat_lines (map (Syntax.string_of_term ctxt o snd) props)) + *) + val lam_trans = if lam_trans = combinatorsN then no_lamsN else lam_trans + val (atp_problem, _, _, lifted, sym_tab) = + prepare_atp_problem ctxt CNF Hypothesis Axiom type_enc false lam_trans + false false [] @{prop False} props + (* + val _ = tracing ("ATP PROBLEM: " ^ + cat_lines (lines_for_atp_problem CNF atp_problem)) + *) + (* "rev" is for compatibility with existing proof scripts. *) + val axioms = + atp_problem + |> maps (map_filter (metis_axiom_from_atp type_enc clauses) o snd) |> rev + in (sym_tab, axioms, (lifted, old_skolems)) end + +end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Metis/metis_reconstruct.ML --- a/src/HOL/Tools/Metis/metis_reconstruct.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Metis/metis_reconstruct.ML Mon Jan 23 17:40:32 2012 +0100 @@ -9,7 +9,7 @@ signature METIS_RECONSTRUCT = sig - type type_enc = ATP_Translate.type_enc + type type_enc = ATP_Problem_Generate.type_enc exception METIS of string * string @@ -30,9 +30,9 @@ struct open ATP_Problem -open ATP_Translate -open ATP_Reconstruct -open Metis_Translate +open ATP_Problem_Generate +open ATP_Proof_Reconstruct +open Metis_Generate exception METIS of string * string @@ -101,7 +101,7 @@ (* INFERENCE RULE: AXIOM *) (* This causes variables to have an index of 1 by default. See also - "term_from_atp" in "ATP_Reconstruct". *) + "term_from_atp" in "ATP_Proof_Reconstruct". *) val axiom_inference = Thm.incr_indexes 1 oo lookth (* INFERENCE RULE: ASSUME *) diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Metis/metis_tactic.ML --- a/src/HOL/Tools/Metis/metis_tactic.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Metis/metis_tactic.ML Mon Jan 23 17:40:32 2012 +0100 @@ -23,9 +23,9 @@ structure Metis_Tactic : METIS_TACTIC = struct -open ATP_Translate -open ATP_Reconstruct -open Metis_Translate +open ATP_Problem_Generate +open ATP_Proof_Reconstruct +open Metis_Generate open Metis_Reconstruct val new_skolemizer = diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Metis/metis_translate.ML --- a/src/HOL/Tools/Metis/metis_translate.ML Mon Jan 23 17:40:31 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,256 +0,0 @@ -(* Title: HOL/Tools/Metis/metis_translate.ML - Author: Jia Meng, Cambridge University Computer Laboratory and NICTA - Author: Kong W. Susanto, Cambridge University Computer Laboratory - Author: Lawrence C. Paulson, Cambridge University Computer Laboratory - Author: Jasmin Blanchette, TU Muenchen - -Translation of HOL to FOL for Metis. -*) - -signature METIS_TRANSLATE = -sig - type type_enc = ATP_Translate.type_enc - - datatype isa_thm = - Isa_Reflexive_or_Trivial | - Isa_Lambda_Lifted | - Isa_Raw of thm - - val metis_equal : string - val metis_predicator : string - val metis_app_op : string - val metis_systematic_type_tag : string - val metis_ad_hoc_type_tag : string - val metis_generated_var_prefix : string - val trace : bool Config.T - val verbose : bool Config.T - val trace_msg : Proof.context -> (unit -> string) -> unit - val verbose_warning : Proof.context -> string -> unit - val metis_name_table : ((string * int) * ((type_enc -> string) * bool)) list - val reveal_old_skolem_terms : (string * term) list -> term -> term - val reveal_lam_lifted : (string * term) list -> term -> term - val prepare_metis_problem : - Proof.context -> type_enc -> string -> thm list -> thm list - -> int Symtab.table * (Metis_Thm.thm * isa_thm) list - * ((string * term) list * (string * term) list) -end - -structure Metis_Translate : METIS_TRANSLATE = -struct - -open ATP_Problem -open ATP_Translate - -val metis_equal = "=" -val metis_predicator = "{}" -val metis_app_op = Metis_Name.toString Metis_Term.appName -val metis_systematic_type_tag = - Metis_Name.toString Metis_Term.hasTypeFunctionName -val metis_ad_hoc_type_tag = "**" -val metis_generated_var_prefix = "_" - -val trace = Attrib.setup_config_bool @{binding metis_trace} (K false) -val verbose = Attrib.setup_config_bool @{binding metis_verbose} (K true) - -fun trace_msg ctxt msg = if Config.get ctxt trace then tracing (msg ()) else () -fun verbose_warning ctxt msg = - if Config.get ctxt verbose then warning ("Metis: " ^ msg) else () - -val metis_name_table = - [((tptp_equal, 2), (K metis_equal, false)), - ((tptp_old_equal, 2), (K metis_equal, false)), - ((prefixed_predicator_name, 1), (K metis_predicator, false)), - ((prefixed_app_op_name, 2), (K metis_app_op, false)), - ((prefixed_type_tag_name, 2), - (fn type_enc => - if level_of_type_enc type_enc = All_Types then metis_systematic_type_tag - else metis_ad_hoc_type_tag, true))] - -fun old_skolem_const_name i j num_T_args = - old_skolem_const_prefix ^ Long_Name.separator ^ - (space_implode Long_Name.separator (map string_of_int [i, j, num_T_args])) - -fun conceal_old_skolem_terms i old_skolems t = - if exists_Const (curry (op =) @{const_name Meson.skolem} o fst) t then - let - fun aux old_skolems - (t as (Const (@{const_name Meson.skolem}, Type (_, [_, T])) $ _)) = - let - val (old_skolems, s) = - if i = ~1 then - (old_skolems, @{const_name undefined}) - else case AList.find (op aconv) old_skolems t of - s :: _ => (old_skolems, s) - | [] => - let - val s = old_skolem_const_name i (length old_skolems) - (length (Term.add_tvarsT T [])) - in ((s, t) :: old_skolems, s) end - in (old_skolems, Const (s, T)) end - | aux old_skolems (t1 $ t2) = - let - val (old_skolems, t1) = aux old_skolems t1 - val (old_skolems, t2) = aux old_skolems t2 - in (old_skolems, t1 $ t2) end - | aux old_skolems (Abs (s, T, t')) = - let val (old_skolems, t') = aux old_skolems t' in - (old_skolems, Abs (s, T, t')) - end - | aux old_skolems t = (old_skolems, t) - in aux old_skolems t end - else - (old_skolems, t) - -fun reveal_old_skolem_terms old_skolems = - map_aterms (fn t as Const (s, _) => - if String.isPrefix old_skolem_const_prefix s then - AList.lookup (op =) old_skolems s |> the - |> map_types (map_type_tvar (K dummyT)) - else - t - | t => t) - -fun reveal_lam_lifted lambdas = - map_aterms (fn t as Const (s, _) => - if String.isPrefix lam_lifted_prefix s then - case AList.lookup (op =) lambdas s of - SOME t => - Const (@{const_name Metis.lambda}, dummyT) - $ map_types (map_type_tvar (K dummyT)) - (reveal_lam_lifted lambdas t) - | NONE => t - else - t - | t => t) - - -(* ------------------------------------------------------------------------- *) -(* Logic maps manage the interface between HOL and first-order logic. *) -(* ------------------------------------------------------------------------- *) - -datatype isa_thm = - Isa_Reflexive_or_Trivial | - Isa_Lambda_Lifted | - Isa_Raw of thm - -val proxy_defs = map (fst o snd o snd) proxy_table -val prepare_helper = - Meson.make_meta_clause #> rewrite_rule (map safe_mk_meta_eq proxy_defs) - -fun metis_term_from_atp type_enc (ATerm (s, tms)) = - if is_tptp_variable s then - Metis_Term.Var (Metis_Name.fromString s) - else - (case AList.lookup (op =) metis_name_table (s, length tms) of - SOME (f, swap) => (f type_enc, swap) - | NONE => (s, false)) - |> (fn (s, swap) => - Metis_Term.Fn (Metis_Name.fromString s, - tms |> map (metis_term_from_atp type_enc) - |> swap ? rev)) -fun metis_atom_from_atp type_enc (AAtom tm) = - (case metis_term_from_atp type_enc tm of - Metis_Term.Fn x => x - | _ => raise Fail "non CNF -- expected function") - | metis_atom_from_atp _ _ = raise Fail "not CNF -- expected atom" -fun metis_literal_from_atp type_enc (AConn (ANot, [phi])) = - (false, metis_atom_from_atp type_enc phi) - | metis_literal_from_atp type_enc phi = - (true, metis_atom_from_atp type_enc phi) -fun metis_literals_from_atp type_enc (AConn (AOr, phis)) = - maps (metis_literals_from_atp type_enc) phis - | metis_literals_from_atp type_enc phi = [metis_literal_from_atp type_enc phi] -fun metis_axiom_from_atp type_enc clauses (Formula (ident, _, phi, _, _)) = - let - fun some isa = - SOME (phi |> metis_literals_from_atp type_enc - |> Metis_LiteralSet.fromList - |> Metis_Thm.axiom, isa) - in - if ident = type_tag_idempotence_helper_name orelse - String.isPrefix tags_sym_formula_prefix ident then - Isa_Reflexive_or_Trivial |> some - else if String.isPrefix conjecture_prefix ident then - NONE - else if String.isPrefix helper_prefix ident then - case (String.isSuffix typed_helper_suffix ident, - space_explode "_" ident) of - (needs_fairly_sound, _ :: const :: j :: _) => - nth ((const, needs_fairly_sound) - |> AList.lookup (op =) helper_table |> the) - (the (Int.fromString j) - 1) - |> prepare_helper - |> Isa_Raw |> some - | _ => raise Fail ("malformed helper identifier " ^ quote ident) - else case try (unprefix fact_prefix) ident of - SOME s => - let val s = s |> space_explode "_" |> tl |> space_implode "_" - in - case Int.fromString s of - SOME j => - Meson.make_meta_clause (snd (nth clauses j)) |> Isa_Raw |> some - | NONE => - if String.isPrefix lam_fact_prefix (unascii_of s) then - Isa_Lambda_Lifted |> some - else - raise Fail ("malformed fact identifier " ^ quote ident) - end - | NONE => TrueI |> Isa_Raw |> some - end - | metis_axiom_from_atp _ _ _ = raise Fail "not CNF -- expected formula" - -fun eliminate_lam_wrappers (Const (@{const_name Metis.lambda}, _) $ t) = - eliminate_lam_wrappers t - | eliminate_lam_wrappers (t $ u) = - eliminate_lam_wrappers t $ eliminate_lam_wrappers u - | eliminate_lam_wrappers (Abs (s, T, t)) = - Abs (s, T, eliminate_lam_wrappers t) - | eliminate_lam_wrappers t = t - -(* Function to generate metis clauses, including comb and type clauses *) -fun prepare_metis_problem ctxt type_enc lam_trans conj_clauses fact_clauses = - let - val (conj_clauses, fact_clauses) = - if polymorphism_of_type_enc type_enc = Polymorphic then - (conj_clauses, fact_clauses) - else - conj_clauses @ fact_clauses - |> map (pair 0) - |> rpair (ctxt |> Config.put Monomorph.keep_partial_instances false) - |-> Monomorph.monomorph atp_schematic_consts_of - |> fst |> chop (length conj_clauses) - |> pairself (maps (map (zero_var_indexes o snd))) - val num_conjs = length conj_clauses - val clauses = - map2 (fn j => pair (Int.toString j, Local)) - (0 upto num_conjs - 1) conj_clauses @ - (* "General" below isn't quite correct; the fact could be local. *) - map2 (fn j => pair (Int.toString (num_conjs + j), General)) - (0 upto length fact_clauses - 1) fact_clauses - val (old_skolems, props) = - fold_rev (fn (name, th) => fn (old_skolems, props) => - th |> prop_of |> Logic.strip_imp_concl - |> conceal_old_skolem_terms (length clauses) old_skolems - ||> lam_trans = lam_liftingN ? eliminate_lam_wrappers - ||> (fn prop => (name, prop) :: props)) - clauses ([], []) - (* - val _ = - tracing ("PROPS:\n" ^ - cat_lines (map (Syntax.string_of_term ctxt o snd) props)) - *) - val lam_trans = if lam_trans = combinatorsN then no_lamsN else lam_trans - val (atp_problem, _, _, lifted, sym_tab) = - prepare_atp_problem ctxt CNF Hypothesis Axiom type_enc false lam_trans - false false [] @{prop False} props - (* - val _ = tracing ("ATP PROBLEM: " ^ - cat_lines (lines_for_atp_problem CNF atp_problem)) - *) - (* "rev" is for compatibility with existing proof scripts. *) - val axioms = - atp_problem - |> maps (map_filter (metis_axiom_from_atp type_enc clauses) o snd) |> rev - in (sym_tab, axioms, (lifted, old_skolems)) end - -end; diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Nitpick/nitpick_hol.ML --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Mon Jan 23 17:40:32 2012 +0100 @@ -1012,7 +1012,7 @@ handle TYPE ("Nitpick_HOL.card_of_type", _, _) => default_card) -(* Similar to "ATP_Translate.tiny_card_of_type". *) +(* Similar to "ATP_Util.tiny_card_of_type". *) fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card assigns T = let diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML Mon Jan 23 17:40:32 2012 +0100 @@ -7,7 +7,7 @@ signature SLEDGEHAMMER_FILTER = sig - type locality = ATP_Translate.locality + type locality = ATP_Problem_Generate.locality type relevance_fudge = {local_const_multiplier : real, @@ -62,7 +62,7 @@ structure Sledgehammer_Filter : SLEDGEHAMMER_FILTER = struct -open ATP_Translate +open ATP_Problem_Generate open Metis_Tactic open Sledgehammer_Util diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Mon Jan 23 17:40:32 2012 +0100 @@ -21,8 +21,8 @@ open ATP_Util open ATP_Systems -open ATP_Translate -open ATP_Reconstruct +open ATP_Problem_Generate +open ATP_Proof_Reconstruct open Sledgehammer_Util open Sledgehammer_Filter open Sledgehammer_Provers diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML Mon Jan 23 17:40:32 2012 +0100 @@ -7,8 +7,8 @@ signature SLEDGEHAMMER_MINIMIZE = sig - type locality = ATP_Translate.locality - type play = ATP_Reconstruct.play + type locality = ATP_Problem_Generate.locality + type play = ATP_Proof_Reconstruct.play type params = Sledgehammer_Provers.params val binary_min_facts : int Config.T @@ -26,8 +26,8 @@ open ATP_Util open ATP_Proof -open ATP_Translate -open ATP_Reconstruct +open ATP_Problem_Generate +open ATP_Proof_Reconstruct open Sledgehammer_Util open Sledgehammer_Filter open Sledgehammer_Provers diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML Mon Jan 23 17:40:32 2012 +0100 @@ -9,11 +9,11 @@ signature SLEDGEHAMMER_PROVERS = sig type failure = ATP_Proof.failure - type locality = ATP_Translate.locality - type type_enc = ATP_Translate.type_enc - type reconstructor = ATP_Reconstruct.reconstructor - type play = ATP_Reconstruct.play - type minimize_command = ATP_Reconstruct.minimize_command + type locality = ATP_Problem_Generate.locality + type type_enc = ATP_Problem_Generate.type_enc + type reconstructor = ATP_Proof_Reconstruct.reconstructor + type play = ATP_Proof_Reconstruct.play + type minimize_command = ATP_Proof_Reconstruct.minimize_command type relevance_fudge = Sledgehammer_Filter.relevance_fudge datatype mode = Auto_Try | Try | Normal | Auto_Minimize | Minimize @@ -119,8 +119,8 @@ open ATP_Problem open ATP_Proof open ATP_Systems -open ATP_Translate -open ATP_Reconstruct +open ATP_Problem_Generate +open ATP_Proof_Reconstruct open Metis_Tactic open Sledgehammer_Util open Sledgehammer_Filter diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/Tools/Sledgehammer/sledgehammer_run.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_run.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_run.ML Mon Jan 23 17:40:32 2012 +0100 @@ -8,7 +8,7 @@ signature SLEDGEHAMMER_RUN = sig - type minimize_command = ATP_Reconstruct.minimize_command + type minimize_command = ATP_Proof_Reconstruct.minimize_command type relevance_override = Sledgehammer_Filter.relevance_override type mode = Sledgehammer_Provers.mode type params = Sledgehammer_Provers.params @@ -31,8 +31,8 @@ struct open ATP_Util -open ATP_Translate -open ATP_Reconstruct +open ATP_Problem_Generate +open ATP_Proof_Reconstruct open Sledgehammer_Util open Sledgehammer_Filter open Sledgehammer_Provers diff -r c248e4f1be74 -r 0b8b73b49848 src/HOL/ex/sledgehammer_tactics.ML --- a/src/HOL/ex/sledgehammer_tactics.ML Mon Jan 23 17:40:31 2012 +0100 +++ b/src/HOL/ex/sledgehammer_tactics.ML Mon Jan 23 17:40:32 2012 +0100 @@ -71,7 +71,7 @@ fun sledgehammer_with_metis_tac ctxt override_params relevance_override i th = case run_atp override_params relevance_override i i ctxt th of SOME facts => - Metis_Tactic.metis_tac [] ATP_Translate.combinatorsN ctxt + Metis_Tactic.metis_tac [] ATP_Problem_Generate.combinatorsN ctxt (maps (thms_of_name ctxt) facts) i th | NONE => Seq.empty