merged
authorbulwahn
Tue May 31 18:13:00 2011 +0200 (2011-05-31)
changeset 431156773d8a9e351
parent 43114 b9fca691addd
parent 43111 61faa204c810
child 43116 e0add071fa10
merged
src/HOL/Tools/Sledgehammer/sledgehammer_atp_reconstruct.ML
src/HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML
     1.1 --- a/src/HOL/ATP.thy	Tue May 31 15:45:27 2011 +0200
     1.2 +++ b/src/HOL/ATP.thy	Tue May 31 18:13:00 2011 +0200
     1.3 @@ -6,12 +6,45 @@
     1.4  header {* Automatic Theorem Provers (ATPs) *}
     1.5  
     1.6  theory ATP
     1.7 -imports Plain
     1.8 -uses "Tools/ATP/atp_problem.ML"
     1.9 +imports Meson
    1.10 +uses "Tools/monomorph.ML"
    1.11 +     "Tools/ATP/atp_util.ML"
    1.12 +     "Tools/ATP/atp_problem.ML"
    1.13       "Tools/ATP/atp_proof.ML"
    1.14       "Tools/ATP/atp_systems.ML"
    1.15 +     ("Tools/ATP/atp_translate.ML")
    1.16 +     ("Tools/ATP/atp_reconstruct.ML")
    1.17  begin
    1.18  
    1.19 +subsection {* Higher-order reasoning helpers *}
    1.20 +
    1.21 +definition fFalse :: bool where [no_atp]:
    1.22 +"fFalse \<longleftrightarrow> False"
    1.23 +
    1.24 +definition fTrue :: bool where [no_atp]:
    1.25 +"fTrue \<longleftrightarrow> True"
    1.26 +
    1.27 +definition fNot :: "bool \<Rightarrow> bool" where [no_atp]:
    1.28 +"fNot P \<longleftrightarrow> \<not> P"
    1.29 +
    1.30 +definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
    1.31 +"fconj P Q \<longleftrightarrow> P \<and> Q"
    1.32 +
    1.33 +definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
    1.34 +"fdisj P Q \<longleftrightarrow> P \<or> Q"
    1.35 +
    1.36 +definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
    1.37 +"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"
    1.38 +
    1.39 +definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
    1.40 +"fequal x y \<longleftrightarrow> (x = y)"
    1.41 +
    1.42 +
    1.43 +subsection {* Setup *}
    1.44 +
    1.45 +use "Tools/ATP/atp_translate.ML"
    1.46 +use "Tools/ATP/atp_reconstruct.ML"
    1.47 +
    1.48  setup ATP_Systems.setup
    1.49  
    1.50  end
     2.1 --- a/src/HOL/IsaMakefile	Tue May 31 15:45:27 2011 +0200
     2.2 +++ b/src/HOL/IsaMakefile	Tue May 31 18:13:00 2011 +0200
     2.3 @@ -300,13 +300,17 @@
     2.4    $(SRC)/Provers/Arith/extract_common_term.ML \
     2.5    Tools/ATP/atp_problem.ML \
     2.6    Tools/ATP/atp_proof.ML \
     2.7 +  Tools/ATP/atp_reconstruct.ML \
     2.8    Tools/ATP/atp_systems.ML \
     2.9 +  Tools/ATP/atp_translate.ML \
    2.10 +  Tools/ATP/atp_util.ML \
    2.11    Tools/choice_specification.ML \
    2.12    Tools/code_evaluation.ML \
    2.13    Tools/groebner.ML \
    2.14    Tools/int_arith.ML \
    2.15    Tools/list_code.ML \
    2.16    Tools/list_to_set_comprehension.ML \
    2.17 +  Tools/monomorph.ML \
    2.18    Tools/nat_numeral_simprocs.ML \
    2.19    Tools/Nitpick/kodkod.ML \
    2.20    Tools/Nitpick/kodkod_sat.ML \
    2.21 @@ -353,8 +357,6 @@
    2.22    Tools/record.ML \
    2.23    Tools/semiring_normalizer.ML \
    2.24    Tools/Sledgehammer/async_manager.ML \
    2.25 -  Tools/Sledgehammer/sledgehammer_atp_reconstruct.ML \
    2.26 -  Tools/Sledgehammer/sledgehammer_atp_translate.ML \
    2.27    Tools/Sledgehammer/sledgehammer_filter.ML \
    2.28    Tools/Sledgehammer/sledgehammer_minimize.ML \
    2.29    Tools/Sledgehammer/sledgehammer_isar.ML \
     3.1 --- a/src/HOL/Metis.thy	Tue May 31 15:45:27 2011 +0200
     3.2 +++ b/src/HOL/Metis.thy	Tue May 31 18:13:00 2011 +0200
     3.3 @@ -7,7 +7,7 @@
     3.4  header {* Metis Proof Method *}
     3.5  
     3.6  theory Metis
     3.7 -imports Meson
     3.8 +imports ATP
     3.9  uses "~~/src/Tools/Metis/metis.ML"
    3.10       ("Tools/Metis/metis_translate.ML")
    3.11       ("Tools/Metis/metis_reconstruct.ML")
    3.12 @@ -15,31 +15,6 @@
    3.13       ("Tools/try_methods.ML")
    3.14  begin
    3.15  
    3.16 -
    3.17 -subsection {* Higher-order reasoning helpers *}
    3.18 -
    3.19 -definition fFalse :: bool where [no_atp]:
    3.20 -"fFalse \<longleftrightarrow> False"
    3.21 -
    3.22 -definition fTrue :: bool where [no_atp]:
    3.23 -"fTrue \<longleftrightarrow> True"
    3.24 -
    3.25 -definition fNot :: "bool \<Rightarrow> bool" where [no_atp]:
    3.26 -"fNot P \<longleftrightarrow> \<not> P"
    3.27 -
    3.28 -definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
    3.29 -"fconj P Q \<longleftrightarrow> P \<and> Q"
    3.30 -
    3.31 -definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
    3.32 -"fdisj P Q \<longleftrightarrow> P \<or> Q"
    3.33 -
    3.34 -definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
    3.35 -"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"
    3.36 -
    3.37 -definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
    3.38 -"fequal x y \<longleftrightarrow> (x = y)"
    3.39 -
    3.40 -
    3.41  subsection {* Literal selection helpers *}
    3.42  
    3.43  definition select :: "'a \<Rightarrow> 'a" where
     4.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Tue May 31 15:45:27 2011 +0200
     4.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Tue May 31 18:13:00 2011 +0200
     4.3 @@ -335,7 +335,7 @@
     4.4      | NONE => get_prover (default_prover_name ()))
     4.5    end
     4.6  
     4.7 -type locality = Sledgehammer_Filter.locality
     4.8 +type locality = ATP_Translate.locality
     4.9  
    4.10  (* hack *)
    4.11  fun reconstructor_from_msg args msg =
    4.12 @@ -361,7 +361,7 @@
    4.13      fun change_dir (SOME dir) =
    4.14          Config.put Sledgehammer_Provers.dest_dir dir
    4.15          #> Config.put SMT_Config.debug_files
    4.16 -          (dir ^ "/" ^ Name.desymbolize false (ATP_Problem.timestamp ()) ^ "_"
    4.17 +          (dir ^ "/" ^ Name.desymbolize false (ATP_Util.timestamp ()) ^ "_"
    4.18            ^ serial_string ())
    4.19        | change_dir NONE = I
    4.20      val st' =
    4.21 @@ -391,14 +391,14 @@
    4.22      val relevance_fudge =
    4.23        Sledgehammer_Provers.relevance_fudge_for_prover ctxt prover_name
    4.24      val relevance_override = {add = [], del = [], only = false}
    4.25 -    val (_, hyp_ts, concl_t) = Sledgehammer_Util.strip_subgoal ctxt goal i
    4.26 +    val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal ctxt goal i
    4.27      val time_limit =
    4.28        (case hard_timeout of
    4.29          NONE => I
    4.30        | SOME secs => TimeLimit.timeLimit (Time.fromSeconds secs))
    4.31      fun failed failure =
    4.32        ({outcome = SOME failure, used_facts = [], run_time_in_msecs = NONE,
    4.33 -        preplay = K Sledgehammer_ATP_Reconstruct.Failed_to_Play,
    4.34 +        preplay = K ATP_Reconstruct.Failed_to_Play,
    4.35          message = K ""}, ~1)
    4.36      val ({outcome, used_facts, run_time_in_msecs, preplay, message}
    4.37           : Sledgehammer_Provers.prover_result,
    4.38 @@ -469,7 +469,7 @@
    4.39      case result of
    4.40        SH_OK (time_isa, time_prover, names) =>
    4.41          let
    4.42 -          fun get_thms (_, Sledgehammer_Filter.Chained) = NONE
    4.43 +          fun get_thms (_, ATP_Translate.Chained) = NONE
    4.44              | get_thms (name, loc) =
    4.45                SOME ((name, loc), thms_of_name (Proof.context_of st) name)
    4.46          in
     5.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer_filter.ML	Tue May 31 15:45:27 2011 +0200
     5.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer_filter.ML	Tue May 31 18:13:00 2011 +0200
     5.3 @@ -128,8 +128,7 @@
     5.4                 (Sledgehammer_Provers.relevance_fudge_for_prover ctxt prover)
     5.5           val relevance_override = {add = [], del = [], only = false}
     5.6           val subgoal = 1
     5.7 -         val (_, hyp_ts, concl_t) =
     5.8 -           Sledgehammer_Util.strip_subgoal ctxt goal subgoal
     5.9 +         val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal ctxt goal subgoal
    5.10           val facts =
    5.11             Sledgehammer_Filter.relevant_facts ctxt relevance_thresholds
    5.12                 (the_default default_max_relevant max_relevant)
     6.1 --- a/src/HOL/Mutabelle/mutabelle_extra.ML	Tue May 31 15:45:27 2011 +0200
     6.2 +++ b/src/HOL/Mutabelle/mutabelle_extra.ML	Tue May 31 18:13:00 2011 +0200
     6.3 @@ -271,8 +271,8 @@
     6.4   @{const_name "equal_bool_inst.equal_bool"},
     6.5   @{const_name "ord_fun_inst.less_eq_fun"},
     6.6   @{const_name "ord_fun_inst.less_fun"},
     6.7 - @{const_name Metis.fequal},
     6.8   @{const_name Meson.skolem},
     6.9 + @{const_name ATP.fequal},
    6.10   @{const_name transfer_morphism},
    6.11   @{const_name enum_prod_inst.enum_all_prod},
    6.12   @{const_name enum_prod_inst.enum_ex_prod}
     7.1 --- a/src/HOL/Sledgehammer.thy	Tue May 31 15:45:27 2011 +0200
     7.2 +++ b/src/HOL/Sledgehammer.thy	Tue May 31 18:13:00 2011 +0200
     7.3 @@ -11,8 +11,6 @@
     7.4  uses "Tools/Sledgehammer/async_manager.ML"
     7.5       "Tools/Sledgehammer/sledgehammer_util.ML"
     7.6       "Tools/Sledgehammer/sledgehammer_filter.ML"
     7.7 -     "Tools/Sledgehammer/sledgehammer_atp_translate.ML"
     7.8 -     "Tools/Sledgehammer/sledgehammer_atp_reconstruct.ML"
     7.9       "Tools/Sledgehammer/sledgehammer_provers.ML"
    7.10       "Tools/Sledgehammer/sledgehammer_minimize.ML"
    7.11       "Tools/Sledgehammer/sledgehammer_run.ML"
     8.1 --- a/src/HOL/Tools/ATP/atp_problem.ML	Tue May 31 15:45:27 2011 +0200
     8.2 +++ b/src/HOL/Tools/ATP/atp_problem.ML	Tue May 31 18:13:00 2011 +0200
     8.3 @@ -17,7 +17,7 @@
     8.4  
     8.5    datatype 'a ho_type = AType of 'a | AFun of 'a ho_type * 'a ho_type
     8.6  
     8.7 -  datatype format = CNF_UEQ | FOF | TFF | THF
     8.8 +  datatype format = CNF | CNF_UEQ | FOF | TFF | THF
     8.9    datatype formula_kind = Axiom | Definition | Lemma | Hypothesis | Conjecture
    8.10    datatype 'a problem_line =
    8.11      Decl of string * 'a * 'a ho_type |
    8.12 @@ -70,10 +70,9 @@
    8.13      -> 'd -> 'd
    8.14    val formula_map : ('c -> 'd) -> ('a, 'b, 'c) formula -> ('a, 'b, 'd) formula
    8.15    val is_format_typed : format -> bool
    8.16 -  val timestamp : unit -> string
    8.17 -  val hashw : word * word -> word
    8.18 -  val hashw_string : string * word -> word
    8.19    val tptp_strings_for_atp_problem : format -> string problem -> string list
    8.20 +  val ensure_cnf_problem :
    8.21 +    (string * string) problem -> (string * string) problem
    8.22    val filter_cnf_ueq_problem :
    8.23      (string * string) problem -> (string * string) problem
    8.24    val declare_undeclared_syms_in_atp_problem :
    8.25 @@ -87,6 +86,9 @@
    8.26  structure ATP_Problem : ATP_PROBLEM =
    8.27  struct
    8.28  
    8.29 +open ATP_Util
    8.30 +
    8.31 +
    8.32  (** ATP problem **)
    8.33  
    8.34  datatype 'a fo_term = ATerm of 'a * 'a fo_term list
    8.35 @@ -99,7 +101,7 @@
    8.36  
    8.37  datatype 'a ho_type = AType of 'a | AFun of 'a ho_type * 'a ho_type
    8.38  
    8.39 -datatype format = CNF_UEQ | FOF | TFF | THF
    8.40 +datatype format = CNF | CNF_UEQ | FOF | TFF | THF
    8.41  datatype formula_kind = Axiom | Definition | Lemma | Hypothesis | Conjecture
    8.42  datatype 'a problem_line =
    8.43    Decl of string * 'a * 'a ho_type |
    8.44 @@ -141,6 +143,17 @@
    8.45  fun is_tptp_variable s = Char.isUpper (String.sub (s, 0))
    8.46  val is_tptp_user_symbol = not o (is_tptp_variable orf is_built_in_tptp_symbol)
    8.47  
    8.48 +fun raw_polarities_of_conn ANot = (SOME false, NONE)
    8.49 +  | raw_polarities_of_conn AAnd = (SOME true, SOME true)
    8.50 +  | raw_polarities_of_conn AOr = (SOME true, SOME true)
    8.51 +  | raw_polarities_of_conn AImplies = (SOME false, SOME true)
    8.52 +  | raw_polarities_of_conn AIf = (SOME true, SOME false)
    8.53 +  | raw_polarities_of_conn AIff = (NONE, NONE)
    8.54 +  | raw_polarities_of_conn ANotIff = (NONE, NONE)
    8.55 +fun polarities_of_conn NONE = K (NONE, NONE)
    8.56 +  | polarities_of_conn (SOME pos) =
    8.57 +    raw_polarities_of_conn #> not pos ? pairself (Option.map not)
    8.58 +
    8.59  fun mk_anot (AConn (ANot, [phi])) = phi
    8.60    | mk_anot phi = AConn (ANot, [phi])
    8.61  fun mk_aconn c phi1 phi2 = AConn (c, [phi1, phi2])
    8.62 @@ -172,15 +185,6 @@
    8.63  
    8.64  val is_format_typed = member (op =) [TFF, THF]
    8.65  
    8.66 -val timestamp = Date.fmt "%Y-%m-%d %H:%M:%S" o Date.fromTimeLocal o Time.now
    8.67 -
    8.68 -(* This hash function is recommended in "Compilers: Principles, Techniques, and
    8.69 -   Tools" by Aho, Sethi, and Ullman. The "hashpjw" function, which they
    8.70 -   particularly recommend, triggers a bug in versions of Poly/ML up to 4.2.0. *)
    8.71 -fun hashw (u, w) = Word.+ (u, Word.* (0w65599, w))
    8.72 -fun hashw_char (c, w) = hashw (Word.fromInt (Char.ord c), w)
    8.73 -fun hashw_string (s : string, w) = CharVector.foldl hashw_char w s
    8.74 -
    8.75  fun string_for_kind Axiom = "axiom"
    8.76    | string_for_kind Definition = "definition"
    8.77    | string_for_kind Lemma = "lemma"
    8.78 @@ -265,7 +269,8 @@
    8.79  val default_source =
    8.80    ATerm ("inference", ATerm ("isabelle", []) :: replicate 2 (ATerm ("[]", [])))
    8.81  
    8.82 -fun string_for_format CNF_UEQ = tptp_cnf
    8.83 +fun string_for_format CNF = tptp_cnf
    8.84 +  | string_for_format CNF_UEQ = tptp_cnf
    8.85    | string_for_format FOF = tptp_fof
    8.86    | string_for_format TFF = tptp_tff
    8.87    | string_for_format THF = tptp_thf
    8.88 @@ -292,7 +297,7 @@
    8.89         problem
    8.90  
    8.91  
    8.92 -(** CNF UEQ (Waldmeister) **)
    8.93 +(** CNF (Metis) and CNF UEQ (Waldmeister) **)
    8.94  
    8.95  fun is_problem_line_negated (Formula (_, _, AConn (ANot, _), _, _)) = true
    8.96    | is_problem_line_negated _ = false
    8.97 @@ -304,9 +309,17 @@
    8.98  fun open_conjecture_term (ATerm ((s, s'), tms)) =
    8.99    ATerm (if is_tptp_variable s then (s |> Name.desymbolize false, s')
   8.100           else (s, s'), tms |> map open_conjecture_term)
   8.101 -fun open_formula conj (AQuant (AForall, _, phi)) = open_formula conj phi
   8.102 -  | open_formula true (AAtom t) = AAtom (open_conjecture_term t)
   8.103 -  | open_formula _ phi = phi
   8.104 +fun open_formula conj =
   8.105 +  let
   8.106 +    fun opn (pos as SOME true) (AQuant (AForall, xs, phi)) = opn pos phi
   8.107 +      | opn (pos as SOME false) (AQuant (AExists, xs, phi)) = opn pos phi
   8.108 +      | opn pos (AConn (ANot, [phi])) = mk_anot (opn (Option.map not pos) phi)
   8.109 +      | opn pos (AConn (c, [phi1, phi2])) =
   8.110 +        let val (pos1, pos2) = polarities_of_conn pos c in
   8.111 +          AConn (c, [opn pos1 phi1, opn pos2 phi2])
   8.112 +        end
   8.113 +      | opn _ (AAtom t) = AAtom (t |> conj ? open_conjecture_term)
   8.114 +  in opn (SOME (not conj)) end
   8.115  fun open_formula_line (Formula (ident, kind, phi, source, info)) =
   8.116      Formula (ident, kind, open_formula (kind = Conjecture) phi, source, info)
   8.117    | open_formula_line line = line
   8.118 @@ -315,6 +328,32 @@
   8.119      Formula (ident, Hypothesis, mk_anot phi, source, info)
   8.120    | negate_conjecture_line line = line
   8.121  
   8.122 +exception CLAUSIFY of unit
   8.123 +
   8.124 +fun clausify_formula pos (phi as AAtom _) = phi |> not pos ? mk_anot
   8.125 +  | clausify_formula pos (AConn (ANot, [phi])) = clausify_formula (not pos) phi
   8.126 +  | clausify_formula false (AConn (AAnd, phis)) =
   8.127 +    AConn (AOr, map (clausify_formula false) phis)
   8.128 +  | clausify_formula true (AConn (AOr, phis)) =
   8.129 +    AConn (AOr, map (clausify_formula true) phis)
   8.130 +  | clausify_formula true (AConn (AImplies, [phi1, phi2])) =
   8.131 +    AConn (AOr, [clausify_formula false phi1, clausify_formula true phi2])
   8.132 +  | clausify_formula true (AConn (AIf, phis)) =
   8.133 +    clausify_formula true (AConn (AImplies, rev phis))
   8.134 +  | clausify_formula _ _ = raise CLAUSIFY ()
   8.135 +
   8.136 +fun clausify_formula_line (Formula (ident, kind, phi, source, info)) =
   8.137 +    (case try (clausify_formula true) phi of
   8.138 +       SOME phi => SOME (Formula (ident, kind, phi, source, info))
   8.139 +     | NONE => NONE)
   8.140 +  | clausify_formula_line _ = NONE
   8.141 +
   8.142 +fun ensure_cnf_problem_line line =
   8.143 +  line |> open_formula_line |> negate_conjecture_line |> clausify_formula_line
   8.144 +
   8.145 +fun ensure_cnf_problem problem =
   8.146 +  problem |> map (apsnd (map_filter ensure_cnf_problem_line))
   8.147 +
   8.148  fun filter_cnf_ueq_problem problem =
   8.149    problem
   8.150    |> map (apsnd (map open_formula_line
     9.1 --- a/src/HOL/Tools/ATP/atp_proof.ML	Tue May 31 15:45:27 2011 +0200
     9.2 +++ b/src/HOL/Tools/ATP/atp_proof.ML	Tue May 31 18:13:00 2011 +0200
     9.3 @@ -28,7 +28,6 @@
     9.4      VampireTooOld |
     9.5      NoPerl |
     9.6      NoLibwwwPerl |
     9.7 -    NoRealZ3 |
     9.8      MalformedInput |
     9.9      MalformedOutput |
    9.10      Interrupted |
    9.11 @@ -44,7 +43,6 @@
    9.12  
    9.13    type 'a proof = ('a, 'a, 'a fo_term) formula step list
    9.14  
    9.15 -  val strip_spaces : bool -> (char -> bool) -> string -> string
    9.16    val short_output : bool -> string -> string
    9.17    val string_for_failure : failure -> string
    9.18    val extract_important_message : string -> string
    9.19 @@ -67,6 +65,7 @@
    9.20  structure ATP_Proof : ATP_PROOF =
    9.21  struct
    9.22  
    9.23 +open ATP_Util
    9.24  open ATP_Problem
    9.25  
    9.26  exception UNRECOGNIZED_ATP_PROOF of unit
    9.27 @@ -85,7 +84,6 @@
    9.28    VampireTooOld |
    9.29    NoPerl |
    9.30    NoLibwwwPerl |
    9.31 -  NoRealZ3 |
    9.32    MalformedInput |
    9.33    MalformedOutput |
    9.34    Interrupted |
    9.35 @@ -93,34 +91,6 @@
    9.36    InternalError |
    9.37    UnknownError of string
    9.38  
    9.39 -fun strip_c_style_comment _ [] = []
    9.40 -  | strip_c_style_comment is_evil (#"*" :: #"/" :: cs) =
    9.41 -    strip_spaces_in_list true is_evil cs
    9.42 -  | strip_c_style_comment is_evil (_ :: cs) = strip_c_style_comment is_evil cs
    9.43 -and strip_spaces_in_list _ _ [] = []
    9.44 -  | strip_spaces_in_list true is_evil (#"%" :: cs) =
    9.45 -    strip_spaces_in_list true is_evil
    9.46 -                         (cs |> chop_while (not_equal #"\n") |> snd)
    9.47 -  | strip_spaces_in_list true is_evil (#"/" :: #"*" :: cs) =
    9.48 -    strip_c_style_comment is_evil cs
    9.49 -  | strip_spaces_in_list _ _ [c1] = if Char.isSpace c1 then [] else [str c1]
    9.50 -  | strip_spaces_in_list skip_comments is_evil [c1, c2] =
    9.51 -    strip_spaces_in_list skip_comments is_evil [c1] @
    9.52 -    strip_spaces_in_list skip_comments is_evil [c2]
    9.53 -  | strip_spaces_in_list skip_comments is_evil (c1 :: c2 :: c3 :: cs) =
    9.54 -    if Char.isSpace c1 then
    9.55 -      strip_spaces_in_list skip_comments is_evil (c2 :: c3 :: cs)
    9.56 -    else if Char.isSpace c2 then
    9.57 -      if Char.isSpace c3 then
    9.58 -        strip_spaces_in_list skip_comments is_evil (c1 :: c3 :: cs)
    9.59 -      else
    9.60 -        str c1 :: (if forall is_evil [c1, c3] then [" "] else []) @
    9.61 -        strip_spaces_in_list skip_comments is_evil (c3 :: cs)
    9.62 -    else
    9.63 -      str c1 :: strip_spaces_in_list skip_comments is_evil (c2 :: c3 :: cs)
    9.64 -fun strip_spaces skip_comments is_evil =
    9.65 -  implode o strip_spaces_in_list skip_comments is_evil o String.explode
    9.66 -
    9.67  fun is_ident_char c = Char.isAlphaNum c orelse c = #"_"
    9.68  val strip_spaces_except_between_ident_chars = strip_spaces true is_ident_char
    9.69  
    9.70 @@ -182,12 +152,11 @@
    9.71    | string_for_failure NoPerl = "Perl" ^ missing_message_tail
    9.72    | string_for_failure NoLibwwwPerl =
    9.73      "The Perl module \"libwww-perl\"" ^ missing_message_tail
    9.74 -  | string_for_failure NoRealZ3 =
    9.75 -    "The environment variable \"Z3_REAL_SOLVER\" must be set to Z3's full path."
    9.76    | string_for_failure MalformedInput =
    9.77      "The generated problem is malformed. Please report this to the Isabelle \
    9.78      \developers."
    9.79    | string_for_failure MalformedOutput = "The prover output is malformed."
    9.80 +  | string_for_failure Interrupted = "The prover was interrupted."
    9.81    | string_for_failure Crashed = "The prover crashed."
    9.82    | string_for_failure InternalError = "An internal prover error occurred."
    9.83    | string_for_failure (UnknownError string) =
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Tools/ATP/atp_reconstruct.ML	Tue May 31 18:13:00 2011 +0200
    10.3 @@ -0,0 +1,1100 @@
    10.4 +(*  Title:      HOL/Tools/ATP/atp_reconstruct.ML
    10.5 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    10.6 +    Author:     Claire Quigley, Cambridge University Computer Laboratory
    10.7 +    Author:     Jasmin Blanchette, TU Muenchen
    10.8 +
    10.9 +Proof reconstruction from ATP proofs.
   10.10 +*)
   10.11 +
   10.12 +signature ATP_RECONSTRUCT =
   10.13 +sig
   10.14 +  type 'a fo_term = 'a ATP_Problem.fo_term
   10.15 +  type 'a proof = 'a ATP_Proof.proof
   10.16 +  type locality = ATP_Translate.locality
   10.17 +  type type_sys = ATP_Translate.type_sys
   10.18 +
   10.19 +  datatype reconstructor =
   10.20 +    Metis |
   10.21 +    MetisFT |
   10.22 +    SMT of string
   10.23 +
   10.24 +  datatype play =
   10.25 +    Played of reconstructor * Time.time |
   10.26 +    Trust_Playable of reconstructor * Time.time option|
   10.27 +    Failed_to_Play
   10.28 +
   10.29 +  type minimize_command = string list -> string
   10.30 +  type one_line_params =
   10.31 +    play * string * (string * locality) list * minimize_command * int * int
   10.32 +  type isar_params =
   10.33 +    bool * bool * int * type_sys * string Symtab.table * int list list * int
   10.34 +    * (string * locality) list vector * int Symtab.table * string proof * thm
   10.35 +  val repair_conjecture_shape_and_fact_names :
   10.36 +    type_sys -> string -> int list list -> int
   10.37 +    -> (string * locality) list vector -> int list
   10.38 +    -> int list list * int * (string * locality) list vector * int list
   10.39 +  val used_facts_in_atp_proof :
   10.40 +    Proof.context -> type_sys -> int -> (string * locality) list vector
   10.41 +    -> string proof -> (string * locality) list
   10.42 +  val used_facts_in_unsound_atp_proof :
   10.43 +    Proof.context -> type_sys -> int list list -> int
   10.44 +    -> (string * locality) list vector -> 'a proof -> string list option
   10.45 +  val uses_typed_helpers : int list -> 'a proof -> bool
   10.46 +  val reconstructor_name : reconstructor -> string
   10.47 +  val one_line_proof_text : one_line_params -> string
   10.48 +  val term_from_atp :
   10.49 +    theory -> bool -> int Symtab.table -> (string * sort) list -> typ option
   10.50 +    -> string fo_term -> term
   10.51 +  val isar_proof_text :
   10.52 +    Proof.context -> bool -> isar_params -> one_line_params -> string
   10.53 +  val proof_text :
   10.54 +    Proof.context -> bool -> isar_params -> one_line_params -> string
   10.55 +end;
   10.56 +
   10.57 +structure ATP_Reconstruct : ATP_RECONSTRUCT =
   10.58 +struct
   10.59 +
   10.60 +open ATP_Util
   10.61 +open ATP_Problem
   10.62 +open ATP_Proof
   10.63 +open ATP_Translate
   10.64 +
   10.65 +datatype reconstructor =
   10.66 +  Metis |
   10.67 +  MetisFT |
   10.68 +  SMT of string
   10.69 +
   10.70 +datatype play =
   10.71 +  Played of reconstructor * Time.time |
   10.72 +  Trust_Playable of reconstructor * Time.time option |
   10.73 +  Failed_to_Play
   10.74 +
   10.75 +type minimize_command = string list -> string
   10.76 +type one_line_params =
   10.77 +  play * string * (string * locality) list * minimize_command * int * int
   10.78 +type isar_params =
   10.79 +  bool * bool * int * type_sys * string Symtab.table * int list list * int
   10.80 +  * (string * locality) list vector * int Symtab.table * string proof * thm
   10.81 +
   10.82 +fun is_head_digit s = Char.isDigit (String.sub (s, 0))
   10.83 +val scan_integer = Scan.many1 is_head_digit >> (the o Int.fromString o implode)
   10.84 +
   10.85 +val is_typed_helper_name =
   10.86 +  String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix
   10.87 +
   10.88 +fun find_first_in_list_vector vec key =
   10.89 +  Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key
   10.90 +                 | (_, value) => value) NONE vec
   10.91 +
   10.92 +
   10.93 +(** SPASS's FLOTTER hack **)
   10.94 +
   10.95 +(* This is a hack required for keeping track of facts after they have been
   10.96 +   clausified by SPASS's FLOTTER preprocessor. The "ATP/scripts/spass" script is
   10.97 +   also part of this hack. *)
   10.98 +
   10.99 +val set_ClauseFormulaRelationN = "set_ClauseFormulaRelation"
  10.100 +
  10.101 +fun extract_clause_sequence output =
  10.102 +  let
  10.103 +    val tokens_of = String.tokens (not o Char.isAlphaNum)
  10.104 +    fun extract_num ("clause" :: (ss as _ :: _)) = Int.fromString (List.last ss)
  10.105 +      | extract_num _ = NONE
  10.106 +  in output |> split_lines |> map_filter (extract_num o tokens_of) end
  10.107 +
  10.108 +val parse_clause_formula_pair =
  10.109 +  $$ "(" |-- scan_integer --| $$ ","
  10.110 +  -- (Symbol.scan_id ::: Scan.repeat ($$ "," |-- Symbol.scan_id)) --| $$ ")"
  10.111 +  --| Scan.option ($$ ",")
  10.112 +val parse_clause_formula_relation =
  10.113 +  Scan.this_string set_ClauseFormulaRelationN |-- $$ "("
  10.114 +  |-- Scan.repeat parse_clause_formula_pair
  10.115 +val extract_clause_formula_relation =
  10.116 +  Substring.full #> Substring.position set_ClauseFormulaRelationN
  10.117 +  #> snd #> Substring.position "." #> fst #> Substring.string
  10.118 +  #> raw_explode #> filter_out Symbol.is_blank #> parse_clause_formula_relation
  10.119 +  #> fst
  10.120 +
  10.121 +fun maybe_unprefix_fact_number type_sys =
  10.122 +  polymorphism_of_type_sys type_sys <> Polymorphic
  10.123 +  ? (space_implode "_" o tl o space_explode "_")
  10.124 +
  10.125 +fun repair_conjecture_shape_and_fact_names type_sys output conjecture_shape
  10.126 +        fact_offset fact_names typed_helpers =
  10.127 +  if String.isSubstring set_ClauseFormulaRelationN output then
  10.128 +    let
  10.129 +      val j0 = hd (hd conjecture_shape)
  10.130 +      val seq = extract_clause_sequence output
  10.131 +      val name_map = extract_clause_formula_relation output
  10.132 +      fun renumber_conjecture j =
  10.133 +        conjecture_prefix ^ string_of_int (j - j0)
  10.134 +        |> AList.find (fn (s, ss) => member (op =) ss s) name_map
  10.135 +        |> map (fn s => find_index (curry (op =) s) seq + 1)
  10.136 +      fun names_for_number j =
  10.137 +        j |> AList.lookup (op =) name_map |> these
  10.138 +          |> map_filter (try (unascii_of o maybe_unprefix_fact_number type_sys
  10.139 +                              o unprefix fact_prefix))
  10.140 +          |> map (fn name =>
  10.141 +                     (name, name |> find_first_in_list_vector fact_names |> the)
  10.142 +                     handle Option.Option =>
  10.143 +                            error ("No such fact: " ^ quote name ^ "."))
  10.144 +    in
  10.145 +      (conjecture_shape |> map (maps renumber_conjecture), 0,
  10.146 +       seq |> map names_for_number |> Vector.fromList,
  10.147 +       name_map |> filter (forall is_typed_helper_name o snd) |> map fst)
  10.148 +    end
  10.149 +  else
  10.150 +    (conjecture_shape, fact_offset, fact_names, typed_helpers)
  10.151 +
  10.152 +val vampire_step_prefix = "f" (* grrr... *)
  10.153 +
  10.154 +val extract_step_number =
  10.155 +  Int.fromString o perhaps (try (unprefix vampire_step_prefix))
  10.156 +
  10.157 +fun resolve_fact type_sys _ fact_names (_, SOME s) =
  10.158 +    (case try (unprefix fact_prefix) s of
  10.159 +       SOME s' =>
  10.160 +       let val s' = s' |> maybe_unprefix_fact_number type_sys |> unascii_of in
  10.161 +         case find_first_in_list_vector fact_names s' of
  10.162 +           SOME x => [(s', x)]
  10.163 +         | NONE => []
  10.164 +       end
  10.165 +     | NONE => [])
  10.166 +  | resolve_fact _ facts_offset fact_names (num, NONE) =
  10.167 +    (case extract_step_number num of
  10.168 +       SOME j =>
  10.169 +       let val j = j - facts_offset in
  10.170 +         if j > 0 andalso j <= Vector.length fact_names then
  10.171 +           Vector.sub (fact_names, j - 1)
  10.172 +         else
  10.173 +           []
  10.174 +       end
  10.175 +     | NONE => [])
  10.176 +
  10.177 +fun is_fact type_sys conjecture_shape =
  10.178 +  not o null o resolve_fact type_sys 0 conjecture_shape
  10.179 +
  10.180 +fun resolve_conjecture _ (_, SOME s) =
  10.181 +    (case try (unprefix conjecture_prefix) s of
  10.182 +       SOME s' =>
  10.183 +       (case Int.fromString s' of
  10.184 +          SOME j => [j]
  10.185 +        | NONE => [])
  10.186 +     | NONE => [])
  10.187 +  | resolve_conjecture conjecture_shape (num, NONE) =
  10.188 +    case extract_step_number num of
  10.189 +      SOME i => (case find_index (exists (curry (op =) i)) conjecture_shape of
  10.190 +                   ~1 => []
  10.191 +                 | j => [j])
  10.192 +    | NONE => []
  10.193 +
  10.194 +fun is_conjecture conjecture_shape =
  10.195 +  not o null o resolve_conjecture conjecture_shape
  10.196 +
  10.197 +fun is_typed_helper _ (_, SOME s) = is_typed_helper_name s
  10.198 +  | is_typed_helper typed_helpers (num, NONE) =
  10.199 +    (case extract_step_number num of
  10.200 +       SOME i => member (op =) typed_helpers i
  10.201 +     | NONE => false)
  10.202 +
  10.203 +val leo2_ext = "extcnf_equal_neg"
  10.204 +val isa_ext = Thm.get_name_hint @{thm ext}
  10.205 +val isa_short_ext = Long_Name.base_name isa_ext
  10.206 +
  10.207 +fun ext_name ctxt =
  10.208 +  if Thm.eq_thm_prop (@{thm ext},
  10.209 +         singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then
  10.210 +    isa_short_ext
  10.211 +  else
  10.212 +    isa_ext
  10.213 +
  10.214 +fun add_fact _ type_sys facts_offset fact_names (Inference (name, _, [])) =
  10.215 +    union (op =) (resolve_fact type_sys facts_offset fact_names name)
  10.216 +  | add_fact ctxt _ _ _ (Inference (_, _, deps)) =
  10.217 +    if AList.defined (op =) deps leo2_ext then
  10.218 +      insert (op =) (ext_name ctxt, General (* or Chained... *))
  10.219 +    else
  10.220 +      I
  10.221 +  | add_fact _ _ _ _ _ = I
  10.222 +
  10.223 +fun used_facts_in_atp_proof ctxt type_sys facts_offset fact_names atp_proof =
  10.224 +  if null atp_proof then Vector.foldl (op @) [] fact_names
  10.225 +  else fold (add_fact ctxt type_sys facts_offset fact_names) atp_proof []
  10.226 +
  10.227 +fun is_conjecture_referred_to_in_proof conjecture_shape =
  10.228 +  exists (fn Inference (name, _, []) => is_conjecture conjecture_shape name
  10.229 +           | _ => false)
  10.230 +
  10.231 +fun used_facts_in_unsound_atp_proof ctxt type_sys conjecture_shape facts_offset
  10.232 +                                    fact_names atp_proof =
  10.233 +  let
  10.234 +    val used_facts =
  10.235 +      used_facts_in_atp_proof ctxt type_sys facts_offset fact_names atp_proof
  10.236 +  in
  10.237 +    if forall (is_locality_global o snd) used_facts andalso
  10.238 +       not (is_conjecture_referred_to_in_proof conjecture_shape atp_proof) then
  10.239 +      SOME (map fst used_facts)
  10.240 +    else
  10.241 +      NONE
  10.242 +  end
  10.243 +
  10.244 +fun uses_typed_helpers typed_helpers =
  10.245 +  exists (fn Inference (name, _, []) => is_typed_helper typed_helpers name
  10.246 +           | _ => false)
  10.247 +
  10.248 +
  10.249 +(** Soft-core proof reconstruction: Metis one-liner **)
  10.250 +
  10.251 +fun reconstructor_name Metis = "metis"
  10.252 +  | reconstructor_name MetisFT = "metisFT"
  10.253 +  | reconstructor_name (SMT _) = "smt"
  10.254 +
  10.255 +fun reconstructor_settings (SMT settings) = settings
  10.256 +  | reconstructor_settings _ = ""
  10.257 +
  10.258 +fun string_for_label (s, num) = s ^ string_of_int num
  10.259 +
  10.260 +fun show_time NONE = ""
  10.261 +  | show_time (SOME ext_time) = " (" ^ string_from_ext_time ext_time ^ ")"
  10.262 +
  10.263 +fun set_settings "" = ""
  10.264 +  | set_settings settings = "using [[" ^ settings ^ "]] "
  10.265 +fun apply_on_subgoal settings _ 1 = set_settings settings ^ "by "
  10.266 +  | apply_on_subgoal settings 1 _ = set_settings settings ^ "apply "
  10.267 +  | apply_on_subgoal settings i n =
  10.268 +    "prefer " ^ string_of_int i ^ " " ^ apply_on_subgoal settings 1 n
  10.269 +fun command_call name [] = name
  10.270 +  | command_call name args = "(" ^ name ^ " " ^ space_implode " " args ^ ")"
  10.271 +fun try_command_line banner time command =
  10.272 +  banner ^ ": " ^ Markup.markup Markup.sendback command ^ show_time time ^ "."
  10.273 +fun using_labels [] = ""
  10.274 +  | using_labels ls =
  10.275 +    "using " ^ space_implode " " (map string_for_label ls) ^ " "
  10.276 +fun reconstructor_command reconstructor i n (ls, ss) =
  10.277 +  using_labels ls ^
  10.278 +  apply_on_subgoal (reconstructor_settings reconstructor) i n ^
  10.279 +  command_call (reconstructor_name reconstructor) ss
  10.280 +fun minimize_line _ [] = ""
  10.281 +  | minimize_line minimize_command ss =
  10.282 +    case minimize_command ss of
  10.283 +      "" => ""
  10.284 +    | command => "\nTo minimize: " ^ Markup.markup Markup.sendback command ^ "."
  10.285 +
  10.286 +val split_used_facts =
  10.287 +  List.partition (curry (op =) Chained o snd)
  10.288 +  #> pairself (sort_distinct (string_ord o pairself fst))
  10.289 +
  10.290 +fun one_line_proof_text (preplay, banner, used_facts, minimize_command,
  10.291 +                         subgoal, subgoal_count) =
  10.292 +  let
  10.293 +    val (chained, extra) = split_used_facts used_facts
  10.294 +    val (reconstructor, ext_time) =
  10.295 +      case preplay of
  10.296 +        Played (reconstructor, time) =>
  10.297 +        (SOME reconstructor, (SOME (false, time)))
  10.298 +      | Trust_Playable (reconstructor, time) =>
  10.299 +        (SOME reconstructor,
  10.300 +         case time of
  10.301 +           NONE => NONE
  10.302 +         | SOME time =>
  10.303 +           if time = Time.zeroTime then NONE else SOME (true, time))
  10.304 +      | Failed_to_Play => (NONE, NONE)
  10.305 +    val try_line =
  10.306 +      case reconstructor of
  10.307 +        SOME r => ([], map fst extra)
  10.308 +                  |> reconstructor_command r subgoal subgoal_count
  10.309 +                  |> try_command_line banner ext_time
  10.310 +      | NONE => "One-line proof reconstruction failed."
  10.311 +  in try_line ^ minimize_line minimize_command (map fst (extra @ chained)) end
  10.312 +
  10.313 +(** Hard-core proof reconstruction: structured Isar proofs **)
  10.314 +
  10.315 +(* Simple simplifications to ensure that sort annotations don't leave a trail of
  10.316 +   spurious "True"s. *)
  10.317 +fun s_not (Const (@{const_name All}, T) $ Abs (s, T', t')) =
  10.318 +    Const (@{const_name Ex}, T) $ Abs (s, T', s_not t')
  10.319 +  | s_not (Const (@{const_name Ex}, T) $ Abs (s, T', t')) =
  10.320 +    Const (@{const_name All}, T) $ Abs (s, T', s_not t')
  10.321 +  | s_not (@{const HOL.implies} $ t1 $ t2) = @{const HOL.conj} $ t1 $ s_not t2
  10.322 +  | s_not (@{const HOL.conj} $ t1 $ t2) =
  10.323 +    @{const HOL.disj} $ s_not t1 $ s_not t2
  10.324 +  | s_not (@{const HOL.disj} $ t1 $ t2) =
  10.325 +    @{const HOL.conj} $ s_not t1 $ s_not t2
  10.326 +  | s_not (@{const False}) = @{const True}
  10.327 +  | s_not (@{const True}) = @{const False}
  10.328 +  | s_not (@{const Not} $ t) = t
  10.329 +  | s_not t = @{const Not} $ t
  10.330 +fun s_conj (@{const True}, t2) = t2
  10.331 +  | s_conj (t1, @{const True}) = t1
  10.332 +  | s_conj p = HOLogic.mk_conj p
  10.333 +fun s_disj (@{const False}, t2) = t2
  10.334 +  | s_disj (t1, @{const False}) = t1
  10.335 +  | s_disj p = HOLogic.mk_disj p
  10.336 +fun s_imp (@{const True}, t2) = t2
  10.337 +  | s_imp (t1, @{const False}) = s_not t1
  10.338 +  | s_imp p = HOLogic.mk_imp p
  10.339 +fun s_iff (@{const True}, t2) = t2
  10.340 +  | s_iff (t1, @{const True}) = t1
  10.341 +  | s_iff (t1, t2) = HOLogic.eq_const HOLogic.boolT $ t1 $ t2
  10.342 +
  10.343 +fun forall_of v t = HOLogic.all_const (fastype_of v) $ lambda v t
  10.344 +fun exists_of v t = HOLogic.exists_const (fastype_of v) $ lambda v t
  10.345 +
  10.346 +val indent_size = 2
  10.347 +val no_label = ("", ~1)
  10.348 +
  10.349 +val raw_prefix = "X"
  10.350 +val assum_prefix = "A"
  10.351 +val have_prefix = "F"
  10.352 +
  10.353 +fun raw_label_for_name conjecture_shape name =
  10.354 +  case resolve_conjecture conjecture_shape name of
  10.355 +    [j] => (conjecture_prefix, j)
  10.356 +  | _ => case Int.fromString (fst name) of
  10.357 +           SOME j => (raw_prefix, j)
  10.358 +         | NONE => (raw_prefix ^ fst name, 0)
  10.359 +
  10.360 +(**** INTERPRETATION OF TSTP SYNTAX TREES ****)
  10.361 +
  10.362 +exception FO_TERM of string fo_term list
  10.363 +exception FORMULA of (string, string, string fo_term) formula list
  10.364 +exception SAME of unit
  10.365 +
  10.366 +(* Type variables are given the basic sort "HOL.type". Some will later be
  10.367 +   constrained by information from type literals, or by type inference. *)
  10.368 +fun typ_from_atp tfrees (u as ATerm (a, us)) =
  10.369 +  let val Ts = map (typ_from_atp tfrees) us in
  10.370 +    case strip_prefix_and_unascii type_const_prefix a of
  10.371 +      SOME b => Type (invert_const b, Ts)
  10.372 +    | NONE =>
  10.373 +      if not (null us) then
  10.374 +        raise FO_TERM [u]  (* only "tconst"s have type arguments *)
  10.375 +      else case strip_prefix_and_unascii tfree_prefix a of
  10.376 +        SOME b =>
  10.377 +        let val s = "'" ^ b in
  10.378 +          TFree (s, AList.lookup (op =) tfrees s |> the_default HOLogic.typeS)
  10.379 +        end
  10.380 +      | NONE =>
  10.381 +        case strip_prefix_and_unascii tvar_prefix a of
  10.382 +          SOME b => TVar (("'" ^ b, 0), HOLogic.typeS)
  10.383 +        | NONE =>
  10.384 +          (* Variable from the ATP, say "X1" *)
  10.385 +          Type_Infer.param 0 (a, HOLogic.typeS)
  10.386 +  end
  10.387 +
  10.388 +(* Type class literal applied to a type. Returns triple of polarity, class,
  10.389 +   type. *)
  10.390 +fun type_constraint_from_term tfrees (u as ATerm (a, us)) =
  10.391 +  case (strip_prefix_and_unascii class_prefix a,
  10.392 +        map (typ_from_atp tfrees) us) of
  10.393 +    (SOME b, [T]) => (b, T)
  10.394 +  | _ => raise FO_TERM [u]
  10.395 +
  10.396 +(** Accumulate type constraints in a formula: negative type literals **)
  10.397 +fun add_var (key, z)  = Vartab.map_default (key, []) (cons z)
  10.398 +fun add_type_constraint false (cl, TFree (a ,_)) = add_var ((a, ~1), cl)
  10.399 +  | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl)
  10.400 +  | add_type_constraint _ _ = I
  10.401 +
  10.402 +fun repair_variable_name f s =
  10.403 +  let
  10.404 +    fun subscript_name s n = s ^ nat_subscript n
  10.405 +    val s = String.map f s
  10.406 +  in
  10.407 +    case space_explode "_" s of
  10.408 +      [_] => (case take_suffix Char.isDigit (String.explode s) of
  10.409 +                (cs1 as _ :: _, cs2 as _ :: _) =>
  10.410 +                subscript_name (String.implode cs1)
  10.411 +                               (the (Int.fromString (String.implode cs2)))
  10.412 +              | (_, _) => s)
  10.413 +    | [s1, s2] => (case Int.fromString s2 of
  10.414 +                     SOME n => subscript_name s1 n
  10.415 +                   | NONE => s)
  10.416 +    | _ => s
  10.417 +  end
  10.418 +  
  10.419 +(* First-order translation. No types are known for variables. "HOLogic.typeT"
  10.420 +   should allow them to be inferred. *)
  10.421 +fun term_from_atp thy textual sym_tab tfrees =
  10.422 +  let
  10.423 +    (* see also "mk_var" in "Metis_Reconstruct" *)
  10.424 +    val var_index = if textual then 0 else 1
  10.425 +    fun do_term extra_us opt_T u =
  10.426 +      case u of
  10.427 +        ATerm (a, us) =>
  10.428 +        if String.isPrefix simple_type_prefix a then
  10.429 +          @{const True} (* ignore TPTP type information *)
  10.430 +        else if a = tptp_equal then
  10.431 +          let val ts = map (do_term [] NONE) us in
  10.432 +            if textual andalso length ts = 2 andalso
  10.433 +              hd ts aconv List.last ts then
  10.434 +              (* Vampire is keen on producing these. *)
  10.435 +              @{const True}
  10.436 +            else
  10.437 +              list_comb (Const (@{const_name HOL.eq}, HOLogic.typeT), ts)
  10.438 +          end
  10.439 +        else case strip_prefix_and_unascii const_prefix a of
  10.440 +          SOME s =>
  10.441 +          let
  10.442 +            val ((s', s), mangled_us) = s |> unmangled_const |>> `invert_const
  10.443 +          in
  10.444 +            if s' = type_tag_name then
  10.445 +              case mangled_us @ us of
  10.446 +                [typ_u, term_u] =>
  10.447 +                do_term extra_us (SOME (typ_from_atp tfrees typ_u)) term_u
  10.448 +              | _ => raise FO_TERM us
  10.449 +            else if s' = predicator_name then
  10.450 +              do_term [] (SOME @{typ bool}) (hd us)
  10.451 +            else if s' = app_op_name then
  10.452 +              do_term (nth us 1 :: extra_us) opt_T (hd us)
  10.453 +            else if s' = type_pred_name then
  10.454 +              @{const True} (* ignore type predicates *)
  10.455 +            else
  10.456 +              let
  10.457 +                val num_ty_args =
  10.458 +                  length us - the_default 0 (Symtab.lookup sym_tab s)
  10.459 +                val (type_us, term_us) =
  10.460 +                  chop num_ty_args us |>> append mangled_us
  10.461 +                (* Extra args from "hAPP" come after any arguments given
  10.462 +                   directly to the constant. *)
  10.463 +                val term_ts = map (do_term [] NONE) term_us
  10.464 +                val extra_ts = map (do_term [] NONE) extra_us
  10.465 +                val T =
  10.466 +                  if not (null type_us) andalso
  10.467 +                     num_type_args thy s' = length type_us then
  10.468 +                    (s', map (typ_from_atp tfrees) type_us)
  10.469 +                    |> Sign.const_instance thy
  10.470 +                  else case opt_T of
  10.471 +                    SOME T => map fastype_of (term_ts @ extra_ts) ---> T
  10.472 +                  | NONE => HOLogic.typeT
  10.473 +                val s' = s' |> unproxify_const
  10.474 +              in list_comb (Const (s', T), term_ts @ extra_ts) end
  10.475 +          end
  10.476 +        | NONE => (* a free or schematic variable *)
  10.477 +          let
  10.478 +            val ts = map (do_term [] NONE) (us @ extra_us)
  10.479 +            val T = map fastype_of ts ---> HOLogic.typeT
  10.480 +            val t =
  10.481 +              case strip_prefix_and_unascii fixed_var_prefix a of
  10.482 +                SOME b => Free (b, T)
  10.483 +              | NONE =>
  10.484 +                case strip_prefix_and_unascii schematic_var_prefix a of
  10.485 +                  SOME b => Var ((b, var_index), T)
  10.486 +                | NONE =>
  10.487 +                  Var ((a |> textual ? repair_variable_name Char.toLower,
  10.488 +                        var_index), T)
  10.489 +          in list_comb (t, ts) end
  10.490 +  in do_term [] end
  10.491 +
  10.492 +fun term_from_atom thy textual sym_tab tfrees pos (u as ATerm (s, _)) =
  10.493 +  if String.isPrefix class_prefix s then
  10.494 +    add_type_constraint pos (type_constraint_from_term tfrees u)
  10.495 +    #> pair @{const True}
  10.496 +  else
  10.497 +    pair (term_from_atp thy textual sym_tab tfrees (SOME @{typ bool}) u)
  10.498 +
  10.499 +val combinator_table =
  10.500 +  [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}),
  10.501 +   (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}),
  10.502 +   (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}),
  10.503 +   (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}),
  10.504 +   (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})]
  10.505 +
  10.506 +fun uncombine_term thy =
  10.507 +  let
  10.508 +    fun aux (t1 $ t2) = betapply (pairself aux (t1, t2))
  10.509 +      | aux (Abs (s, T, t')) = Abs (s, T, aux t')
  10.510 +      | aux (t as Const (x as (s, _))) =
  10.511 +        (case AList.lookup (op =) combinator_table s of
  10.512 +           SOME thm => thm |> prop_of |> specialize_type thy x
  10.513 +                           |> Logic.dest_equals |> snd
  10.514 +         | NONE => t)
  10.515 +      | aux t = t
  10.516 +  in aux end
  10.517 +
  10.518 +(* Update schematic type variables with detected sort constraints. It's not
  10.519 +   totally clear whether this code is necessary. *)
  10.520 +fun repair_tvar_sorts (t, tvar_tab) =
  10.521 +  let
  10.522 +    fun do_type (Type (a, Ts)) = Type (a, map do_type Ts)
  10.523 +      | do_type (TVar (xi, s)) =
  10.524 +        TVar (xi, the_default s (Vartab.lookup tvar_tab xi))
  10.525 +      | do_type (TFree z) = TFree z
  10.526 +    fun do_term (Const (a, T)) = Const (a, do_type T)
  10.527 +      | do_term (Free (a, T)) = Free (a, do_type T)
  10.528 +      | do_term (Var (xi, T)) = Var (xi, do_type T)
  10.529 +      | do_term (t as Bound _) = t
  10.530 +      | do_term (Abs (a, T, t)) = Abs (a, do_type T, do_term t)
  10.531 +      | do_term (t1 $ t2) = do_term t1 $ do_term t2
  10.532 +  in t |> not (Vartab.is_empty tvar_tab) ? do_term end
  10.533 +
  10.534 +fun quantify_over_var quant_of var_s t =
  10.535 +  let
  10.536 +    val vars = [] |> Term.add_vars t |> filter (fn ((s, _), _) => s = var_s)
  10.537 +                  |> map Var
  10.538 +  in fold_rev quant_of vars t end
  10.539 +
  10.540 +(* Interpret an ATP formula as a HOL term, extracting sort constraints as they
  10.541 +   appear in the formula. *)
  10.542 +fun prop_from_formula thy textual sym_tab tfrees phi =
  10.543 +  let
  10.544 +    fun do_formula pos phi =
  10.545 +      case phi of
  10.546 +        AQuant (_, [], phi) => do_formula pos phi
  10.547 +      | AQuant (q, (s, _) :: xs, phi') =>
  10.548 +        do_formula pos (AQuant (q, xs, phi'))
  10.549 +        (* FIXME: TFF *)
  10.550 +        #>> quantify_over_var (case q of
  10.551 +                                 AForall => forall_of
  10.552 +                               | AExists => exists_of)
  10.553 +                              (s |> textual ? repair_variable_name Char.toLower)
  10.554 +      | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not
  10.555 +      | AConn (c, [phi1, phi2]) =>
  10.556 +        do_formula (pos |> c = AImplies ? not) phi1
  10.557 +        ##>> do_formula pos phi2
  10.558 +        #>> (case c of
  10.559 +               AAnd => s_conj
  10.560 +             | AOr => s_disj
  10.561 +             | AImplies => s_imp
  10.562 +             | AIf => s_imp o swap
  10.563 +             | AIff => s_iff
  10.564 +             | ANotIff => s_not o s_iff
  10.565 +             | _ => raise Fail "unexpected connective")
  10.566 +      | AAtom tm => term_from_atom thy textual sym_tab tfrees pos tm
  10.567 +      | _ => raise FORMULA [phi]
  10.568 +  in repair_tvar_sorts (do_formula true phi Vartab.empty) end
  10.569 +
  10.570 +fun check_formula ctxt =
  10.571 +  Type.constraint HOLogic.boolT
  10.572 +  #> Syntax.check_term
  10.573 +         (Proof_Context.set_mode Proof_Context.mode_schematic ctxt)
  10.574 +
  10.575 +(**** Translation of TSTP files to Isar proofs ****)
  10.576 +
  10.577 +fun unvarify_term (Var ((s, 0), T)) = Free (s, T)
  10.578 +  | unvarify_term t = raise TERM ("unvarify_term: non-Var", [t])
  10.579 +
  10.580 +fun decode_line sym_tab tfrees (Definition (name, phi1, phi2)) ctxt =
  10.581 +    let
  10.582 +      val thy = Proof_Context.theory_of ctxt
  10.583 +      val t1 = prop_from_formula thy true sym_tab tfrees phi1
  10.584 +      val vars = snd (strip_comb t1)
  10.585 +      val frees = map unvarify_term vars
  10.586 +      val unvarify_args = subst_atomic (vars ~~ frees)
  10.587 +      val t2 = prop_from_formula thy true sym_tab tfrees phi2
  10.588 +      val (t1, t2) =
  10.589 +        HOLogic.eq_const HOLogic.typeT $ t1 $ t2
  10.590 +        |> unvarify_args |> uncombine_term thy |> check_formula ctxt
  10.591 +        |> HOLogic.dest_eq
  10.592 +    in
  10.593 +      (Definition (name, t1, t2),
  10.594 +       fold Variable.declare_term (maps OldTerm.term_frees [t1, t2]) ctxt)
  10.595 +    end
  10.596 +  | decode_line sym_tab tfrees (Inference (name, u, deps)) ctxt =
  10.597 +    let
  10.598 +      val thy = Proof_Context.theory_of ctxt
  10.599 +      val t = u |> prop_from_formula thy true sym_tab tfrees
  10.600 +                |> uncombine_term thy |> check_formula ctxt
  10.601 +    in
  10.602 +      (Inference (name, t, deps),
  10.603 +       fold Variable.declare_term (OldTerm.term_frees t) ctxt)
  10.604 +    end
  10.605 +fun decode_lines ctxt sym_tab tfrees lines =
  10.606 +  fst (fold_map (decode_line sym_tab tfrees) lines ctxt)
  10.607 +
  10.608 +fun is_same_inference _ (Definition _) = false
  10.609 +  | is_same_inference t (Inference (_, t', _)) = t aconv t'
  10.610 +
  10.611 +(* No "real" literals means only type information (tfree_tcs, clsrel, or
  10.612 +   clsarity). *)
  10.613 +val is_only_type_information = curry (op aconv) HOLogic.true_const
  10.614 +
  10.615 +fun replace_one_dependency (old, new) dep =
  10.616 +  if is_same_atp_step dep old then new else [dep]
  10.617 +fun replace_dependencies_in_line _ (line as Definition _) = line
  10.618 +  | replace_dependencies_in_line p (Inference (name, t, deps)) =
  10.619 +    Inference (name, t, fold (union (op =) o replace_one_dependency p) deps [])
  10.620 +
  10.621 +(* Discard facts; consolidate adjacent lines that prove the same formula, since
  10.622 +   they differ only in type information.*)
  10.623 +fun add_line _ _ _ (line as Definition _) lines = line :: lines
  10.624 +  | add_line type_sys conjecture_shape fact_names (Inference (name, t, []))
  10.625 +             lines =
  10.626 +    (* No dependencies: fact, conjecture, or (for Vampire) internal facts or
  10.627 +       definitions. *)
  10.628 +    if is_fact type_sys fact_names name then
  10.629 +      (* Facts are not proof lines. *)
  10.630 +      if is_only_type_information t then
  10.631 +        map (replace_dependencies_in_line (name, [])) lines
  10.632 +      (* Is there a repetition? If so, replace later line by earlier one. *)
  10.633 +      else case take_prefix (not o is_same_inference t) lines of
  10.634 +        (_, []) => lines (* no repetition of proof line *)
  10.635 +      | (pre, Inference (name', _, _) :: post) =>
  10.636 +        pre @ map (replace_dependencies_in_line (name', [name])) post
  10.637 +      | _ => raise Fail "unexpected inference"
  10.638 +    else if is_conjecture conjecture_shape name then
  10.639 +      Inference (name, s_not t, []) :: lines
  10.640 +    else
  10.641 +      map (replace_dependencies_in_line (name, [])) lines
  10.642 +  | add_line _ _ _ (Inference (name, t, deps)) lines =
  10.643 +    (* Type information will be deleted later; skip repetition test. *)
  10.644 +    if is_only_type_information t then
  10.645 +      Inference (name, t, deps) :: lines
  10.646 +    (* Is there a repetition? If so, replace later line by earlier one. *)
  10.647 +    else case take_prefix (not o is_same_inference t) lines of
  10.648 +      (* FIXME: Doesn't this code risk conflating proofs involving different
  10.649 +         types? *)
  10.650 +       (_, []) => Inference (name, t, deps) :: lines
  10.651 +     | (pre, Inference (name', t', _) :: post) =>
  10.652 +       Inference (name, t', deps) ::
  10.653 +       pre @ map (replace_dependencies_in_line (name', [name])) post
  10.654 +     | _ => raise Fail "unexpected inference"
  10.655 +
  10.656 +(* Recursively delete empty lines (type information) from the proof. *)
  10.657 +fun add_nontrivial_line (Inference (name, t, [])) lines =
  10.658 +    if is_only_type_information t then delete_dependency name lines
  10.659 +    else Inference (name, t, []) :: lines
  10.660 +  | add_nontrivial_line line lines = line :: lines
  10.661 +and delete_dependency name lines =
  10.662 +  fold_rev add_nontrivial_line
  10.663 +           (map (replace_dependencies_in_line (name, [])) lines) []
  10.664 +
  10.665 +(* ATPs sometimes reuse free variable names in the strangest ways. Removing
  10.666 +   offending lines often does the trick. *)
  10.667 +fun is_bad_free frees (Free x) = not (member (op =) frees x)
  10.668 +  | is_bad_free _ _ = false
  10.669 +
  10.670 +fun add_desired_line _ _ _ _ _ (line as Definition (name, _, _)) (j, lines) =
  10.671 +    (j, line :: map (replace_dependencies_in_line (name, [])) lines)
  10.672 +  | add_desired_line type_sys isar_shrink_factor conjecture_shape fact_names
  10.673 +                     frees (Inference (name, t, deps)) (j, lines) =
  10.674 +    (j + 1,
  10.675 +     if is_fact type_sys fact_names name orelse
  10.676 +        is_conjecture conjecture_shape name orelse
  10.677 +        (* the last line must be kept *)
  10.678 +        j = 0 orelse
  10.679 +        (not (is_only_type_information t) andalso
  10.680 +         null (Term.add_tvars t []) andalso
  10.681 +         not (exists_subterm (is_bad_free frees) t) andalso
  10.682 +         length deps >= 2 andalso j mod isar_shrink_factor = 0 andalso
  10.683 +         (* kill next to last line, which usually results in a trivial step *)
  10.684 +         j <> 1) then
  10.685 +       Inference (name, t, deps) :: lines  (* keep line *)
  10.686 +     else
  10.687 +       map (replace_dependencies_in_line (name, deps)) lines)  (* drop line *)
  10.688 +
  10.689 +(** Isar proof construction and manipulation **)
  10.690 +
  10.691 +fun merge_fact_sets (ls1, ss1) (ls2, ss2) =
  10.692 +  (union (op =) ls1 ls2, union (op =) ss1 ss2)
  10.693 +
  10.694 +type label = string * int
  10.695 +type facts = label list * string list
  10.696 +
  10.697 +datatype isar_qualifier = Show | Then | Moreover | Ultimately
  10.698 +
  10.699 +datatype isar_step =
  10.700 +  Fix of (string * typ) list |
  10.701 +  Let of term * term |
  10.702 +  Assume of label * term |
  10.703 +  Have of isar_qualifier list * label * term * byline
  10.704 +and byline =
  10.705 +  ByMetis of facts |
  10.706 +  CaseSplit of isar_step list list * facts
  10.707 +
  10.708 +fun smart_case_split [] facts = ByMetis facts
  10.709 +  | smart_case_split proofs facts = CaseSplit (proofs, facts)
  10.710 +
  10.711 +fun add_fact_from_dependency type_sys conjecture_shape facts_offset fact_names
  10.712 +                             name =
  10.713 +  if is_fact type_sys fact_names name then
  10.714 +    apsnd (union (op =)
  10.715 +          (map fst (resolve_fact type_sys facts_offset fact_names name)))
  10.716 +  else
  10.717 +    apfst (insert (op =) (raw_label_for_name conjecture_shape name))
  10.718 +
  10.719 +fun step_for_line _ _ _ _ _ (Definition (_, t1, t2)) = Let (t1, t2)
  10.720 +  | step_for_line _ conjecture_shape _ _ _ (Inference (name, t, [])) =
  10.721 +    Assume (raw_label_for_name conjecture_shape name, t)
  10.722 +  | step_for_line type_sys conjecture_shape facts_offset
  10.723 +                  fact_names j (Inference (name, t, deps)) =
  10.724 +    Have (if j = 1 then [Show] else [],
  10.725 +          raw_label_for_name conjecture_shape name,
  10.726 +          fold_rev forall_of (map Var (Term.add_vars t [])) t,
  10.727 +          ByMetis (fold (add_fact_from_dependency type_sys conjecture_shape
  10.728 +                                                  facts_offset fact_names)
  10.729 +                        deps ([], [])))
  10.730 +
  10.731 +fun repair_name "$true" = "c_True"
  10.732 +  | repair_name "$false" = "c_False"
  10.733 +  | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *)
  10.734 +  | repair_name s =
  10.735 +    if is_tptp_equal s orelse
  10.736 +       (* seen in Vampire proofs *)
  10.737 +       (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then
  10.738 +      tptp_equal
  10.739 +    else
  10.740 +      s
  10.741 +
  10.742 +fun isar_proof_from_atp_proof pool ctxt type_sys tfrees isar_shrink_factor
  10.743 +        conjecture_shape facts_offset fact_names sym_tab params frees
  10.744 +        atp_proof =
  10.745 +  let
  10.746 +    val lines =
  10.747 +      atp_proof
  10.748 +      |> clean_up_atp_proof_dependencies
  10.749 +      |> nasty_atp_proof pool
  10.750 +      |> map_term_names_in_atp_proof repair_name
  10.751 +      |> decode_lines ctxt sym_tab tfrees
  10.752 +      |> rpair [] |-> fold_rev (add_line type_sys conjecture_shape fact_names)
  10.753 +      |> rpair [] |-> fold_rev add_nontrivial_line
  10.754 +      |> rpair (0, [])
  10.755 +      |-> fold_rev (add_desired_line type_sys isar_shrink_factor
  10.756 +                                     conjecture_shape fact_names frees)
  10.757 +      |> snd
  10.758 +  in
  10.759 +    (if null params then [] else [Fix params]) @
  10.760 +    map2 (step_for_line type_sys conjecture_shape facts_offset fact_names)
  10.761 +         (length lines downto 1) lines
  10.762 +  end
  10.763 +
  10.764 +(* When redirecting proofs, we keep information about the labels seen so far in
  10.765 +   the "backpatches" data structure. The first component indicates which facts
  10.766 +   should be associated with forthcoming proof steps. The second component is a
  10.767 +   pair ("assum_ls", "drop_ls"), where "assum_ls" are the labels that should
  10.768 +   become assumptions and "drop_ls" are the labels that should be dropped in a
  10.769 +   case split. *)
  10.770 +type backpatches = (label * facts) list * (label list * label list)
  10.771 +
  10.772 +fun used_labels_of_step (Have (_, _, _, by)) =
  10.773 +    (case by of
  10.774 +       ByMetis (ls, _) => ls
  10.775 +     | CaseSplit (proofs, (ls, _)) =>
  10.776 +       fold (union (op =) o used_labels_of) proofs ls)
  10.777 +  | used_labels_of_step _ = []
  10.778 +and used_labels_of proof = fold (union (op =) o used_labels_of_step) proof []
  10.779 +
  10.780 +fun new_labels_of_step (Fix _) = []
  10.781 +  | new_labels_of_step (Let _) = []
  10.782 +  | new_labels_of_step (Assume (l, _)) = [l]
  10.783 +  | new_labels_of_step (Have (_, l, _, _)) = [l]
  10.784 +val new_labels_of = maps new_labels_of_step
  10.785 +
  10.786 +val join_proofs =
  10.787 +  let
  10.788 +    fun aux _ [] = NONE
  10.789 +      | aux proof_tail (proofs as (proof1 :: _)) =
  10.790 +        if exists null proofs then
  10.791 +          NONE
  10.792 +        else if forall (curry (op =) (hd proof1) o hd) (tl proofs) then
  10.793 +          aux (hd proof1 :: proof_tail) (map tl proofs)
  10.794 +        else case hd proof1 of
  10.795 +          Have ([], l, t, _) => (* FIXME: should we really ignore the "by"? *)
  10.796 +          if forall (fn Have ([], l', t', _) :: _ => (l, t) = (l', t')
  10.797 +                      | _ => false) (tl proofs) andalso
  10.798 +             not (exists (member (op =) (maps new_labels_of proofs))
  10.799 +                         (used_labels_of proof_tail)) then
  10.800 +            SOME (l, t, map rev proofs, proof_tail)
  10.801 +          else
  10.802 +            NONE
  10.803 +        | _ => NONE
  10.804 +  in aux [] o map rev end
  10.805 +
  10.806 +fun case_split_qualifiers proofs =
  10.807 +  case length proofs of
  10.808 +    0 => []
  10.809 +  | 1 => [Then]
  10.810 +  | _ => [Ultimately]
  10.811 +
  10.812 +fun redirect_proof hyp_ts concl_t proof =
  10.813 +  let
  10.814 +    (* The first pass outputs those steps that are independent of the negated
  10.815 +       conjecture. The second pass flips the proof by contradiction to obtain a
  10.816 +       direct proof, introducing case splits when an inference depends on
  10.817 +       several facts that depend on the negated conjecture. *)
  10.818 +     val concl_l = (conjecture_prefix, length hyp_ts)
  10.819 +     fun first_pass ([], contra) = ([], contra)
  10.820 +       | first_pass ((step as Fix _) :: proof, contra) =
  10.821 +         first_pass (proof, contra) |>> cons step
  10.822 +       | first_pass ((step as Let _) :: proof, contra) =
  10.823 +         first_pass (proof, contra) |>> cons step
  10.824 +       | first_pass ((step as Assume (l as (_, j), _)) :: proof, contra) =
  10.825 +         if l = concl_l then first_pass (proof, contra ||> cons step)
  10.826 +         else first_pass (proof, contra) |>> cons (Assume (l, nth hyp_ts j))
  10.827 +       | first_pass (Have (qs, l, t, ByMetis (ls, ss)) :: proof, contra) =
  10.828 +         let val step = Have (qs, l, t, ByMetis (ls, ss)) in
  10.829 +           if exists (member (op =) (fst contra)) ls then
  10.830 +             first_pass (proof, contra |>> cons l ||> cons step)
  10.831 +           else
  10.832 +             first_pass (proof, contra) |>> cons step
  10.833 +         end
  10.834 +       | first_pass _ = raise Fail "malformed proof"
  10.835 +    val (proof_top, (contra_ls, contra_proof)) =
  10.836 +      first_pass (proof, ([concl_l], []))
  10.837 +    val backpatch_label = the_default ([], []) oo AList.lookup (op =) o fst
  10.838 +    fun backpatch_labels patches ls =
  10.839 +      fold merge_fact_sets (map (backpatch_label patches) ls) ([], [])
  10.840 +    fun second_pass end_qs ([], assums, patches) =
  10.841 +        ([Have (end_qs, no_label, concl_t,
  10.842 +                ByMetis (backpatch_labels patches (map snd assums)))], patches)
  10.843 +      | second_pass end_qs (Assume (l, t) :: proof, assums, patches) =
  10.844 +        second_pass end_qs (proof, (t, l) :: assums, patches)
  10.845 +      | second_pass end_qs (Have (qs, l, t, ByMetis (ls, ss)) :: proof, assums,
  10.846 +                            patches) =
  10.847 +        (if member (op =) (snd (snd patches)) l andalso
  10.848 +            not (member (op =) (fst (snd patches)) l) andalso
  10.849 +            not (AList.defined (op =) (fst patches) l) then
  10.850 +           second_pass end_qs (proof, assums, patches ||> apsnd (append ls))
  10.851 +         else case List.partition (member (op =) contra_ls) ls of
  10.852 +           ([contra_l], co_ls) =>
  10.853 +           if member (op =) qs Show then
  10.854 +             second_pass end_qs (proof, assums,
  10.855 +                                 patches |>> cons (contra_l, (co_ls, ss)))
  10.856 +           else
  10.857 +             second_pass end_qs
  10.858 +                         (proof, assums,
  10.859 +                          patches |>> cons (contra_l, (l :: co_ls, ss)))
  10.860 +             |>> cons (if member (op =) (fst (snd patches)) l then
  10.861 +                         Assume (l, s_not t)
  10.862 +                       else
  10.863 +                         Have (qs, l, s_not t,
  10.864 +                               ByMetis (backpatch_label patches l)))
  10.865 +         | (contra_ls as _ :: _, co_ls) =>
  10.866 +           let
  10.867 +             val proofs =
  10.868 +               map_filter
  10.869 +                   (fn l =>
  10.870 +                       if l = concl_l then
  10.871 +                         NONE
  10.872 +                       else
  10.873 +                         let
  10.874 +                           val drop_ls = filter (curry (op <>) l) contra_ls
  10.875 +                         in
  10.876 +                           second_pass []
  10.877 +                               (proof, assums,
  10.878 +                                patches ||> apfst (insert (op =) l)
  10.879 +                                        ||> apsnd (union (op =) drop_ls))
  10.880 +                           |> fst |> SOME
  10.881 +                         end) contra_ls
  10.882 +             val (assumes, facts) =
  10.883 +               if member (op =) (fst (snd patches)) l then
  10.884 +                 ([Assume (l, s_not t)], (l :: co_ls, ss))
  10.885 +               else
  10.886 +                 ([], (co_ls, ss))
  10.887 +           in
  10.888 +             (case join_proofs proofs of
  10.889 +                SOME (l, t, proofs, proof_tail) =>
  10.890 +                Have (case_split_qualifiers proofs @
  10.891 +                      (if null proof_tail then end_qs else []), l, t,
  10.892 +                      smart_case_split proofs facts) :: proof_tail
  10.893 +              | NONE =>
  10.894 +                [Have (case_split_qualifiers proofs @ end_qs, no_label,
  10.895 +                       concl_t, smart_case_split proofs facts)],
  10.896 +              patches)
  10.897 +             |>> append assumes
  10.898 +           end
  10.899 +         | _ => raise Fail "malformed proof")
  10.900 +       | second_pass _ _ = raise Fail "malformed proof"
  10.901 +    val proof_bottom =
  10.902 +      second_pass [Show] (contra_proof, [], ([], ([], []))) |> fst
  10.903 +  in proof_top @ proof_bottom end
  10.904 +
  10.905 +(* FIXME: Still needed? Probably not. *)
  10.906 +val kill_duplicate_assumptions_in_proof =
  10.907 +  let
  10.908 +    fun relabel_facts subst =
  10.909 +      apfst (map (fn l => AList.lookup (op =) subst l |> the_default l))
  10.910 +    fun do_step (step as Assume (l, t)) (proof, subst, assums) =
  10.911 +        (case AList.lookup (op aconv) assums t of
  10.912 +           SOME l' => (proof, (l, l') :: subst, assums)
  10.913 +         | NONE => (step :: proof, subst, (t, l) :: assums))
  10.914 +      | do_step (Have (qs, l, t, by)) (proof, subst, assums) =
  10.915 +        (Have (qs, l, t,
  10.916 +               case by of
  10.917 +                 ByMetis facts => ByMetis (relabel_facts subst facts)
  10.918 +               | CaseSplit (proofs, facts) =>
  10.919 +                 CaseSplit (map do_proof proofs, relabel_facts subst facts)) ::
  10.920 +         proof, subst, assums)
  10.921 +      | do_step step (proof, subst, assums) = (step :: proof, subst, assums)
  10.922 +    and do_proof proof = fold do_step proof ([], [], []) |> #1 |> rev
  10.923 +  in do_proof end
  10.924 +
  10.925 +val then_chain_proof =
  10.926 +  let
  10.927 +    fun aux _ [] = []
  10.928 +      | aux _ ((step as Assume (l, _)) :: proof) = step :: aux l proof
  10.929 +      | aux l' (Have (qs, l, t, by) :: proof) =
  10.930 +        (case by of
  10.931 +           ByMetis (ls, ss) =>
  10.932 +           Have (if member (op =) ls l' then
  10.933 +                   (Then :: qs, l, t,
  10.934 +                    ByMetis (filter_out (curry (op =) l') ls, ss))
  10.935 +                 else
  10.936 +                   (qs, l, t, ByMetis (ls, ss)))
  10.937 +         | CaseSplit (proofs, facts) =>
  10.938 +           Have (qs, l, t, CaseSplit (map (aux no_label) proofs, facts))) ::
  10.939 +        aux l proof
  10.940 +      | aux _ (step :: proof) = step :: aux no_label proof
  10.941 +  in aux no_label end
  10.942 +
  10.943 +fun kill_useless_labels_in_proof proof =
  10.944 +  let
  10.945 +    val used_ls = used_labels_of proof
  10.946 +    fun do_label l = if member (op =) used_ls l then l else no_label
  10.947 +    fun do_step (Assume (l, t)) = Assume (do_label l, t)
  10.948 +      | do_step (Have (qs, l, t, by)) =
  10.949 +        Have (qs, do_label l, t,
  10.950 +              case by of
  10.951 +                CaseSplit (proofs, facts) =>
  10.952 +                CaseSplit (map (map do_step) proofs, facts)
  10.953 +              | _ => by)
  10.954 +      | do_step step = step
  10.955 +  in map do_step proof end
  10.956 +
  10.957 +fun prefix_for_depth n = replicate_string (n + 1)
  10.958 +
  10.959 +val relabel_proof =
  10.960 +  let
  10.961 +    fun aux _ _ _ [] = []
  10.962 +      | aux subst depth (next_assum, next_fact) (Assume (l, t) :: proof) =
  10.963 +        if l = no_label then
  10.964 +          Assume (l, t) :: aux subst depth (next_assum, next_fact) proof
  10.965 +        else
  10.966 +          let val l' = (prefix_for_depth depth assum_prefix, next_assum) in
  10.967 +            Assume (l', t) ::
  10.968 +            aux ((l, l') :: subst) depth (next_assum + 1, next_fact) proof
  10.969 +          end
  10.970 +      | aux subst depth (next_assum, next_fact) (Have (qs, l, t, by) :: proof) =
  10.971 +        let
  10.972 +          val (l', subst, next_fact) =
  10.973 +            if l = no_label then
  10.974 +              (l, subst, next_fact)
  10.975 +            else
  10.976 +              let
  10.977 +                val l' = (prefix_for_depth depth have_prefix, next_fact)
  10.978 +              in (l', (l, l') :: subst, next_fact + 1) end
  10.979 +          val relabel_facts =
  10.980 +            apfst (maps (the_list o AList.lookup (op =) subst))
  10.981 +          val by =
  10.982 +            case by of
  10.983 +              ByMetis facts => ByMetis (relabel_facts facts)
  10.984 +            | CaseSplit (proofs, facts) =>
  10.985 +              CaseSplit (map (aux subst (depth + 1) (1, 1)) proofs,
  10.986 +                         relabel_facts facts)
  10.987 +        in
  10.988 +          Have (qs, l', t, by) ::
  10.989 +          aux subst depth (next_assum, next_fact) proof
  10.990 +        end
  10.991 +      | aux subst depth nextp (step :: proof) =
  10.992 +        step :: aux subst depth nextp proof
  10.993 +  in aux [] 0 (1, 1) end
  10.994 +
  10.995 +fun string_for_proof ctxt0 full_types i n =
  10.996 +  let
  10.997 +    val ctxt =
  10.998 +      ctxt0 |> Config.put show_free_types false
  10.999 +            |> Config.put show_types true
 10.1000 +            |> Config.put show_sorts true
 10.1001 +    fun fix_print_mode f x =
 10.1002 +      Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN)
 10.1003 +                               (print_mode_value ())) f x
 10.1004 +    fun do_indent ind = replicate_string (ind * indent_size) " "
 10.1005 +    fun do_free (s, T) =
 10.1006 +      maybe_quote s ^ " :: " ^
 10.1007 +      maybe_quote (fix_print_mode (Syntax.string_of_typ ctxt) T)
 10.1008 +    fun do_label l = if l = no_label then "" else string_for_label l ^ ": "
 10.1009 +    fun do_have qs =
 10.1010 +      (if member (op =) qs Moreover then "moreover " else "") ^
 10.1011 +      (if member (op =) qs Ultimately then "ultimately " else "") ^
 10.1012 +      (if member (op =) qs Then then
 10.1013 +         if member (op =) qs Show then "thus" else "hence"
 10.1014 +       else
 10.1015 +         if member (op =) qs Show then "show" else "have")
 10.1016 +    val do_term = maybe_quote o fix_print_mode (Syntax.string_of_term ctxt)
 10.1017 +    val reconstructor = if full_types then MetisFT else Metis
 10.1018 +    fun do_facts (ls, ss) =
 10.1019 +      reconstructor_command reconstructor 1 1
 10.1020 +          (ls |> sort_distinct (prod_ord string_ord int_ord),
 10.1021 +           ss |> sort_distinct string_ord)
 10.1022 +    and do_step ind (Fix xs) =
 10.1023 +        do_indent ind ^ "fix " ^ space_implode " and " (map do_free xs) ^ "\n"
 10.1024 +      | do_step ind (Let (t1, t2)) =
 10.1025 +        do_indent ind ^ "let " ^ do_term t1 ^ " = " ^ do_term t2 ^ "\n"
 10.1026 +      | do_step ind (Assume (l, t)) =
 10.1027 +        do_indent ind ^ "assume " ^ do_label l ^ do_term t ^ "\n"
 10.1028 +      | do_step ind (Have (qs, l, t, ByMetis facts)) =
 10.1029 +        do_indent ind ^ do_have qs ^ " " ^
 10.1030 +        do_label l ^ do_term t ^ " " ^ do_facts facts ^ "\n"
 10.1031 +      | do_step ind (Have (qs, l, t, CaseSplit (proofs, facts))) =
 10.1032 +        space_implode (do_indent ind ^ "moreover\n")
 10.1033 +                      (map (do_block ind) proofs) ^
 10.1034 +        do_indent ind ^ do_have qs ^ " " ^ do_label l ^ do_term t ^ " " ^
 10.1035 +        do_facts facts ^ "\n"
 10.1036 +    and do_steps prefix suffix ind steps =
 10.1037 +      let val s = implode (map (do_step ind) steps) in
 10.1038 +        replicate_string (ind * indent_size - size prefix) " " ^ prefix ^
 10.1039 +        String.extract (s, ind * indent_size,
 10.1040 +                        SOME (size s - ind * indent_size - 1)) ^
 10.1041 +        suffix ^ "\n"
 10.1042 +      end
 10.1043 +    and do_block ind proof = do_steps "{ " " }" (ind + 1) proof
 10.1044 +    (* One-step proofs are pointless; better use the Metis one-liner
 10.1045 +       directly. *)
 10.1046 +    and do_proof [Have (_, _, _, ByMetis _)] = ""
 10.1047 +      | do_proof proof =
 10.1048 +        (if i <> 1 then "prefer " ^ string_of_int i ^ "\n" else "") ^
 10.1049 +        do_indent 0 ^ "proof -\n" ^ do_steps "" "" 1 proof ^ do_indent 0 ^
 10.1050 +        (if n <> 1 then "next" else "qed")
 10.1051 +  in do_proof end
 10.1052 +
 10.1053 +fun isar_proof_text ctxt isar_proof_requested
 10.1054 +        (debug, full_types, isar_shrink_factor, type_sys, pool,
 10.1055 +         conjecture_shape, facts_offset, fact_names, sym_tab, atp_proof, goal)
 10.1056 +        (one_line_params as (_, _, _, _, subgoal, subgoal_count)) =
 10.1057 +  let
 10.1058 +    val isar_shrink_factor =
 10.1059 +      (if isar_proof_requested then 1 else 2) * isar_shrink_factor
 10.1060 +    val (params, hyp_ts, concl_t) = strip_subgoal ctxt goal subgoal
 10.1061 +    val frees = fold Term.add_frees (concl_t :: hyp_ts) []
 10.1062 +    val tfrees = fold Term.add_tfrees (concl_t :: hyp_ts) []
 10.1063 +    val one_line_proof = one_line_proof_text one_line_params
 10.1064 +    fun isar_proof_for () =
 10.1065 +      case atp_proof
 10.1066 +           |> isar_proof_from_atp_proof pool ctxt type_sys tfrees
 10.1067 +                  isar_shrink_factor conjecture_shape facts_offset
 10.1068 +                  fact_names sym_tab params frees
 10.1069 +           |> redirect_proof hyp_ts concl_t
 10.1070 +           |> kill_duplicate_assumptions_in_proof
 10.1071 +           |> then_chain_proof
 10.1072 +           |> kill_useless_labels_in_proof
 10.1073 +           |> relabel_proof
 10.1074 +           |> string_for_proof ctxt full_types subgoal subgoal_count of
 10.1075 +        "" =>
 10.1076 +        if isar_proof_requested then
 10.1077 +          "\nNo structured proof available (proof too short)."
 10.1078 +        else
 10.1079 +          ""
 10.1080 +      | proof =>
 10.1081 +        "\n\n" ^ (if isar_proof_requested then "Structured proof"
 10.1082 +                  else "Perhaps this will work") ^
 10.1083 +        ":\n" ^ Markup.markup Markup.sendback proof
 10.1084 +    val isar_proof =
 10.1085 +      if debug then
 10.1086 +        isar_proof_for ()
 10.1087 +      else
 10.1088 +        case try isar_proof_for () of
 10.1089 +          SOME s => s
 10.1090 +        | NONE => if isar_proof_requested then
 10.1091 +                    "\nWarning: The Isar proof construction failed."
 10.1092 +                  else
 10.1093 +                    ""
 10.1094 +  in one_line_proof ^ isar_proof end
 10.1095 +
 10.1096 +fun proof_text ctxt isar_proof isar_params
 10.1097 +               (one_line_params as (preplay, _, _, _, _, _)) =
 10.1098 +  (if isar_proof orelse preplay = Failed_to_Play then
 10.1099 +     isar_proof_text ctxt isar_proof isar_params
 10.1100 +   else
 10.1101 +     one_line_proof_text) one_line_params
 10.1102 +
 10.1103 +end;
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Tools/ATP/atp_translate.ML	Tue May 31 18:13:00 2011 +0200
    11.3 @@ -0,0 +1,1900 @@
    11.4 +(*  Title:      HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML
    11.5 +    Author:     Fabian Immler, TU Muenchen
    11.6 +    Author:     Makarius
    11.7 +    Author:     Jasmin Blanchette, TU Muenchen
    11.8 +
    11.9 +Translation of HOL to FOL for Sledgehammer.
   11.10 +*)
   11.11 +
   11.12 +signature ATP_TRANSLATE =
   11.13 +sig
   11.14 +  type 'a fo_term = 'a ATP_Problem.fo_term
   11.15 +  type format = ATP_Problem.format
   11.16 +  type formula_kind = ATP_Problem.formula_kind
   11.17 +  type 'a problem = 'a ATP_Problem.problem
   11.18 +
   11.19 +  type name = string * string
   11.20 +
   11.21 +  datatype type_literal =
   11.22 +    TyLitVar of name * name |
   11.23 +    TyLitFree of name * name
   11.24 +
   11.25 +  datatype arity_literal =
   11.26 +    TConsLit of name * name * name list |
   11.27 +    TVarLit of name * name
   11.28 +
   11.29 +  type arity_clause =
   11.30 +    {name: string,
   11.31 +     prem_lits: arity_literal list,
   11.32 +     concl_lits: arity_literal}
   11.33 +
   11.34 +  type class_rel_clause =
   11.35 +    {name: string,
   11.36 +     subclass: name,
   11.37 +     superclass: name}
   11.38 +
   11.39 +  datatype combterm =
   11.40 +    CombConst of name * typ * typ list |
   11.41 +    CombVar of name * typ |
   11.42 +    CombApp of combterm * combterm
   11.43 +
   11.44 +  datatype locality = General | Intro | Elim | Simp | Local | Assum | Chained
   11.45 +
   11.46 +  datatype polymorphism = Polymorphic | Monomorphic | Mangled_Monomorphic
   11.47 +  datatype type_level =
   11.48 +    All_Types | Nonmonotonic_Types | Finite_Types | Const_Arg_Types | No_Types
   11.49 +  datatype type_heaviness = Heavy | Light
   11.50 +
   11.51 +  datatype type_sys =
   11.52 +    Simple_Types of type_level |
   11.53 +    Preds of polymorphism * type_level * type_heaviness |
   11.54 +    Tags of polymorphism * type_level * type_heaviness
   11.55 +
   11.56 +  type translated_formula
   11.57 +
   11.58 +  val bound_var_prefix : string
   11.59 +  val schematic_var_prefix: string
   11.60 +  val fixed_var_prefix: string
   11.61 +  val tvar_prefix: string
   11.62 +  val tfree_prefix: string
   11.63 +  val const_prefix: string
   11.64 +  val type_const_prefix: string
   11.65 +  val class_prefix: string
   11.66 +  val skolem_const_prefix : string
   11.67 +  val old_skolem_const_prefix : string
   11.68 +  val new_skolem_const_prefix : string
   11.69 +  val fact_prefix : string
   11.70 +  val conjecture_prefix : string
   11.71 +  val helper_prefix : string
   11.72 +  val typed_helper_suffix : string
   11.73 +  val predicator_name : string
   11.74 +  val app_op_name : string
   11.75 +  val type_tag_name : string
   11.76 +  val type_pred_name : string
   11.77 +  val simple_type_prefix : string
   11.78 +  val ascii_of: string -> string
   11.79 +  val unascii_of: string -> string
   11.80 +  val strip_prefix_and_unascii : string -> string -> string option
   11.81 +  val proxify_const : string -> (int * (string * string)) option
   11.82 +  val invert_const: string -> string
   11.83 +  val unproxify_const: string -> string
   11.84 +  val make_bound_var : string -> string
   11.85 +  val make_schematic_var : string * int -> string
   11.86 +  val make_fixed_var : string -> string
   11.87 +  val make_schematic_type_var : string * int -> string
   11.88 +  val make_fixed_type_var : string -> string
   11.89 +  val make_fixed_const : string -> string
   11.90 +  val make_fixed_type_const : string -> string
   11.91 +  val make_type_class : string -> string
   11.92 +  val new_skolem_var_name_from_const : string -> string
   11.93 +  val num_type_args : theory -> string -> int
   11.94 +  val make_arity_clauses :
   11.95 +    theory -> string list -> class list -> class list * arity_clause list
   11.96 +  val make_class_rel_clauses :
   11.97 +    theory -> class list -> class list -> class_rel_clause list
   11.98 +  val combtyp_of : combterm -> typ
   11.99 +  val strip_combterm_comb : combterm -> combterm * combterm list
  11.100 +  val atyps_of : typ -> typ list
  11.101 +  val combterm_from_term :
  11.102 +    theory -> (string * typ) list -> term -> combterm * typ list
  11.103 +  val is_locality_global : locality -> bool
  11.104 +  val type_sys_from_string : string -> type_sys
  11.105 +  val polymorphism_of_type_sys : type_sys -> polymorphism
  11.106 +  val level_of_type_sys : type_sys -> type_level
  11.107 +  val is_type_sys_virtually_sound : type_sys -> bool
  11.108 +  val is_type_sys_fairly_sound : type_sys -> bool
  11.109 +  val choose_format : format list -> type_sys -> format * type_sys
  11.110 +  val raw_type_literals_for_types : typ list -> type_literal list
  11.111 +  val unmangled_const : string -> string * string fo_term list
  11.112 +  val translate_atp_fact :
  11.113 +    Proof.context -> format -> type_sys -> bool -> (string * locality) * thm
  11.114 +    -> translated_formula option * ((string * locality) * thm)
  11.115 +  val helper_table : (string * (bool * thm list)) list
  11.116 +  val tfree_classes_of_terms : term list -> string list
  11.117 +  val tvar_classes_of_terms : term list -> string list
  11.118 +  val type_consts_of_terms : theory -> term list -> string list
  11.119 +  val prepare_atp_problem :
  11.120 +    Proof.context -> format -> formula_kind -> formula_kind -> type_sys
  11.121 +    -> bool option -> bool -> bool -> term list -> term
  11.122 +    -> (translated_formula option * ((string * 'a) * thm)) list
  11.123 +    -> string problem * string Symtab.table * int * int
  11.124 +       * (string * 'a) list vector * int list * int Symtab.table
  11.125 +  val atp_problem_weights : string problem -> (string * real) list
  11.126 +end;
  11.127 +
  11.128 +structure ATP_Translate : ATP_TRANSLATE =
  11.129 +struct
  11.130 +
  11.131 +open ATP_Util
  11.132 +open ATP_Problem
  11.133 +
  11.134 +type name = string * string
  11.135 +
  11.136 +(* FIXME: avoid *)
  11.137 +fun union_all xss = fold (union (op =)) xss []
  11.138 +
  11.139 +(* experimental *)
  11.140 +val generate_useful_info = false
  11.141 +
  11.142 +fun useful_isabelle_info s =
  11.143 +  if generate_useful_info then
  11.144 +    SOME (ATerm ("[]", [ATerm ("isabelle_" ^ s, [])]))
  11.145 +  else
  11.146 +    NONE
  11.147 +
  11.148 +val intro_info = useful_isabelle_info "intro"
  11.149 +val elim_info = useful_isabelle_info "elim"
  11.150 +val simp_info = useful_isabelle_info "simp"
  11.151 +
  11.152 +val bound_var_prefix = "B_"
  11.153 +val schematic_var_prefix = "V_"
  11.154 +val fixed_var_prefix = "v_"
  11.155 +
  11.156 +val tvar_prefix = "T_"
  11.157 +val tfree_prefix = "t_"
  11.158 +
  11.159 +val const_prefix = "c_"
  11.160 +val type_const_prefix = "tc_"
  11.161 +val class_prefix = "cl_"
  11.162 +
  11.163 +val skolem_const_prefix = "Sledgehammer" ^ Long_Name.separator ^ "Sko"
  11.164 +val old_skolem_const_prefix = skolem_const_prefix ^ "o"
  11.165 +val new_skolem_const_prefix = skolem_const_prefix ^ "n"
  11.166 +
  11.167 +val type_decl_prefix = "ty_"
  11.168 +val sym_decl_prefix = "sy_"
  11.169 +val sym_formula_prefix = "sym_"
  11.170 +val fact_prefix = "fact_"
  11.171 +val conjecture_prefix = "conj_"
  11.172 +val helper_prefix = "help_"
  11.173 +val class_rel_clause_prefix = "crel_"
  11.174 +val arity_clause_prefix = "arity_"
  11.175 +val tfree_clause_prefix = "tfree_"
  11.176 +
  11.177 +val typed_helper_suffix = "_T"
  11.178 +val untyped_helper_suffix = "_U"
  11.179 +
  11.180 +val predicator_name = "hBOOL"
  11.181 +val app_op_name = "hAPP"
  11.182 +val type_tag_name = "ti"
  11.183 +val type_pred_name = "is"
  11.184 +val simple_type_prefix = "ty_"
  11.185 +
  11.186 +(* Freshness almost guaranteed! *)
  11.187 +val sledgehammer_weak_prefix = "Sledgehammer:"
  11.188 +
  11.189 +(*Escaping of special characters.
  11.190 +  Alphanumeric characters are left unchanged.
  11.191 +  The character _ goes to __
  11.192 +  Characters in the range ASCII space to / go to _A to _P, respectively.
  11.193 +  Other characters go to _nnn where nnn is the decimal ASCII code.*)
  11.194 +val upper_a_minus_space = Char.ord #"A" - Char.ord #" "
  11.195 +
  11.196 +fun stringN_of_int 0 _ = ""
  11.197 +  | stringN_of_int k n =
  11.198 +    stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10)
  11.199 +
  11.200 +fun ascii_of_char c =
  11.201 +  if Char.isAlphaNum c then
  11.202 +    String.str c
  11.203 +  else if c = #"_" then
  11.204 +    "__"
  11.205 +  else if #" " <= c andalso c <= #"/" then
  11.206 +    "_" ^ String.str (Char.chr (Char.ord c + upper_a_minus_space))
  11.207 +  else
  11.208 +    (* fixed width, in case more digits follow *)
  11.209 +    "_" ^ stringN_of_int 3 (Char.ord c)
  11.210 +
  11.211 +val ascii_of = String.translate ascii_of_char
  11.212 +
  11.213 +(** Remove ASCII armoring from names in proof files **)
  11.214 +
  11.215 +(* We don't raise error exceptions because this code can run inside a worker
  11.216 +   thread. Also, the errors are impossible. *)
  11.217 +val unascii_of =
  11.218 +  let
  11.219 +    fun un rcs [] = String.implode(rev rcs)
  11.220 +      | un rcs [#"_"] = un (#"_" :: rcs) [] (* ERROR *)
  11.221 +        (* Three types of _ escapes: __, _A to _P, _nnn *)
  11.222 +      | un rcs (#"_" :: #"_" :: cs) = un (#"_"::rcs) cs
  11.223 +      | un rcs (#"_" :: c :: cs) =
  11.224 +        if #"A" <= c andalso c<= #"P" then
  11.225 +          (* translation of #" " to #"/" *)
  11.226 +          un (Char.chr (Char.ord c - upper_a_minus_space) :: rcs) cs
  11.227 +        else
  11.228 +          let val digits = List.take (c::cs, 3) handle Subscript => [] in
  11.229 +            case Int.fromString (String.implode digits) of
  11.230 +              SOME n => un (Char.chr n :: rcs) (List.drop (cs, 2))
  11.231 +            | NONE => un (c:: #"_"::rcs) cs (* ERROR *)
  11.232 +          end
  11.233 +      | un rcs (c :: cs) = un (c :: rcs) cs
  11.234 +  in un [] o String.explode end
  11.235 +
  11.236 +(* If string s has the prefix s1, return the result of deleting it,
  11.237 +   un-ASCII'd. *)
  11.238 +fun strip_prefix_and_unascii s1 s =
  11.239 +  if String.isPrefix s1 s then
  11.240 +    SOME (unascii_of (String.extract (s, size s1, NONE)))
  11.241 +  else
  11.242 +    NONE
  11.243 +
  11.244 +val proxies =
  11.245 +  [("c_False",
  11.246 +    (@{const_name False}, (0, ("fFalse", @{const_name ATP.fFalse})))),
  11.247 +   ("c_True", (@{const_name True}, (0, ("fTrue", @{const_name ATP.fTrue})))),
  11.248 +   ("c_Not", (@{const_name Not}, (1, ("fNot", @{const_name ATP.fNot})))),
  11.249 +   ("c_conj", (@{const_name conj}, (2, ("fconj", @{const_name ATP.fconj})))),
  11.250 +   ("c_disj", (@{const_name disj}, (2, ("fdisj", @{const_name ATP.fdisj})))),
  11.251 +   ("c_implies",
  11.252 +    (@{const_name implies}, (2, ("fimplies", @{const_name ATP.fimplies})))),
  11.253 +   ("equal",
  11.254 +    (@{const_name HOL.eq}, (2, ("fequal", @{const_name ATP.fequal}))))]
  11.255 +
  11.256 +val proxify_const = AList.lookup (op =) proxies #> Option.map snd
  11.257 +
  11.258 +(* Readable names for the more common symbolic functions. Do not mess with the
  11.259 +   table unless you know what you are doing. *)
  11.260 +val const_trans_table =
  11.261 +  [(@{type_name Product_Type.prod}, "prod"),
  11.262 +   (@{type_name Sum_Type.sum}, "sum"),
  11.263 +   (@{const_name False}, "False"),
  11.264 +   (@{const_name True}, "True"),
  11.265 +   (@{const_name Not}, "Not"),
  11.266 +   (@{const_name conj}, "conj"),
  11.267 +   (@{const_name disj}, "disj"),
  11.268 +   (@{const_name implies}, "implies"),
  11.269 +   (@{const_name HOL.eq}, "equal"),
  11.270 +   (@{const_name If}, "If"),
  11.271 +   (@{const_name Set.member}, "member"),
  11.272 +   (@{const_name Meson.COMBI}, "COMBI"),
  11.273 +   (@{const_name Meson.COMBK}, "COMBK"),
  11.274 +   (@{const_name Meson.COMBB}, "COMBB"),
  11.275 +   (@{const_name Meson.COMBC}, "COMBC"),
  11.276 +   (@{const_name Meson.COMBS}, "COMBS")]
  11.277 +  |> Symtab.make
  11.278 +  |> fold (Symtab.update o swap o snd o snd o snd) proxies
  11.279 +
  11.280 +(* Invert the table of translations between Isabelle and ATPs. *)
  11.281 +val const_trans_table_inv =
  11.282 +  const_trans_table |> Symtab.dest |> map swap |> Symtab.make
  11.283 +val const_trans_table_unprox =
  11.284 +  Symtab.empty
  11.285 +  |> fold (fn (_, (isa, (_, (_, metis)))) => Symtab.update (metis, isa)) proxies
  11.286 +
  11.287 +val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
  11.288 +val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox)
  11.289 +
  11.290 +fun lookup_const c =
  11.291 +  case Symtab.lookup const_trans_table c of
  11.292 +    SOME c' => c'
  11.293 +  | NONE => ascii_of c
  11.294 +
  11.295 +(*Remove the initial ' character from a type variable, if it is present*)
  11.296 +fun trim_type_var s =
  11.297 +  if s <> "" andalso String.sub(s,0) = #"'" then String.extract(s,1,NONE)
  11.298 +  else raise Fail ("trim_type: Malformed type variable encountered: " ^ s)
  11.299 +
  11.300 +fun ascii_of_indexname (v,0) = ascii_of v
  11.301 +  | ascii_of_indexname (v,i) = ascii_of v ^ "_" ^ string_of_int i
  11.302 +
  11.303 +fun make_bound_var x = bound_var_prefix ^ ascii_of x
  11.304 +fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
  11.305 +fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
  11.306 +
  11.307 +fun make_schematic_type_var (x,i) =
  11.308 +      tvar_prefix ^ (ascii_of_indexname (trim_type_var x, i))
  11.309 +fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (trim_type_var x))
  11.310 +
  11.311 +(* HOL.eq MUST BE "equal" because it's built into ATPs. *)
  11.312 +fun make_fixed_const @{const_name HOL.eq} = "equal"
  11.313 +  | make_fixed_const c = const_prefix ^ lookup_const c
  11.314 +
  11.315 +fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
  11.316 +
  11.317 +fun make_type_class clas = class_prefix ^ ascii_of clas
  11.318 +
  11.319 +fun new_skolem_var_name_from_const s =
  11.320 +  let val ss = s |> space_explode Long_Name.separator in
  11.321 +    nth ss (length ss - 2)
  11.322 +  end
  11.323 +
  11.324 +(* The number of type arguments of a constant, zero if it's monomorphic. For
  11.325 +   (instances of) Skolem pseudoconstants, this information is encoded in the
  11.326 +   constant name. *)
  11.327 +fun num_type_args thy s =
  11.328 +  if String.isPrefix skolem_const_prefix s then
  11.329 +    s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the
  11.330 +  else
  11.331 +    (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length
  11.332 +
  11.333 +(** Definitions and functions for FOL clauses and formulas for TPTP **)
  11.334 +
  11.335 +(* The first component is the type class; the second is a "TVar" or "TFree". *)
  11.336 +datatype type_literal =
  11.337 +  TyLitVar of name * name |
  11.338 +  TyLitFree of name * name
  11.339 +
  11.340 +
  11.341 +(** Isabelle arities **)
  11.342 +
  11.343 +datatype arity_literal =
  11.344 +  TConsLit of name * name * name list |
  11.345 +  TVarLit of name * name
  11.346 +
  11.347 +fun gen_TVars 0 = []
  11.348 +  | gen_TVars n = ("T_" ^ string_of_int n) :: gen_TVars (n-1)
  11.349 +
  11.350 +fun pack_sort (_,[])  = []
  11.351 +  | pack_sort (tvar, "HOL.type" :: srt) =
  11.352 +    pack_sort (tvar, srt) (* IGNORE sort "type" *)
  11.353 +  | pack_sort (tvar, cls :: srt) =
  11.354 +    (`make_type_class cls, `I tvar) :: pack_sort (tvar, srt)
  11.355 +
  11.356 +type arity_clause =
  11.357 +  {name: string,
  11.358 +   prem_lits: arity_literal list,
  11.359 +   concl_lits: arity_literal}
  11.360 +
  11.361 +(* Arity of type constructor "tcon :: (arg1, ..., argN) res" *)
  11.362 +fun make_axiom_arity_clause (tcons, name, (cls, args)) =
  11.363 +  let
  11.364 +    val tvars = gen_TVars (length args)
  11.365 +    val tvars_srts = ListPair.zip (tvars, args)
  11.366 +  in
  11.367 +    {name = name,
  11.368 +     prem_lits = map TVarLit (union_all (map pack_sort tvars_srts)),
  11.369 +     concl_lits = TConsLit (`make_type_class cls,
  11.370 +                            `make_fixed_type_const tcons,
  11.371 +                            tvars ~~ tvars)}
  11.372 +  end
  11.373 +
  11.374 +fun arity_clause _ _ (_, []) = []
  11.375 +  | arity_clause seen n (tcons, ("HOL.type",_)::ars) =  (*ignore*)
  11.376 +      arity_clause seen n (tcons,ars)
  11.377 +  | arity_clause seen n (tcons, (ar as (class,_)) :: ars) =
  11.378 +      if member (op =) seen class then (*multiple arities for the same tycon, class pair*)
  11.379 +          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class ^ "_" ^ string_of_int n, ar) ::
  11.380 +          arity_clause seen (n+1) (tcons,ars)
  11.381 +      else
  11.382 +          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class, ar) ::
  11.383 +          arity_clause (class::seen) n (tcons,ars)
  11.384 +
  11.385 +fun multi_arity_clause [] = []
  11.386 +  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
  11.387 +      arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
  11.388 +
  11.389 +(*Generate all pairs (tycon,class,sorts) such that tycon belongs to class in theory thy
  11.390 +  provided its arguments have the corresponding sorts.*)
  11.391 +fun type_class_pairs thy tycons classes =
  11.392 +  let
  11.393 +    val alg = Sign.classes_of thy
  11.394 +    fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
  11.395 +    fun add_class tycon class =
  11.396 +      cons (class, domain_sorts tycon class)
  11.397 +      handle Sorts.CLASS_ERROR _ => I
  11.398 +    fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
  11.399 +  in map try_classes tycons end
  11.400 +
  11.401 +(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  11.402 +fun iter_type_class_pairs _ _ [] = ([], [])
  11.403 +  | iter_type_class_pairs thy tycons classes =
  11.404 +      let val cpairs = type_class_pairs thy tycons classes
  11.405 +          val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs)))
  11.406 +            |> subtract (op =) classes |> subtract (op =) HOLogic.typeS
  11.407 +          val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  11.408 +      in (union (op =) classes' classes, union (op =) cpairs' cpairs) end
  11.409 +
  11.410 +fun make_arity_clauses thy tycons =
  11.411 +  iter_type_class_pairs thy tycons ##> multi_arity_clause
  11.412 +
  11.413 +
  11.414 +(** Isabelle class relations **)
  11.415 +
  11.416 +type class_rel_clause =
  11.417 +  {name: string,
  11.418 +   subclass: name,
  11.419 +   superclass: name}
  11.420 +
  11.421 +(*Generate all pairs (sub,super) such that sub is a proper subclass of super in theory thy.*)
  11.422 +fun class_pairs _ [] _ = []
  11.423 +  | class_pairs thy subs supers =
  11.424 +      let
  11.425 +        val class_less = Sorts.class_less (Sign.classes_of thy)
  11.426 +        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
  11.427 +        fun add_supers sub = fold (add_super sub) supers
  11.428 +      in fold add_supers subs [] end
  11.429 +
  11.430 +fun make_class_rel_clause (sub,super) =
  11.431 +  {name = sub ^ "_" ^ super,
  11.432 +   subclass = `make_type_class sub,
  11.433 +   superclass = `make_type_class super}
  11.434 +
  11.435 +fun make_class_rel_clauses thy subs supers =
  11.436 +  map make_class_rel_clause (class_pairs thy subs supers)
  11.437 +
  11.438 +datatype combterm =
  11.439 +  CombConst of name * typ * typ list |
  11.440 +  CombVar of name * typ |
  11.441 +  CombApp of combterm * combterm
  11.442 +
  11.443 +fun combtyp_of (CombConst (_, T, _)) = T
  11.444 +  | combtyp_of (CombVar (_, T)) = T
  11.445 +  | combtyp_of (CombApp (t1, _)) = snd (dest_funT (combtyp_of t1))
  11.446 +
  11.447 +(*gets the head of a combinator application, along with the list of arguments*)
  11.448 +fun strip_combterm_comb u =
  11.449 +    let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
  11.450 +        |   stripc  x =  x
  11.451 +    in stripc(u,[]) end
  11.452 +
  11.453 +fun atyps_of T = fold_atyps (insert (op =)) T []
  11.454 +
  11.455 +fun new_skolem_const_name s num_T_args =
  11.456 +  [new_skolem_const_prefix, s, string_of_int num_T_args]
  11.457 +  |> space_implode Long_Name.separator
  11.458 +
  11.459 +(* Converts a term (with combinators) into a combterm. Also accumulates sort
  11.460 +   infomation. *)
  11.461 +fun combterm_from_term thy bs (P $ Q) =
  11.462 +    let
  11.463 +      val (P', P_atomics_Ts) = combterm_from_term thy bs P
  11.464 +      val (Q', Q_atomics_Ts) = combterm_from_term thy bs Q
  11.465 +    in (CombApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end
  11.466 +  | combterm_from_term thy _ (Const (c, T)) =
  11.467 +    let
  11.468 +      val tvar_list =
  11.469 +        (if String.isPrefix old_skolem_const_prefix c then
  11.470 +           [] |> Term.add_tvarsT T |> map TVar
  11.471 +         else
  11.472 +           (c, T) |> Sign.const_typargs thy)
  11.473 +      val c' = CombConst (`make_fixed_const c, T, tvar_list)
  11.474 +    in (c', atyps_of T) end
  11.475 +  | combterm_from_term _ _ (Free (v, T)) =
  11.476 +    (CombConst (`make_fixed_var v, T, []), atyps_of T)
  11.477 +  | combterm_from_term _ _ (Var (v as (s, _), T)) =
  11.478 +    (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
  11.479 +       let
  11.480 +         val Ts = T |> strip_type |> swap |> op ::
  11.481 +         val s' = new_skolem_const_name s (length Ts)
  11.482 +       in CombConst (`make_fixed_const s', T, Ts) end
  11.483 +     else
  11.484 +       CombVar ((make_schematic_var v, s), T), atyps_of T)
  11.485 +  | combterm_from_term _ bs (Bound j) =
  11.486 +    nth bs j
  11.487 +    |> (fn (s, T) => (CombConst (`make_bound_var s, T, []), atyps_of T))
  11.488 +  | combterm_from_term _ _ (Abs _) = raise Fail "HOL clause: Abs"
  11.489 +
  11.490 +datatype locality = General | Intro | Elim | Simp | Local | Assum | Chained
  11.491 +
  11.492 +(* (quasi-)underapproximation of the truth *)
  11.493 +fun is_locality_global Local = false
  11.494 +  | is_locality_global Assum = false
  11.495 +  | is_locality_global Chained = false
  11.496 +  | is_locality_global _ = true
  11.497 +
  11.498 +datatype polymorphism = Polymorphic | Monomorphic | Mangled_Monomorphic
  11.499 +datatype type_level =
  11.500 +  All_Types | Nonmonotonic_Types | Finite_Types | Const_Arg_Types | No_Types
  11.501 +datatype type_heaviness = Heavy | Light
  11.502 +
  11.503 +datatype type_sys =
  11.504 +  Simple_Types of type_level |
  11.505 +  Preds of polymorphism * type_level * type_heaviness |
  11.506 +  Tags of polymorphism * type_level * type_heaviness
  11.507 +
  11.508 +fun try_unsuffixes ss s =
  11.509 +  fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE
  11.510 +
  11.511 +fun type_sys_from_string s =
  11.512 +  (case try (unprefix "poly_") s of
  11.513 +     SOME s => (SOME Polymorphic, s)
  11.514 +   | NONE =>
  11.515 +     case try (unprefix "mono_") s of
  11.516 +       SOME s => (SOME Monomorphic, s)
  11.517 +     | NONE =>
  11.518 +       case try (unprefix "mangled_") s of
  11.519 +         SOME s => (SOME Mangled_Monomorphic, s)
  11.520 +       | NONE => (NONE, s))
  11.521 +  ||> (fn s =>
  11.522 +          (* "_query" and "_bang" are for the ASCII-challenged Mirabelle. *)
  11.523 +          case try_unsuffixes ["?", "_query"] s of
  11.524 +            SOME s => (Nonmonotonic_Types, s)
  11.525 +          | NONE =>
  11.526 +            case try_unsuffixes ["!", "_bang"] s of
  11.527 +              SOME s => (Finite_Types, s)
  11.528 +            | NONE => (All_Types, s))
  11.529 +  ||> apsnd (fn s =>
  11.530 +                case try (unsuffix "_heavy") s of
  11.531 +                  SOME s => (Heavy, s)
  11.532 +                | NONE => (Light, s))
  11.533 +  |> (fn (poly, (level, (heaviness, core))) =>
  11.534 +         case (core, (poly, level, heaviness)) of
  11.535 +           ("simple", (NONE, _, Light)) => Simple_Types level
  11.536 +         | ("preds", (SOME poly, _, _)) => Preds (poly, level, heaviness)
  11.537 +         | ("tags", (SOME Polymorphic, All_Types, _)) =>
  11.538 +           Tags (Polymorphic, All_Types, heaviness)
  11.539 +         | ("tags", (SOME Polymorphic, _, _)) =>
  11.540 +           (* The actual light encoding is very unsound. *)
  11.541 +           Tags (Polymorphic, level, Heavy)
  11.542 +         | ("tags", (SOME poly, _, _)) => Tags (poly, level, heaviness)
  11.543 +         | ("args", (SOME poly, All_Types (* naja *), Light)) =>
  11.544 +           Preds (poly, Const_Arg_Types, Light)
  11.545 +         | ("erased", (NONE, All_Types (* naja *), Light)) =>
  11.546 +           Preds (Polymorphic, No_Types, Light)
  11.547 +         | _ => raise Same.SAME)
  11.548 +  handle Same.SAME => error ("Unknown type system: " ^ quote s ^ ".")
  11.549 +
  11.550 +fun polymorphism_of_type_sys (Simple_Types _) = Mangled_Monomorphic
  11.551 +  | polymorphism_of_type_sys (Preds (poly, _, _)) = poly
  11.552 +  | polymorphism_of_type_sys (Tags (poly, _, _)) = poly
  11.553 +
  11.554 +fun level_of_type_sys (Simple_Types level) = level
  11.555 +  | level_of_type_sys (Preds (_, level, _)) = level
  11.556 +  | level_of_type_sys (Tags (_, level, _)) = level
  11.557 +
  11.558 +fun heaviness_of_type_sys (Simple_Types _) = Heavy
  11.559 +  | heaviness_of_type_sys (Preds (_, _, heaviness)) = heaviness
  11.560 +  | heaviness_of_type_sys (Tags (_, _, heaviness)) = heaviness
  11.561 +
  11.562 +fun is_type_level_virtually_sound level =
  11.563 +  level = All_Types orelse level = Nonmonotonic_Types
  11.564 +val is_type_sys_virtually_sound =
  11.565 +  is_type_level_virtually_sound o level_of_type_sys
  11.566 +
  11.567 +fun is_type_level_fairly_sound level =
  11.568 +  is_type_level_virtually_sound level orelse level = Finite_Types
  11.569 +val is_type_sys_fairly_sound = is_type_level_fairly_sound o level_of_type_sys
  11.570 +
  11.571 +fun is_setting_higher_order THF (Simple_Types _) = true
  11.572 +  | is_setting_higher_order _ _ = false
  11.573 +
  11.574 +fun choose_format formats (Simple_Types level) =
  11.575 +    if member (op =) formats THF then (THF, Simple_Types level)
  11.576 +    else if member (op =) formats TFF then (TFF, Simple_Types level)
  11.577 +    else choose_format formats (Preds (Mangled_Monomorphic, level, Heavy))
  11.578 +  | choose_format formats type_sys =
  11.579 +    (case hd formats of
  11.580 +       CNF_UEQ =>
  11.581 +       (CNF_UEQ, case type_sys of
  11.582 +                   Preds stuff =>
  11.583 +                   (if is_type_sys_fairly_sound type_sys then Preds else Tags)
  11.584 +                       stuff
  11.585 +                 | _ => type_sys)
  11.586 +     | format => (format, type_sys))
  11.587 +
  11.588 +type translated_formula =
  11.589 +  {name: string,
  11.590 +   locality: locality,
  11.591 +   kind: formula_kind,
  11.592 +   combformula: (name, typ, combterm) formula,
  11.593 +   atomic_types: typ list}
  11.594 +
  11.595 +fun update_combformula f ({name, locality, kind, combformula, atomic_types}
  11.596 +                          : translated_formula) =
  11.597 +  {name = name, locality = locality, kind = kind, combformula = f combformula,
  11.598 +   atomic_types = atomic_types} : translated_formula
  11.599 +
  11.600 +fun fact_lift f ({combformula, ...} : translated_formula) = f combformula
  11.601 +
  11.602 +val type_instance = Sign.typ_instance o Proof_Context.theory_of
  11.603 +
  11.604 +fun insert_type ctxt get_T x xs =
  11.605 +  let val T = get_T x in
  11.606 +    if exists (curry (type_instance ctxt) T o get_T) xs then xs
  11.607 +    else x :: filter_out (curry (type_instance ctxt o swap) T o get_T) xs
  11.608 +  end
  11.609 +
  11.610 +(* The Booleans indicate whether all type arguments should be kept. *)
  11.611 +datatype type_arg_policy =
  11.612 +  Explicit_Type_Args of bool |
  11.613 +  Mangled_Type_Args of bool |
  11.614 +  No_Type_Args
  11.615 +
  11.616 +fun should_drop_arg_type_args (Simple_Types _) =
  11.617 +    false (* since TFF doesn't support overloading *)
  11.618 +  | should_drop_arg_type_args type_sys =
  11.619 +    level_of_type_sys type_sys = All_Types andalso
  11.620 +    heaviness_of_type_sys type_sys = Heavy
  11.621 +
  11.622 +fun general_type_arg_policy (Tags (_, All_Types, Heavy)) = No_Type_Args
  11.623 +  | general_type_arg_policy type_sys =
  11.624 +    if level_of_type_sys type_sys = No_Types then
  11.625 +      No_Type_Args
  11.626 +    else if polymorphism_of_type_sys type_sys = Mangled_Monomorphic then
  11.627 +      Mangled_Type_Args (should_drop_arg_type_args type_sys)
  11.628 +    else
  11.629 +      Explicit_Type_Args (should_drop_arg_type_args type_sys)
  11.630 +
  11.631 +fun type_arg_policy type_sys s =
  11.632 +  if s = @{const_name HOL.eq} orelse
  11.633 +     (s = app_op_name andalso level_of_type_sys type_sys = Const_Arg_Types) then
  11.634 +    No_Type_Args
  11.635 +  else if s = type_tag_name then
  11.636 +    Explicit_Type_Args false
  11.637 +  else
  11.638 +    general_type_arg_policy type_sys
  11.639 +
  11.640 +(*Make literals for sorted type variables*)
  11.641 +fun generic_sorts_on_type (_, []) = []
  11.642 +  | generic_sorts_on_type ((x, i), s :: ss) =
  11.643 +    generic_sorts_on_type ((x, i), ss)
  11.644 +    |> (if s = the_single @{sort HOL.type} then
  11.645 +          I
  11.646 +        else if i = ~1 then
  11.647 +          cons (TyLitFree (`make_type_class s, `make_fixed_type_var x))
  11.648 +        else
  11.649 +          cons (TyLitVar (`make_type_class s,
  11.650 +                          (make_schematic_type_var (x, i), x))))
  11.651 +fun sorts_on_tfree (TFree (s, S)) = generic_sorts_on_type ((s, ~1), S)
  11.652 +  | sorts_on_tfree _ = []
  11.653 +fun sorts_on_tvar (TVar z) = generic_sorts_on_type z
  11.654 +  | sorts_on_tvar _ = []
  11.655 +
  11.656 +(* Given a list of sorted type variables, return a list of type literals. *)
  11.657 +fun raw_type_literals_for_types Ts =
  11.658 +  union_all (map sorts_on_tfree Ts @ map sorts_on_tvar Ts)
  11.659 +
  11.660 +fun type_literals_for_types type_sys sorts_on_typ Ts =
  11.661 +  if level_of_type_sys type_sys = No_Types then []
  11.662 +  else union_all (map sorts_on_typ Ts)
  11.663 +
  11.664 +fun mk_aconns c phis =
  11.665 +  let val (phis', phi') = split_last phis in
  11.666 +    fold_rev (mk_aconn c) phis' phi'
  11.667 +  end
  11.668 +fun mk_ahorn [] phi = phi
  11.669 +  | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi])
  11.670 +fun mk_aquant _ [] phi = phi
  11.671 +  | mk_aquant q xs (phi as AQuant (q', xs', phi')) =
  11.672 +    if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi)
  11.673 +  | mk_aquant q xs phi = AQuant (q, xs, phi)
  11.674 +
  11.675 +fun close_universally atom_vars phi =
  11.676 +  let
  11.677 +    fun formula_vars bounds (AQuant (_, xs, phi)) =
  11.678 +        formula_vars (map fst xs @ bounds) phi
  11.679 +      | formula_vars bounds (AConn (_, phis)) = fold (formula_vars bounds) phis
  11.680 +      | formula_vars bounds (AAtom tm) =
  11.681 +        union (op =) (atom_vars tm []
  11.682 +                      |> filter_out (member (op =) bounds o fst))
  11.683 +  in mk_aquant AForall (formula_vars [] phi []) phi end
  11.684 +
  11.685 +fun combterm_vars (CombApp (tm1, tm2)) = fold combterm_vars [tm1, tm2]
  11.686 +  | combterm_vars (CombConst _) = I
  11.687 +  | combterm_vars (CombVar (name, T)) = insert (op =) (name, SOME T)
  11.688 +fun close_combformula_universally phi = close_universally combterm_vars phi
  11.689 +
  11.690 +fun term_vars (ATerm (name as (s, _), tms)) =
  11.691 +  is_tptp_variable s ? insert (op =) (name, NONE) #> fold term_vars tms
  11.692 +fun close_formula_universally phi = close_universally term_vars phi
  11.693 +
  11.694 +val homo_infinite_type_name = @{type_name ind} (* any infinite type *)
  11.695 +val homo_infinite_type = Type (homo_infinite_type_name, [])
  11.696 +
  11.697 +fun fo_term_from_typ higher_order =
  11.698 +  let
  11.699 +    fun term (Type (s, Ts)) =
  11.700 +      ATerm (case (higher_order, s) of
  11.701 +               (true, @{type_name bool}) => `I tptp_bool_type
  11.702 +             | (true, @{type_name fun}) => `I tptp_fun_type
  11.703 +             | _ => if s = homo_infinite_type_name then `I tptp_individual_type
  11.704 +                    else `make_fixed_type_const s,
  11.705 +             map term Ts)
  11.706 +    | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, [])
  11.707 +    | term (TVar ((x as (s, _)), _)) =
  11.708 +      ATerm ((make_schematic_type_var x, s), [])
  11.709 +  in term end
  11.710 +
  11.711 +(* This shouldn't clash with anything else. *)
  11.712 +val mangled_type_sep = "\000"
  11.713 +
  11.714 +fun generic_mangled_type_name f (ATerm (name, [])) = f name
  11.715 +  | generic_mangled_type_name f (ATerm (name, tys)) =
  11.716 +    f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys)
  11.717 +    ^ ")"
  11.718 +
  11.719 +val bool_atype = AType (`I tptp_bool_type)
  11.720 +
  11.721 +fun make_simple_type s =
  11.722 +  if s = tptp_bool_type orelse s = tptp_fun_type orelse
  11.723 +     s = tptp_individual_type then
  11.724 +    s
  11.725 +  else
  11.726 +    simple_type_prefix ^ ascii_of s
  11.727 +
  11.728 +fun ho_type_from_fo_term higher_order pred_sym ary =
  11.729 +  let
  11.730 +    fun to_atype ty =
  11.731 +      AType ((make_simple_type (generic_mangled_type_name fst ty),
  11.732 +              generic_mangled_type_name snd ty))
  11.733 +    fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1))
  11.734 +    fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty
  11.735 +      | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys
  11.736 +    fun to_ho (ty as ATerm ((s, _), tys)) =
  11.737 +      if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty
  11.738 +  in if higher_order then to_ho else to_fo ary end
  11.739 +
  11.740 +fun mangled_type higher_order pred_sym ary =
  11.741 +  ho_type_from_fo_term higher_order pred_sym ary o fo_term_from_typ higher_order
  11.742 +
  11.743 +fun mangled_const_name T_args (s, s') =
  11.744 +  let
  11.745 +    val ty_args = map (fo_term_from_typ false) T_args
  11.746 +    fun type_suffix f g =
  11.747 +      fold_rev (curry (op ^) o g o prefix mangled_type_sep
  11.748 +                o generic_mangled_type_name f) ty_args ""
  11.749 +  in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end
  11.750 +
  11.751 +val parse_mangled_ident =
  11.752 +  Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode
  11.753 +
  11.754 +fun parse_mangled_type x =
  11.755 +  (parse_mangled_ident
  11.756 +   -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")")
  11.757 +                    [] >> ATerm) x
  11.758 +and parse_mangled_types x =
  11.759 +  (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x
  11.760 +
  11.761 +fun unmangled_type s =
  11.762 +  s |> suffix ")" |> raw_explode
  11.763 +    |> Scan.finite Symbol.stopper
  11.764 +           (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^
  11.765 +                                                quote s)) parse_mangled_type))
  11.766 +    |> fst
  11.767 +
  11.768 +val unmangled_const_name = space_explode mangled_type_sep #> hd
  11.769 +fun unmangled_const s =
  11.770 +  let val ss = space_explode mangled_type_sep s in
  11.771 +    (hd ss, map unmangled_type (tl ss))
  11.772 +  end
  11.773 +
  11.774 +fun introduce_proxies format type_sys =
  11.775 +  let
  11.776 +    fun intro top_level (CombApp (tm1, tm2)) =
  11.777 +        CombApp (intro top_level tm1, intro false tm2)
  11.778 +      | intro top_level (CombConst (name as (s, _), T, T_args)) =
  11.779 +        (case proxify_const s of
  11.780 +           SOME (_, proxy_base) =>
  11.781 +           if top_level orelse is_setting_higher_order format type_sys then
  11.782 +             case (top_level, s) of
  11.783 +               (_, "c_False") => (`I tptp_false, [])
  11.784 +             | (_, "c_True") => (`I tptp_true, [])
  11.785 +             | (false, "c_Not") => (`I tptp_not, [])
  11.786 +             | (false, "c_conj") => (`I tptp_and, [])
  11.787 +             | (false, "c_disj") => (`I tptp_or, [])
  11.788 +             | (false, "c_implies") => (`I tptp_implies, [])
  11.789 +             | (false, s) =>
  11.790 +               if is_tptp_equal s then (`I tptp_equal, [])
  11.791 +               else (proxy_base |>> prefix const_prefix, T_args)
  11.792 +             | _ => (name, [])
  11.793 +           else
  11.794 +             (proxy_base |>> prefix const_prefix, T_args)
  11.795 +          | NONE => (name, T_args))
  11.796 +        |> (fn (name, T_args) => CombConst (name, T, T_args))
  11.797 +      | intro _ tm = tm
  11.798 +  in intro true end
  11.799 +
  11.800 +fun combformula_from_prop thy format type_sys eq_as_iff =
  11.801 +  let
  11.802 +    fun do_term bs t atomic_types =
  11.803 +      combterm_from_term thy bs (Envir.eta_contract t)
  11.804 +      |>> (introduce_proxies format type_sys #> AAtom)
  11.805 +      ||> union (op =) atomic_types
  11.806 +    fun do_quant bs q s T t' =
  11.807 +      let val s = Name.variant (map fst bs) s in
  11.808 +        do_formula ((s, T) :: bs) t'
  11.809 +        #>> mk_aquant q [(`make_bound_var s, SOME T)]
  11.810 +      end
  11.811 +    and do_conn bs c t1 t2 =
  11.812 +      do_formula bs t1 ##>> do_formula bs t2
  11.813 +      #>> uncurry (mk_aconn c)
  11.814 +    and do_formula bs t =
  11.815 +      case t of
  11.816 +        @{const Trueprop} $ t1 => do_formula bs t1
  11.817 +      | @{const Not} $ t1 => do_formula bs t1 #>> mk_anot
  11.818 +      | Const (@{const_name All}, _) $ Abs (s, T, t') =>
  11.819 +        do_quant bs AForall s T t'
  11.820 +      | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
  11.821 +        do_quant bs AExists s T t'
  11.822 +      | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd t1 t2
  11.823 +      | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr t1 t2
  11.824 +      | @{const HOL.implies} $ t1 $ t2 => do_conn bs AImplies t1 t2
  11.825 +      | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 =>
  11.826 +        if eq_as_iff then do_conn bs AIff t1 t2 else do_term bs t
  11.827 +      | _ => do_term bs t
  11.828 +  in do_formula [] end
  11.829 +
  11.830 +fun presimplify_term ctxt =
  11.831 +  Skip_Proof.make_thm (Proof_Context.theory_of ctxt)
  11.832 +  #> Meson.presimplify ctxt
  11.833 +  #> prop_of
  11.834 +
  11.835 +fun concealed_bound_name j = sledgehammer_weak_prefix ^ string_of_int j
  11.836 +fun conceal_bounds Ts t =
  11.837 +  subst_bounds (map (Free o apfst concealed_bound_name)
  11.838 +                    (0 upto length Ts - 1 ~~ Ts), t)
  11.839 +fun reveal_bounds Ts =
  11.840 +  subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j))
  11.841 +                    (0 upto length Ts - 1 ~~ Ts))
  11.842 +
  11.843 +fun extensionalize_term ctxt t =
  11.844 +  let val thy = Proof_Context.theory_of ctxt in
  11.845 +    t |> cterm_of thy |> Meson.extensionalize_conv ctxt
  11.846 +      |> prop_of |> Logic.dest_equals |> snd
  11.847 +  end
  11.848 +
  11.849 +fun introduce_combinators_in_term ctxt kind t =
  11.850 +  let val thy = Proof_Context.theory_of ctxt in
  11.851 +    if Meson.is_fol_term thy t then
  11.852 +      t
  11.853 +    else
  11.854 +      let
  11.855 +        fun aux Ts t =
  11.856 +          case t of
  11.857 +            @{const Not} $ t1 => @{const Not} $ aux Ts t1
  11.858 +          | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') =>
  11.859 +            t0 $ Abs (s, T, aux (T :: Ts) t')
  11.860 +          | (t0 as Const (@{const_name All}, _)) $ t1 =>
  11.861 +            aux Ts (t0 $ eta_expand Ts t1 1)
  11.862 +          | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') =>
  11.863 +            t0 $ Abs (s, T, aux (T :: Ts) t')
  11.864 +          | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
  11.865 +            aux Ts (t0 $ eta_expand Ts t1 1)
  11.866 +          | (t0 as @{const HOL.conj}) $ t1 $ t2 => t0 $ aux Ts t1 $ aux Ts t2
  11.867 +          | (t0 as @{const HOL.disj}) $ t1 $ t2 => t0 $ aux Ts t1 $ aux Ts t2
  11.868 +          | (t0 as @{const HOL.implies}) $ t1 $ t2 => t0 $ aux Ts t1 $ aux Ts t2
  11.869 +          | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])))
  11.870 +              $ t1 $ t2 =>
  11.871 +            t0 $ aux Ts t1 $ aux Ts t2
  11.872 +          | _ => if not (exists_subterm (fn Abs _ => true | _ => false) t) then
  11.873 +                   t
  11.874 +                 else
  11.875 +                   t |> conceal_bounds Ts
  11.876 +                     |> Envir.eta_contract
  11.877 +                     |> cterm_of thy
  11.878 +                     |> Meson_Clausify.introduce_combinators_in_cterm
  11.879 +                     |> prop_of |> Logic.dest_equals |> snd
  11.880 +                     |> reveal_bounds Ts
  11.881 +        val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single
  11.882 +      in t |> aux [] |> singleton (Variable.export_terms ctxt' ctxt) end
  11.883 +      handle THM _ =>
  11.884 +             (* A type variable of sort "{}" will make abstraction fail. *)
  11.885 +             if kind = Conjecture then HOLogic.false_const
  11.886 +             else HOLogic.true_const
  11.887 +  end
  11.888 +
  11.889 +(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the
  11.890 +   same in Sledgehammer to prevent the discovery of unreplayable proofs. *)
  11.891 +fun freeze_term t =
  11.892 +  let
  11.893 +    fun aux (t $ u) = aux t $ aux u
  11.894 +      | aux (Abs (s, T, t)) = Abs (s, T, aux t)
  11.895 +      | aux (Var ((s, i), T)) =
  11.896 +        Free (sledgehammer_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
  11.897 +      | aux t = t
  11.898 +  in t |> exists_subterm is_Var t ? aux end
  11.899 +
  11.900 +fun preprocess_prop ctxt presimp kind t =
  11.901 +  let
  11.902 +    val thy = Proof_Context.theory_of ctxt
  11.903 +    val t = t |> Envir.beta_eta_contract
  11.904 +              |> transform_elim_prop
  11.905 +              |> Object_Logic.atomize_term thy
  11.906 +    val need_trueprop = (fastype_of t = @{typ bool})
  11.907 +  in
  11.908 +    t |> need_trueprop ? HOLogic.mk_Trueprop
  11.909 +      |> Raw_Simplifier.rewrite_term thy (Meson.unfold_set_const_simps ctxt) []
  11.910 +      |> extensionalize_term ctxt
  11.911 +      |> presimp ? presimplify_term ctxt
  11.912 +      |> introduce_combinators_in_term ctxt kind
  11.913 +  end
  11.914 +
  11.915 +(* making fact and conjecture formulas *)
  11.916 +fun make_formula thy format type_sys eq_as_iff name loc kind t =
  11.917 +  let
  11.918 +    val (combformula, atomic_types) =
  11.919 +      combformula_from_prop thy format type_sys eq_as_iff t []
  11.920 +  in
  11.921 +    {name = name, locality = loc, kind = kind, combformula = combformula,
  11.922 +     atomic_types = atomic_types}
  11.923 +  end
  11.924 +
  11.925 +fun make_fact ctxt format type_sys keep_trivial eq_as_iff preproc presimp
  11.926 +              ((name, loc), t) =
  11.927 +  let val thy = Proof_Context.theory_of ctxt in
  11.928 +    case (keep_trivial,
  11.929 +          t |> preproc ? preprocess_prop ctxt presimp Axiom
  11.930 +            |> make_formula thy format type_sys eq_as_iff name loc Axiom) of
  11.931 +      (false,
  11.932 +       formula as {combformula = AAtom (CombConst ((s, _), _, _)), ...}) =>
  11.933 +      if s = tptp_true then NONE else SOME formula
  11.934 +    | (_, formula) => SOME formula
  11.935 +  end
  11.936 +
  11.937 +fun make_conjecture ctxt format prem_kind type_sys preproc ts =
  11.938 +  let
  11.939 +    val thy = Proof_Context.theory_of ctxt
  11.940 +    val last = length ts - 1
  11.941 +  in
  11.942 +    map2 (fn j => fn t =>
  11.943 +             let
  11.944 +               val (kind, maybe_negate) =
  11.945 +                 if j = last then
  11.946 +                   (Conjecture, I)
  11.947 +                 else
  11.948 +                   (prem_kind,
  11.949 +                    if prem_kind = Conjecture then update_combformula mk_anot
  11.950 +                    else I)
  11.951 +              in
  11.952 +                t |> preproc ? (preprocess_prop ctxt true kind #> freeze_term)
  11.953 +                  |> make_formula thy format type_sys true (string_of_int j)
  11.954 +                                  General kind
  11.955 +                  |> maybe_negate
  11.956 +              end)
  11.957 +         (0 upto last) ts
  11.958 +  end
  11.959 +
  11.960 +(** Finite and infinite type inference **)
  11.961 +
  11.962 +fun deep_freeze_atyp (TVar (_, S)) = TFree ("v", S)
  11.963 +  | deep_freeze_atyp T = T
  11.964 +val deep_freeze_type = map_atyps deep_freeze_atyp
  11.965 +
  11.966 +(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are
  11.967 +   dangerous because their "exhaust" properties can easily lead to unsound ATP
  11.968 +   proofs. On the other hand, all HOL infinite types can be given the same
  11.969 +   models in first-order logic (via Löwenheim-Skolem). *)
  11.970 +
  11.971 +fun should_encode_type ctxt (nonmono_Ts as _ :: _) _ T =
  11.972 +    exists (curry (type_instance ctxt) (deep_freeze_type T)) nonmono_Ts
  11.973 +  | should_encode_type _ _ All_Types _ = true
  11.974 +  | should_encode_type ctxt _ Finite_Types T = is_type_surely_finite ctxt T
  11.975 +  | should_encode_type _ _ _ _ = false
  11.976 +
  11.977 +fun should_predicate_on_type ctxt nonmono_Ts (Preds (_, level, heaviness))
  11.978 +                             should_predicate_on_var T =
  11.979 +    (heaviness = Heavy orelse should_predicate_on_var ()) andalso
  11.980 +    should_encode_type ctxt nonmono_Ts level T
  11.981 +  | should_predicate_on_type _ _ _ _ _ = false
  11.982 +
  11.983 +fun is_var_or_bound_var (CombConst ((s, _), _, _)) =
  11.984 +    String.isPrefix bound_var_prefix s
  11.985 +  | is_var_or_bound_var (CombVar _) = true
  11.986 +  | is_var_or_bound_var _ = false
  11.987 +
  11.988 +datatype tag_site = Top_Level | Eq_Arg | Elsewhere
  11.989 +
  11.990 +fun should_tag_with_type _ _ _ Top_Level _ _ = false
  11.991 +  | should_tag_with_type ctxt nonmono_Ts (Tags (_, level, heaviness)) site u T =
  11.992 +    (case heaviness of
  11.993 +       Heavy => should_encode_type ctxt nonmono_Ts level T
  11.994 +     | Light =>
  11.995 +       case (site, is_var_or_bound_var u) of
  11.996 +         (Eq_Arg, true) => should_encode_type ctxt nonmono_Ts level T
  11.997 +       | _ => false)
  11.998 +  | should_tag_with_type _ _ _ _ _ _ = false
  11.999 +
 11.1000 +fun homogenized_type ctxt nonmono_Ts level =
 11.1001 +  let
 11.1002 +    val should_encode = should_encode_type ctxt nonmono_Ts level
 11.1003 +    fun homo 0 T = if should_encode T then T else homo_infinite_type
 11.1004 +      | homo ary (Type (@{type_name fun}, [T1, T2])) =
 11.1005 +        homo 0 T1 --> homo (ary - 1) T2
 11.1006 +      | homo _ _ = raise Fail "expected function type"
 11.1007 +  in homo end
 11.1008 +
 11.1009 +(** "hBOOL" and "hAPP" **)
 11.1010 +
 11.1011 +type sym_info =
 11.1012 +  {pred_sym : bool, min_ary : int, max_ary : int, types : typ list}
 11.1013 +
 11.1014 +fun add_combterm_syms_to_table ctxt explicit_apply =
 11.1015 +  let
 11.1016 +    fun consider_var_arity const_T var_T max_ary =
 11.1017 +      let
 11.1018 +        fun iter ary T =
 11.1019 +          if ary = max_ary orelse type_instance ctxt (var_T, T) then ary
 11.1020 +          else iter (ary + 1) (range_type T)
 11.1021 +      in iter 0 const_T end
 11.1022 +    fun add top_level tm (accum as (ho_var_Ts, sym_tab)) =
 11.1023 +      let val (head, args) = strip_combterm_comb tm in
 11.1024 +        (case head of
 11.1025 +           CombConst ((s, _), T, _) =>
 11.1026 +           if String.isPrefix bound_var_prefix s then
 11.1027 +             if explicit_apply = NONE andalso can dest_funT T then
 11.1028 +               let
 11.1029 +                 fun repair_min_arity {pred_sym, min_ary, max_ary, types} =
 11.1030 +                   {pred_sym = pred_sym,
 11.1031 +                    min_ary =
 11.1032 +                      fold (fn T' => consider_var_arity T' T) types min_ary,
 11.1033 +                    max_ary = max_ary, types = types}
 11.1034 +                 val ho_var_Ts' = ho_var_Ts |> insert_type ctxt I T
 11.1035 +               in
 11.1036 +                 if pointer_eq (ho_var_Ts', ho_var_Ts) then accum
 11.1037 +                 else (ho_var_Ts', Symtab.map (K repair_min_arity) sym_tab)
 11.1038 +               end
 11.1039 +             else
 11.1040 +               accum
 11.1041 +           else
 11.1042 +             let
 11.1043 +               val ary = length args
 11.1044 +             in
 11.1045 +               (ho_var_Ts,
 11.1046 +                case Symtab.lookup sym_tab s of
 11.1047 +                  SOME {pred_sym, min_ary, max_ary, types} =>
 11.1048 +                  let
 11.1049 +                    val types' = types |> insert_type ctxt I T
 11.1050 +                    val min_ary =
 11.1051 +                      if is_some explicit_apply orelse
 11.1052 +                         pointer_eq (types', types) then
 11.1053 +                        min_ary
 11.1054 +                      else
 11.1055 +                        fold (consider_var_arity T) ho_var_Ts min_ary
 11.1056 +                  in
 11.1057 +                    Symtab.update (s, {pred_sym = pred_sym andalso top_level,
 11.1058 +                                       min_ary = Int.min (ary, min_ary),
 11.1059 +                                       max_ary = Int.max (ary, max_ary),
 11.1060 +                                       types = types'})
 11.1061 +                                  sym_tab
 11.1062 +                  end
 11.1063 +                | NONE =>
 11.1064 +                  let
 11.1065 +                    val min_ary =
 11.1066 +                      case explicit_apply of
 11.1067 +                        SOME true => 0
 11.1068 +                      | SOME false => ary
 11.1069 +                      | NONE => fold (consider_var_arity T) ho_var_Ts ary
 11.1070 +                  in
 11.1071 +                    Symtab.update_new (s, {pred_sym = top_level,
 11.1072 +                                           min_ary = min_ary, max_ary = ary,
 11.1073 +                                           types = [T]})
 11.1074 +                                      sym_tab
 11.1075 +                  end)
 11.1076 +             end
 11.1077 +         | _ => accum)
 11.1078 +        |> fold (add false) args
 11.1079 +      end
 11.1080 +  in add true end
 11.1081 +fun add_fact_syms_to_table ctxt explicit_apply =
 11.1082 +  fact_lift (formula_fold NONE
 11.1083 +                          (K (add_combterm_syms_to_table ctxt explicit_apply)))
 11.1084 +
 11.1085 +val default_sym_table_entries : (string * sym_info) list =
 11.1086 +  [(tptp_equal, {pred_sym = true, min_ary = 2, max_ary = 2, types = []}),
 11.1087 +   (tptp_old_equal, {pred_sym = true, min_ary = 2, max_ary = 2, types = []}),
 11.1088 +   (make_fixed_const predicator_name,
 11.1089 +    {pred_sym = true, min_ary = 1, max_ary = 1, types = []})] @
 11.1090 +  ([tptp_false, tptp_true]
 11.1091 +   |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = []}))
 11.1092 +
 11.1093 +fun sym_table_for_facts ctxt explicit_apply facts =
 11.1094 +  Symtab.empty
 11.1095 +  |> fold Symtab.default default_sym_table_entries
 11.1096 +  |> pair [] |> fold (add_fact_syms_to_table ctxt explicit_apply) facts |> snd
 11.1097 +
 11.1098 +fun min_arity_of sym_tab s =
 11.1099 +  case Symtab.lookup sym_tab s of
 11.1100 +    SOME ({min_ary, ...} : sym_info) => min_ary
 11.1101 +  | NONE =>
 11.1102 +    case strip_prefix_and_unascii const_prefix s of
 11.1103 +      SOME s =>
 11.1104 +      let val s = s |> unmangled_const_name |> invert_const in
 11.1105 +        if s = predicator_name then 1
 11.1106 +        else if s = app_op_name then 2
 11.1107 +        else if s = type_pred_name then 1
 11.1108 +        else 0
 11.1109 +      end
 11.1110 +    | NONE => 0
 11.1111 +
 11.1112 +(* True if the constant ever appears outside of the top-level position in
 11.1113 +   literals, or if it appears with different arities (e.g., because of different
 11.1114 +   type instantiations). If false, the constant always receives all of its
 11.1115 +   arguments and is used as a predicate. *)
 11.1116 +fun is_pred_sym sym_tab s =
 11.1117 +  case Symtab.lookup sym_tab s of
 11.1118 +    SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) =>
 11.1119 +    pred_sym andalso min_ary = max_ary
 11.1120 +  | NONE => false
 11.1121 +
 11.1122 +val predicator_combconst =
 11.1123 +  CombConst (`make_fixed_const predicator_name, @{typ "bool => bool"}, [])
 11.1124 +fun predicator tm = CombApp (predicator_combconst, tm)
 11.1125 +
 11.1126 +fun introduce_predicators_in_combterm sym_tab tm =
 11.1127 +  case strip_combterm_comb tm of
 11.1128 +    (CombConst ((s, _), _, _), _) =>
 11.1129 +    if is_pred_sym sym_tab s then tm else predicator tm
 11.1130 +  | _ => predicator tm
 11.1131 +
 11.1132 +fun list_app head args = fold (curry (CombApp o swap)) args head
 11.1133 +
 11.1134 +fun explicit_app arg head =
 11.1135 +  let
 11.1136 +    val head_T = combtyp_of head
 11.1137 +    val (arg_T, res_T) = dest_funT head_T
 11.1138 +    val explicit_app =
 11.1139 +      CombConst (`make_fixed_const app_op_name, head_T --> head_T,
 11.1140 +                 [arg_T, res_T])
 11.1141 +  in list_app explicit_app [head, arg] end
 11.1142 +fun list_explicit_app head args = fold explicit_app args head
 11.1143 +
 11.1144 +fun introduce_explicit_apps_in_combterm sym_tab =
 11.1145 +  let
 11.1146 +    fun aux tm =
 11.1147 +      case strip_combterm_comb tm of
 11.1148 +        (head as CombConst ((s, _), _, _), args) =>
 11.1149 +        args |> map aux
 11.1150 +             |> chop (min_arity_of sym_tab s)
 11.1151 +             |>> list_app head
 11.1152 +             |-> list_explicit_app
 11.1153 +      | (head, args) => list_explicit_app head (map aux args)
 11.1154 +  in aux end
 11.1155 +
 11.1156 +fun chop_fun 0 T = ([], T)
 11.1157 +  | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) =
 11.1158 +    chop_fun (n - 1) ran_T |>> cons dom_T
 11.1159 +  | chop_fun _ _ = raise Fail "unexpected non-function"
 11.1160 +
 11.1161 +fun filter_type_args _ _ _ [] = []
 11.1162 +  | filter_type_args thy s arity T_args =
 11.1163 +    let
 11.1164 +      (* will throw "TYPE" for pseudo-constants *)
 11.1165 +      val U = if s = app_op_name then
 11.1166 +                @{typ "('a => 'b) => 'a => 'b"} |> Logic.varifyT_global
 11.1167 +              else
 11.1168 +                s |> Sign.the_const_type thy
 11.1169 +    in
 11.1170 +      case Term.add_tvarsT (U |> chop_fun arity |> snd) [] of
 11.1171 +        [] => []
 11.1172 +      | res_U_vars =>
 11.1173 +        let val U_args = (s, U) |> Sign.const_typargs thy in
 11.1174 +          U_args ~~ T_args
 11.1175 +          |> map_filter (fn (U, T) =>
 11.1176 +                            if member (op =) res_U_vars (dest_TVar U) then
 11.1177 +                              SOME T
 11.1178 +                            else
 11.1179 +                              NONE)
 11.1180 +        end
 11.1181 +    end
 11.1182 +    handle TYPE _ => T_args
 11.1183 +
 11.1184 +fun enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys =
 11.1185 +  let
 11.1186 +    val thy = Proof_Context.theory_of ctxt
 11.1187 +    fun aux arity (CombApp (tm1, tm2)) =
 11.1188 +        CombApp (aux (arity + 1) tm1, aux 0 tm2)
 11.1189 +      | aux arity (CombConst (name as (s, _), T, T_args)) =
 11.1190 +        let
 11.1191 +          val level = level_of_type_sys type_sys
 11.1192 +          val (T, T_args) =
 11.1193 +            (* Aggressively merge most "hAPPs" if the type system is unsound
 11.1194 +               anyway, by distinguishing overloads only on the homogenized
 11.1195 +               result type. Don't do it for lightweight type systems, though,
 11.1196 +               since it leads to too many unsound proofs. *)
 11.1197 +            if s = const_prefix ^ app_op_name andalso
 11.1198 +               length T_args = 2 andalso
 11.1199 +               not (is_type_sys_virtually_sound type_sys) andalso
 11.1200 +               heaviness_of_type_sys type_sys = Heavy then
 11.1201 +              T_args |> map (homogenized_type ctxt nonmono_Ts level 0)
 11.1202 +                     |> (fn Ts => let val T = hd Ts --> nth Ts 1 in
 11.1203 +                                    (T --> T, tl Ts)
 11.1204 +                                  end)
 11.1205 +            else
 11.1206 +              (T, T_args)
 11.1207 +        in
 11.1208 +          (case strip_prefix_and_unascii const_prefix s of
 11.1209 +             NONE => (name, T_args)
 11.1210 +           | SOME s'' =>
 11.1211 +             let
 11.1212 +               val s'' = invert_const s''
 11.1213 +               fun filtered_T_args false = T_args
 11.1214 +                 | filtered_T_args true = filter_type_args thy s'' arity T_args
 11.1215 +             in
 11.1216 +               case type_arg_policy type_sys s'' of
 11.1217 +                 Explicit_Type_Args drop_args =>
 11.1218 +                 (name, filtered_T_args drop_args)
 11.1219 +               | Mangled_Type_Args drop_args =>
 11.1220 +                 (mangled_const_name (filtered_T_args drop_args) name, [])
 11.1221 +               | No_Type_Args => (name, [])
 11.1222 +             end)
 11.1223 +          |> (fn (name, T_args) => CombConst (name, T, T_args))
 11.1224 +        end
 11.1225 +      | aux _ tm = tm
 11.1226 +  in aux 0 end
 11.1227 +
 11.1228 +fun repair_combterm ctxt format nonmono_Ts type_sys sym_tab =
 11.1229 +  not (is_setting_higher_order format type_sys)
 11.1230 +  ? (introduce_explicit_apps_in_combterm sym_tab
 11.1231 +     #> introduce_predicators_in_combterm sym_tab)
 11.1232 +  #> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys
 11.1233 +fun repair_fact ctxt format nonmono_Ts type_sys sym_tab =
 11.1234 +  update_combformula (formula_map
 11.1235 +      (repair_combterm ctxt format nonmono_Ts type_sys sym_tab))
 11.1236 +
 11.1237 +(** Helper facts **)
 11.1238 +
 11.1239 +(* The Boolean indicates that a fairly sound type encoding is needed. *)
 11.1240 +val helper_table =
 11.1241 +  [("COMBI", (false, @{thms Meson.COMBI_def})),
 11.1242 +   ("COMBK", (false, @{thms Meson.COMBK_def})),
 11.1243 +   ("COMBB", (false, @{thms Meson.COMBB_def})),
 11.1244 +   ("COMBC", (false, @{thms Meson.COMBC_def})),
 11.1245 +   ("COMBS", (false, @{thms Meson.COMBS_def})),
 11.1246 +   ("fequal",
 11.1247 +    (* This is a lie: Higher-order equality doesn't need a sound type encoding.
 11.1248 +       However, this is done so for backward compatibility: Including the
 11.1249 +       equality helpers by default in Metis breaks a few existing proofs. *)
 11.1250 +    (true, @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1]
 11.1251 +                  fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]})),
 11.1252 +   ("fFalse", (true, @{thms True_or_False})),
 11.1253 +   ("fFalse", (false, [@{lemma "~ fFalse" by (unfold fFalse_def) fast}])),
 11.1254 +   ("fTrue", (true, @{thms True_or_False})),
 11.1255 +   ("fTrue", (false, [@{lemma "fTrue" by (unfold fTrue_def) fast}])),
 11.1256 +   ("fNot",
 11.1257 +    (false, @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1]
 11.1258 +                   fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]})),
 11.1259 +   ("fconj",
 11.1260 +    (false,
 11.1261 +     @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q"
 11.1262 +         by (unfold fconj_def) fast+})),
 11.1263 +   ("fdisj",
 11.1264 +    (false,
 11.1265 +     @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q"
 11.1266 +         by (unfold fdisj_def) fast+})),
 11.1267 +   ("fimplies",
 11.1268 +    (false, @{lemma "P | fimplies P Q" "~ Q | fimplies P Q"
 11.1269 +                    "~ fimplies P Q | ~ P | Q"
 11.1270 +                by (unfold fimplies_def) fast+})),
 11.1271 +   ("If", (true, @{thms if_True if_False True_or_False}))]
 11.1272 +
 11.1273 +fun ti_ti_helper_fact () =
 11.1274 +  let
 11.1275 +    fun var s = ATerm (`I s, [])
 11.1276 +    fun tag tm = ATerm (`make_fixed_const type_tag_name, [var "X", tm])
 11.1277 +  in
 11.1278 +    Formula (helper_prefix ^ "ti_ti", Axiom,
 11.1279 +             AAtom (ATerm (`I tptp_equal, [tag (tag (var "Y")), tag (var "Y")]))
 11.1280 +             |> close_formula_universally, simp_info, NONE)
 11.1281 +  end
 11.1282 +
 11.1283 +fun helper_facts_for_sym ctxt format type_sys (s, {types, ...} : sym_info) =
 11.1284 +  case strip_prefix_and_unascii const_prefix s of
 11.1285 +    SOME mangled_s =>
 11.1286 +    let
 11.1287 +      val thy = Proof_Context.theory_of ctxt
 11.1288 +      val unmangled_s = mangled_s |> unmangled_const_name
 11.1289 +      fun dub_and_inst c needs_fairly_sound (th, j) =
 11.1290 +        ((c ^ "_" ^ string_of_int j ^
 11.1291 +          (if needs_fairly_sound then typed_helper_suffix
 11.1292 +           else untyped_helper_suffix),
 11.1293 +          General),
 11.1294 +         let val t = th |> prop_of in
 11.1295 +           t |> ((case general_type_arg_policy type_sys of
 11.1296 +                    Mangled_Type_Args _ => true
 11.1297 +                  | _ => false) andalso
 11.1298 +                 not (null (Term.hidden_polymorphism t)))
 11.1299 +                ? (case types of
 11.1300 +                     [T] => specialize_type thy (invert_const unmangled_s, T)
 11.1301 +                   | _ => I)
 11.1302 +         end)
 11.1303 +      fun make_facts eq_as_iff =
 11.1304 +        map_filter (make_fact ctxt format type_sys true false eq_as_iff false)
 11.1305 +      val fairly_sound = is_type_sys_fairly_sound type_sys
 11.1306 +    in
 11.1307 +      helper_table
 11.1308 +      |> maps (fn (metis_s, (needs_fairly_sound, ths)) =>
 11.1309 +                  if metis_s <> unmangled_s orelse
 11.1310 +                     (needs_fairly_sound andalso not fairly_sound) then
 11.1311 +                    []
 11.1312 +                  else
 11.1313 +                    ths ~~ (1 upto length ths)
 11.1314 +                    |> map (dub_and_inst mangled_s needs_fairly_sound)
 11.1315 +                    |> make_facts (not needs_fairly_sound))
 11.1316 +    end
 11.1317 +  | NONE => []
 11.1318 +fun helper_facts_for_sym_table ctxt format type_sys sym_tab =
 11.1319 +  Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_sys) sym_tab
 11.1320 +                  []
 11.1321 +
 11.1322 +fun translate_atp_fact ctxt format type_sys keep_trivial =
 11.1323 +  `(make_fact ctxt format type_sys keep_trivial true true true o apsnd prop_of)
 11.1324 +
 11.1325 +(***************************************************************)
 11.1326 +(* Type Classes Present in the Axiom or Conjecture Clauses     *)
 11.1327 +(***************************************************************)
 11.1328 +
 11.1329 +fun set_insert (x, s) = Symtab.update (x, ()) s
 11.1330 +
 11.1331 +fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
 11.1332 +
 11.1333 +(* Remove this trivial type class (FIXME: similar code elsewhere) *)
 11.1334 +fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset
 11.1335 +
 11.1336 +fun classes_of_terms get_Ts =
 11.1337 +  map (map #2 o get_Ts)
 11.1338 +  #> List.foldl add_classes Symtab.empty
 11.1339 +  #> delete_type #> Symtab.keys
 11.1340 +
 11.1341 +val tfree_classes_of_terms = classes_of_terms OldTerm.term_tfrees
 11.1342 +val tvar_classes_of_terms = classes_of_terms OldTerm.term_tvars
 11.1343 +
 11.1344 +(*fold type constructors*)
 11.1345 +fun fold_type_consts f (Type (a, Ts)) x = fold (fold_type_consts f) Ts (f (a,x))
 11.1346 +  | fold_type_consts _ _ x = x
 11.1347 +
 11.1348 +(*Type constructors used to instantiate overloaded constants are the only ones needed.*)
 11.1349 +fun add_type_consts_in_term thy =
 11.1350 +  let
 11.1351 +    fun aux (Const (@{const_name Meson.skolem}, _) $ _) = I
 11.1352 +      | aux (t $ u) = aux t #> aux u
 11.1353 +      | aux (Const x) =
 11.1354 +        fold (fold_type_consts set_insert) (Sign.const_typargs thy x)
 11.1355 +      | aux (Abs (_, _, u)) = aux u
 11.1356 +      | aux _ = I
 11.1357 +  in aux end
 11.1358 +
 11.1359 +fun type_consts_of_terms thy ts =
 11.1360 +  Symtab.keys (fold (add_type_consts_in_term thy) ts Symtab.empty)
 11.1361 +
 11.1362 +fun translate_formulas ctxt format prem_kind type_sys preproc hyp_ts concl_t
 11.1363 +                       rich_facts =
 11.1364 +  let
 11.1365 +    val thy = Proof_Context.theory_of ctxt
 11.1366 +    val fact_ts = map (prop_of o snd o snd) rich_facts
 11.1367 +    val (facts, fact_names) =
 11.1368 +      rich_facts
 11.1369 +      |> map_filter (fn (NONE, _) => NONE
 11.1370 +                      | (SOME fact, (name, _)) => SOME (fact, name))
 11.1371 +      |> ListPair.unzip
 11.1372 +    (* Remove existing facts from the conjecture, as this can dramatically
 11.1373 +       boost an ATP's performance (for some reason). *)
 11.1374 +    val hyp_ts = hyp_ts |> filter_out (member (op aconv) fact_ts)
 11.1375 +    val goal_t = Logic.list_implies (hyp_ts, concl_t)
 11.1376 +    val all_ts = goal_t :: fact_ts
 11.1377 +    val subs = tfree_classes_of_terms all_ts
 11.1378 +    val supers = tvar_classes_of_terms all_ts
 11.1379 +    val tycons = type_consts_of_terms thy all_ts
 11.1380 +    val conjs =
 11.1381 +      hyp_ts @ [concl_t]
 11.1382 +      |> make_conjecture ctxt format prem_kind type_sys preproc
 11.1383 +    val (supers', arity_clauses) =
 11.1384 +      if level_of_type_sys type_sys = No_Types then ([], [])
 11.1385 +      else make_arity_clauses thy tycons supers
 11.1386 +    val class_rel_clauses = make_class_rel_clauses thy subs supers'
 11.1387 +  in
 11.1388 +    (fact_names |> map single, (conjs, facts, class_rel_clauses, arity_clauses))
 11.1389 +  end
 11.1390 +
 11.1391 +fun fo_literal_from_type_literal (TyLitVar (class, name)) =
 11.1392 +    (true, ATerm (class, [ATerm (name, [])]))
 11.1393 +  | fo_literal_from_type_literal (TyLitFree (class, name)) =
 11.1394 +    (true, ATerm (class, [ATerm (name, [])]))
 11.1395 +
 11.1396 +fun formula_from_fo_literal (pos, t) = AAtom t |> not pos ? mk_anot
 11.1397 +
 11.1398 +fun type_pred_combterm ctxt nonmono_Ts type_sys T tm =
 11.1399 +  CombApp (CombConst (`make_fixed_const type_pred_name, T --> @{typ bool}, [T])
 11.1400 +           |> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys,
 11.1401 +           tm)
 11.1402 +
 11.1403 +fun var_occurs_positively_naked_in_term _ (SOME false) _ accum = accum
 11.1404 +  | var_occurs_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum =
 11.1405 +    accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, [])))
 11.1406 +fun is_var_nonmonotonic_in_formula _ _ (SOME false) _ = false
 11.1407 +  | is_var_nonmonotonic_in_formula pos phi _ name =
 11.1408 +    formula_fold pos (var_occurs_positively_naked_in_term name) phi false
 11.1409 +
 11.1410 +fun mk_const_aterm x T_args args =
 11.1411 +  ATerm (x, map (fo_term_from_typ false) T_args @ args)
 11.1412 +
 11.1413 +fun tag_with_type ctxt format nonmono_Ts type_sys T tm =
 11.1414 +  CombConst (`make_fixed_const type_tag_name, T --> T, [T])
 11.1415 +  |> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys
 11.1416 +  |> term_from_combterm ctxt format nonmono_Ts type_sys Top_Level
 11.1417 +  |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm]))
 11.1418 +and term_from_combterm ctxt format nonmono_Ts type_sys =
 11.1419 +  let
 11.1420 +    fun aux site u =
 11.1421 +      let
 11.1422 +        val (head, args) = strip_combterm_comb u
 11.1423 +        val (x as (s, _), T_args) =
 11.1424 +          case head of
 11.1425 +            CombConst (name, _, T_args) => (name, T_args)
 11.1426 +          | CombVar (name, _) => (name, [])
 11.1427 +          | CombApp _ => raise Fail "impossible \"CombApp\""
 11.1428 +        val arg_site = if site = Top_Level andalso is_tptp_equal s then Eq_Arg
 11.1429 +                       else Elsewhere
 11.1430 +        val t = mk_const_aterm x T_args (map (aux arg_site) args)
 11.1431 +        val T = combtyp_of u
 11.1432 +      in
 11.1433 +        t |> (if should_tag_with_type ctxt nonmono_Ts type_sys site u T then
 11.1434 +                tag_with_type ctxt format nonmono_Ts type_sys T
 11.1435 +              else
 11.1436 +                I)
 11.1437 +      end
 11.1438 +  in aux end
 11.1439 +and formula_from_combformula ctxt format nonmono_Ts type_sys
 11.1440 +                             should_predicate_on_var =
 11.1441 +  let
 11.1442 +    val higher_order = is_setting_higher_order format type_sys
 11.1443 +    val do_term = term_from_combterm ctxt format nonmono_Ts type_sys Top_Level
 11.1444 +    val do_bound_type =
 11.1445 +      case type_sys of
 11.1446 +        Simple_Types level =>
 11.1447 +        homogenized_type ctxt nonmono_Ts level 0
 11.1448 +        #> mangled_type higher_order false 0 #> SOME
 11.1449 +      | _ => K NONE
 11.1450 +    fun do_out_of_bound_type pos phi universal (name, T) =
 11.1451 +      if should_predicate_on_type ctxt nonmono_Ts type_sys
 11.1452 +             (fn () => should_predicate_on_var pos phi universal name) T then
 11.1453 +        CombVar (name, T)
 11.1454 +        |> type_pred_combterm ctxt nonmono_Ts type_sys T
 11.1455 +        |> do_term |> AAtom |> SOME
 11.1456 +      else
 11.1457 +        NONE
 11.1458 +    fun do_formula pos (AQuant (q, xs, phi)) =
 11.1459 +        let
 11.1460 +          val phi = phi |> do_formula pos
 11.1461 +          val universal = Option.map (q = AExists ? not) pos
 11.1462 +        in
 11.1463 +          AQuant (q, xs |> map (apsnd (fn NONE => NONE
 11.1464 +                                        | SOME T => do_bound_type T)),
 11.1465 +                  (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd))
 11.1466 +                      (map_filter
 11.1467 +                           (fn (_, NONE) => NONE
 11.1468 +                             | (s, SOME T) =>
 11.1469 +                               do_out_of_bound_type pos phi universal (s, T))
 11.1470 +                           xs)
 11.1471 +                      phi)
 11.1472 +        end
 11.1473 +      | do_formula pos (AConn conn) = aconn_map pos do_formula conn
 11.1474 +      | do_formula _ (AAtom tm) = AAtom (do_term tm)
 11.1475 +  in do_formula o SOME end
 11.1476 +
 11.1477 +fun bound_tvars type_sys Ts =
 11.1478 +  mk_ahorn (map (formula_from_fo_literal o fo_literal_from_type_literal)
 11.1479 +                (type_literals_for_types type_sys sorts_on_tvar Ts))
 11.1480 +
 11.1481 +fun formula_for_fact ctxt format nonmono_Ts type_sys
 11.1482 +                     ({combformula, atomic_types, ...} : translated_formula) =
 11.1483 +  combformula
 11.1484 +  |> close_combformula_universally
 11.1485 +  |> formula_from_combformula ctxt format nonmono_Ts type_sys
 11.1486 +                              is_var_nonmonotonic_in_formula true
 11.1487 +  |> bound_tvars type_sys atomic_types
 11.1488 +  |> close_formula_universally
 11.1489 +
 11.1490 +(* Each fact is given a unique fact number to avoid name clashes (e.g., because
 11.1491 +   of monomorphization). The TPTP explicitly forbids name clashes, and some of
 11.1492 +   the remote provers might care. *)
 11.1493 +fun formula_line_for_fact ctxt format prefix nonmono_Ts type_sys
 11.1494 +                          (j, formula as {name, locality, kind, ...}) =
 11.1495 +  Formula (prefix ^ (if polymorphism_of_type_sys type_sys = Polymorphic then ""
 11.1496 +                     else string_of_int j ^ "_") ^
 11.1497 +           ascii_of name,
 11.1498 +           kind, formula_for_fact ctxt format nonmono_Ts type_sys formula, NONE,
 11.1499 +           case locality of
 11.1500 +             Intro => intro_info
 11.1501 +           | Elim => elim_info
 11.1502 +           | Simp => simp_info
 11.1503 +           | _ => NONE)
 11.1504 +
 11.1505 +fun formula_line_for_class_rel_clause ({name, subclass, superclass, ...}
 11.1506 +                                       : class_rel_clause) =
 11.1507 +  let val ty_arg = ATerm (`I "T", []) in
 11.1508 +    Formula (class_rel_clause_prefix ^ ascii_of name, Axiom,
 11.1509 +             AConn (AImplies, [AAtom (ATerm (subclass, [ty_arg])),
 11.1510 +                               AAtom (ATerm (superclass, [ty_arg]))])
 11.1511 +             |> close_formula_universally, intro_info, NONE)
 11.1512 +  end
 11.1513 +
 11.1514 +fun fo_literal_from_arity_literal (TConsLit (c, t, args)) =
 11.1515 +    (true, ATerm (c, [ATerm (t, map (fn arg => ATerm (arg, [])) args)]))
 11.1516 +  | fo_literal_from_arity_literal (TVarLit (c, sort)) =
 11.1517 +    (false, ATerm (c, [ATerm (sort, [])]))
 11.1518 +
 11.1519 +fun formula_line_for_arity_clause ({name, prem_lits, concl_lits, ...}
 11.1520 +                                   : arity_clause) =
 11.1521 +  Formula (arity_clause_prefix ^ ascii_of name, Axiom,
 11.1522 +           mk_ahorn (map (formula_from_fo_literal o apfst not
 11.1523 +                          o fo_literal_from_arity_literal) prem_lits)
 11.1524 +                    (formula_from_fo_literal
 11.1525 +                         (fo_literal_from_arity_literal concl_lits))
 11.1526 +           |> close_formula_universally, intro_info, NONE)
 11.1527 +
 11.1528 +fun formula_line_for_conjecture ctxt format nonmono_Ts type_sys
 11.1529 +        ({name, kind, combformula, atomic_types, ...} : translated_formula) =
 11.1530 +  Formula (conjecture_prefix ^ name, kind,
 11.1531 +           formula_from_combformula ctxt format nonmono_Ts type_sys
 11.1532 +               is_var_nonmonotonic_in_formula false
 11.1533 +               (close_combformula_universally combformula)
 11.1534 +           |> bound_tvars type_sys atomic_types
 11.1535 +           |> close_formula_universally, NONE, NONE)
 11.1536 +
 11.1537 +fun free_type_literals type_sys ({atomic_types, ...} : translated_formula) =
 11.1538 +  atomic_types |> type_literals_for_types type_sys sorts_on_tfree
 11.1539 +               |> map fo_literal_from_type_literal
 11.1540 +
 11.1541 +fun formula_line_for_free_type j lit =
 11.1542 +  Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis,
 11.1543 +           formula_from_fo_literal lit, NONE, NONE)
 11.1544 +fun formula_lines_for_free_types type_sys facts =
 11.1545 +  let
 11.1546 +    val litss = map (free_type_literals type_sys) facts
 11.1547 +    val lits = fold (union (op =)) litss []
 11.1548 +  in map2 formula_line_for_free_type (0 upto length lits - 1) lits end
 11.1549 +
 11.1550 +(** Symbol declarations **)
 11.1551 +
 11.1552 +fun should_declare_sym type_sys pred_sym s =
 11.1553 +  is_tptp_user_symbol s andalso not (String.isPrefix bound_var_prefix s) andalso
 11.1554 +  (case type_sys of
 11.1555 +     Simple_Types _ => true
 11.1556 +   | Tags (_, _, Light) => true
 11.1557 +   | _ => not pred_sym)
 11.1558 +
 11.1559 +fun sym_decl_table_for_facts ctxt type_sys repaired_sym_tab (conjs, facts) =
 11.1560 +  let
 11.1561 +    fun add_combterm in_conj tm =
 11.1562 +      let val (head, args) = strip_combterm_comb tm in
 11.1563 +        (case head of
 11.1564 +           CombConst ((s, s'), T, T_args) =>
 11.1565 +           let val pred_sym = is_pred_sym repaired_sym_tab s in
 11.1566 +             if should_declare_sym type_sys pred_sym s then
 11.1567 +               Symtab.map_default (s, [])
 11.1568 +                   (insert_type ctxt #3 (s', T_args, T, pred_sym, length args,
 11.1569 +                                         in_conj))
 11.1570 +             else
 11.1571 +               I
 11.1572 +           end
 11.1573 +         | _ => I)
 11.1574 +        #> fold (add_combterm in_conj) args
 11.1575 +      end
 11.1576 +    fun add_fact in_conj =
 11.1577 +      fact_lift (formula_fold NONE (K (add_combterm in_conj)))
 11.1578 +  in
 11.1579 +    Symtab.empty
 11.1580 +    |> is_type_sys_fairly_sound type_sys
 11.1581 +       ? (fold (add_fact true) conjs #> fold (add_fact false) facts)
 11.1582 +  end
 11.1583 +
 11.1584 +(* These types witness that the type classes they belong to allow infinite
 11.1585 +   models and hence that any types with these type classes is monotonic. *)
 11.1586 +val known_infinite_types =
 11.1587 +  [@{typ nat}, Type ("Int.int", []), @{typ "nat => bool"}]
 11.1588 +
 11.1589 +(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it
 11.1590 +   out with monotonicity" paper presented at CADE 2011. *)
 11.1591 +fun add_combterm_nonmonotonic_types _ _ (SOME false) _ = I
 11.1592 +  | add_combterm_nonmonotonic_types ctxt level _
 11.1593 +        (CombApp (CombApp (CombConst ((s, _), Type (_, [T, _]), _), tm1), tm2)) =
 11.1594 +    (is_tptp_equal s andalso exists is_var_or_bound_var [tm1, tm2] andalso
 11.1595 +     (case level of
 11.1596 +        Nonmonotonic_Types =>
 11.1597 +        not (is_type_surely_infinite ctxt known_infinite_types T)
 11.1598 +      | Finite_Types => is_type_surely_finite ctxt T
 11.1599 +      | _ => true)) ? insert_type ctxt I (deep_freeze_type T)
 11.1600 +  | add_combterm_nonmonotonic_types _ _ _ _ = I
 11.1601 +fun add_fact_nonmonotonic_types ctxt level ({kind, combformula, ...}
 11.1602 +                                            : translated_formula) =
 11.1603 +  formula_fold (SOME (kind <> Conjecture))
 11.1604 +               (add_combterm_nonmonotonic_types ctxt level) combformula
 11.1605 +fun nonmonotonic_types_for_facts ctxt type_sys facts =
 11.1606 +  let val level = level_of_type_sys type_sys in
 11.1607 +    if level = Nonmonotonic_Types orelse level = Finite_Types then
 11.1608 +      [] |> fold (add_fact_nonmonotonic_types ctxt level) facts
 11.1609 +         (* We must add "bool" in case the helper "True_or_False" is added
 11.1610 +            later. In addition, several places in the code rely on the list of
 11.1611 +            nonmonotonic types not being empty. *)
 11.1612 +         |> insert_type ctxt I @{typ bool}
 11.1613 +    else
 11.1614 +      []
 11.1615 +  end
 11.1616 +
 11.1617 +fun decl_line_for_sym ctxt format nonmono_Ts type_sys s
 11.1618 +                      (s', T_args, T, pred_sym, ary, _) =
 11.1619 +  let
 11.1620 +    val (higher_order, T_arg_Ts, level) =
 11.1621 +      case type_sys of
 11.1622 +        Simple_Types level => (format = THF, [], level)
 11.1623 +      | _ => (false, replicate (length T_args) homo_infinite_type, No_Types)
 11.1624 +  in
 11.1625 +    Decl (sym_decl_prefix ^ s, (s, s'),
 11.1626 +          (T_arg_Ts ---> (T |> homogenized_type ctxt nonmono_Ts level ary))
 11.1627 +          |> mangled_type higher_order pred_sym (length T_arg_Ts + ary))
 11.1628 +  end
 11.1629 +
 11.1630 +fun is_polymorphic_type T = fold_atyps (fn TVar _ => K true | _ => I) T false
 11.1631 +
 11.1632 +fun formula_line_for_pred_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys
 11.1633 +                                   n s j (s', T_args, T, _, ary, in_conj) =
 11.1634 +  let
 11.1635 +    val (kind, maybe_negate) =
 11.1636 +      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 11.1637 +      else (Axiom, I)
 11.1638 +    val (arg_Ts, res_T) = chop_fun ary T
 11.1639 +    val bound_names =
 11.1640 +      1 upto length arg_Ts |> map (`I o make_bound_var o string_of_int)
 11.1641 +    val bounds =
 11.1642 +      bound_names ~~ arg_Ts |> map (fn (name, T) => CombConst (name, T, []))
 11.1643 +    val bound_Ts =
 11.1644 +      arg_Ts |> map (fn T => if n > 1 orelse is_polymorphic_type T then SOME T
 11.1645 +                             else NONE)
 11.1646 +  in
 11.1647 +    Formula (sym_formula_prefix ^ s ^
 11.1648 +             (if n > 1 then "_" ^ string_of_int j else ""), kind,
 11.1649 +             CombConst ((s, s'), T, T_args)
 11.1650 +             |> fold (curry (CombApp o swap)) bounds
 11.1651 +             |> type_pred_combterm ctxt nonmono_Ts type_sys res_T
 11.1652 +             |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts)
 11.1653 +             |> formula_from_combformula ctxt format nonmono_Ts type_sys
 11.1654 +                                         (K (K (K (K true)))) true
 11.1655 +             |> n > 1 ? bound_tvars type_sys (atyps_of T)
 11.1656 +             |> close_formula_universally
 11.1657 +             |> maybe_negate,
 11.1658 +             intro_info, NONE)
 11.1659 +  end
 11.1660 +
 11.1661 +fun formula_lines_for_tag_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys
 11.1662 +        n s (j, (s', T_args, T, pred_sym, ary, in_conj)) =
 11.1663 +  let
 11.1664 +    val ident_base =
 11.1665 +      sym_formula_prefix ^ s ^ (if n > 1 then "_" ^ string_of_int j else "")
 11.1666 +    val (kind, maybe_negate) =
 11.1667 +      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 11.1668 +      else (Axiom, I)
 11.1669 +    val (arg_Ts, res_T) = chop_fun ary T
 11.1670 +    val bound_names =
 11.1671 +      1 upto length arg_Ts |> map (`I o make_bound_var o string_of_int)
 11.1672 +    val bounds = bound_names |> map (fn name => ATerm (name, []))
 11.1673 +    val cst = mk_const_aterm (s, s') T_args
 11.1674 +    val atomic_Ts = atyps_of T
 11.1675 +    fun eq tms =
 11.1676 +      (if pred_sym then AConn (AIff, map AAtom tms)
 11.1677 +       else AAtom (ATerm (`I tptp_equal, tms)))
 11.1678 +      |> bound_tvars type_sys atomic_Ts
 11.1679 +      |> close_formula_universally
 11.1680 +      |> maybe_negate
 11.1681 +    val should_encode = should_encode_type ctxt nonmono_Ts All_Types
 11.1682 +    val tag_with = tag_with_type ctxt format nonmono_Ts type_sys
 11.1683 +    val add_formula_for_res =
 11.1684 +      if should_encode res_T then
 11.1685 +        cons (Formula (ident_base ^ "_res", kind,
 11.1686 +                       eq [tag_with res_T (cst bounds), cst bounds],
 11.1687 +                       simp_info, NONE))
 11.1688 +      else
 11.1689 +        I
 11.1690 +    fun add_formula_for_arg k =
 11.1691 +      let val arg_T = nth arg_Ts k in
 11.1692 +        if should_encode arg_T then
 11.1693 +          case chop k bounds of
 11.1694 +            (bounds1, bound :: bounds2) =>
 11.1695 +            cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind,
 11.1696 +                           eq [cst (bounds1 @ tag_with arg_T bound :: bounds2),
 11.1697 +                               cst bounds],
 11.1698 +                           simp_info, NONE))
 11.1699 +          | _ => raise Fail "expected nonempty tail"
 11.1700 +        else
 11.1701 +          I
 11.1702 +      end
 11.1703 +  in
 11.1704 +    [] |> not pred_sym ? add_formula_for_res
 11.1705 +       |> fold add_formula_for_arg (ary - 1 downto 0)
 11.1706 +  end
 11.1707 +
 11.1708 +fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
 11.1709 +
 11.1710 +fun problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts type_sys
 11.1711 +                                (s, decls) =
 11.1712 +  case type_sys of
 11.1713 +    Simple_Types _ =>
 11.1714 +    decls |> map (decl_line_for_sym ctxt format nonmono_Ts type_sys s)
 11.1715 +  | Preds _ =>
 11.1716 +    let
 11.1717 +      val decls =
 11.1718 +        case decls of
 11.1719 +          decl :: (decls' as _ :: _) =>
 11.1720 +          let val T = result_type_of_decl decl in
 11.1721 +            if forall (curry (type_instance ctxt o swap) T
 11.1722 +                       o result_type_of_decl) decls' then
 11.1723 +              [decl]
 11.1724 +            else
 11.1725 +              decls
 11.1726 +          end
 11.1727 +        | _ => decls
 11.1728 +      val n = length decls
 11.1729 +      val decls =
 11.1730 +        decls
 11.1731 +        |> filter (should_predicate_on_type ctxt nonmono_Ts type_sys (K true)
 11.1732 +                   o result_type_of_decl)
 11.1733 +    in
 11.1734 +      (0 upto length decls - 1, decls)
 11.1735 +      |-> map2 (formula_line_for_pred_sym_decl ctxt format conj_sym_kind
 11.1736 +                                               nonmono_Ts type_sys n s)
 11.1737 +    end
 11.1738 +  | Tags (_, _, heaviness) =>
 11.1739 +    (case heaviness of
 11.1740 +       Heavy => []
 11.1741 +     | Light =>
 11.1742 +       let val n = length decls in
 11.1743 +         (0 upto n - 1 ~~ decls)
 11.1744 +         |> maps (formula_lines_for_tag_sym_decl ctxt format conj_sym_kind
 11.1745 +                                                 nonmono_Ts type_sys n s)
 11.1746 +       end)
 11.1747 +
 11.1748 +fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind nonmono_Ts
 11.1749 +                                     type_sys sym_decl_tab =
 11.1750 +  sym_decl_tab
 11.1751 +  |> Symtab.dest
 11.1752 +  |> sort_wrt fst
 11.1753 +  |> rpair []
 11.1754 +  |-> fold_rev (append o problem_lines_for_sym_decls ctxt format conj_sym_kind
 11.1755 +                                                     nonmono_Ts type_sys)
 11.1756 +
 11.1757 +fun should_add_ti_ti_helper (Tags (Polymorphic, level, Heavy)) =
 11.1758 +    level = Nonmonotonic_Types orelse level = Finite_Types
 11.1759 +  | should_add_ti_ti_helper _ = false
 11.1760 +
 11.1761 +fun offset_of_heading_in_problem _ [] j = j
 11.1762 +  | offset_of_heading_in_problem needle ((heading, lines) :: problem) j =
 11.1763 +    if heading = needle then j
 11.1764 +    else offset_of_heading_in_problem needle problem (j + length lines)
 11.1765 +
 11.1766 +val implicit_declsN = "Should-be-implicit typings"
 11.1767 +val explicit_declsN = "Explicit typings"
 11.1768 +val factsN = "Relevant facts"
 11.1769 +val class_relsN = "Class relationships"
 11.1770 +val aritiesN = "Arities"
 11.1771 +val helpersN = "Helper facts"
 11.1772 +val conjsN = "Conjectures"
 11.1773 +val free_typesN = "Type variables"
 11.1774 +
 11.1775 +fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_sys
 11.1776 +                        explicit_apply readable_names preproc hyp_ts concl_t
 11.1777 +                        facts =
 11.1778 +  let
 11.1779 +    val (format, type_sys) = choose_format [format] type_sys
 11.1780 +    val (fact_names, (conjs, facts, class_rel_clauses, arity_clauses)) =
 11.1781 +      translate_formulas ctxt format prem_kind type_sys preproc hyp_ts concl_t
 11.1782 +                         facts
 11.1783 +    val sym_tab = conjs @ facts |> sym_table_for_facts ctxt explicit_apply
 11.1784 +    val nonmono_Ts = conjs @ facts |> nonmonotonic_types_for_facts ctxt type_sys
 11.1785 +    val repair = repair_fact ctxt format nonmono_Ts type_sys sym_tab
 11.1786 +    val (conjs, facts) = (conjs, facts) |> pairself (map repair)
 11.1787 +    val repaired_sym_tab =
 11.1788 +      conjs @ facts |> sym_table_for_facts ctxt (SOME false)
 11.1789 +    val helpers =
 11.1790 +      repaired_sym_tab |> helper_facts_for_sym_table ctxt format type_sys
 11.1791 +                       |> map repair
 11.1792 +    val lavish_nonmono_Ts =
 11.1793 +      if null nonmono_Ts orelse
 11.1794 +         polymorphism_of_type_sys type_sys <> Polymorphic then
 11.1795 +        nonmono_Ts
 11.1796 +      else
 11.1797 +        [TVar (("'a", 0), HOLogic.typeS)]
 11.1798 +    val sym_decl_lines =
 11.1799 +      (conjs, helpers @ facts)
 11.1800 +      |> sym_decl_table_for_facts ctxt type_sys repaired_sym_tab
 11.1801 +      |> problem_lines_for_sym_decl_table ctxt format conj_sym_kind
 11.1802 +                                          lavish_nonmono_Ts type_sys
 11.1803 +    val helper_lines =
 11.1804 +      0 upto length helpers - 1 ~~ helpers
 11.1805 +      |> map (formula_line_for_fact ctxt format helper_prefix lavish_nonmono_Ts
 11.1806 +                                    type_sys)
 11.1807 +      |> (if should_add_ti_ti_helper type_sys then cons (ti_ti_helper_fact ())
 11.1808 +          else I)
 11.1809 +    (* Reordering these might confuse the proof reconstruction code or the SPASS
 11.1810 +       FLOTTER hack. *)
 11.1811 +    val problem =
 11.1812 +      [(explicit_declsN, sym_decl_lines),
 11.1813 +       (factsN,
 11.1814 +        map (formula_line_for_fact ctxt format fact_prefix nonmono_Ts type_sys)
 11.1815 +            (0 upto length facts - 1 ~~ facts)),
 11.1816 +       (class_relsN, map formula_line_for_class_rel_clause class_rel_clauses),
 11.1817 +       (aritiesN, map formula_line_for_arity_clause arity_clauses),
 11.1818 +       (helpersN, helper_lines),
 11.1819 +       (conjsN,
 11.1820 +        map (formula_line_for_conjecture ctxt format nonmono_Ts type_sys)
 11.1821 +            conjs),
 11.1822 +       (free_typesN, formula_lines_for_free_types type_sys (facts @ conjs))]
 11.1823 +    val problem =
 11.1824 +      problem
 11.1825 +      |> (case format of
 11.1826 +            CNF => ensure_cnf_problem
 11.1827 +          | CNF_UEQ => filter_cnf_ueq_problem
 11.1828 +          | _ => I)
 11.1829 +      |> (if is_format_typed format then
 11.1830 +            declare_undeclared_syms_in_atp_problem type_decl_prefix
 11.1831 +                                                   implicit_declsN
 11.1832 +          else
 11.1833 +            I)
 11.1834 +    val (problem, pool) = problem |> nice_atp_problem readable_names
 11.1835 +    val helpers_offset = offset_of_heading_in_problem helpersN problem 0
 11.1836 +    val typed_helpers =
 11.1837 +      map_filter (fn (j, {name, ...}) =>
 11.1838 +                     if String.isSuffix typed_helper_suffix name then SOME j
 11.1839 +                     else NONE)
 11.1840 +                 ((helpers_offset + 1 upto helpers_offset + length helpers)
 11.1841 +                  ~~ helpers)
 11.1842 +    fun add_sym_arity (s, {min_ary, ...} : sym_info) =
 11.1843 +      if min_ary > 0 then
 11.1844 +        case strip_prefix_and_unascii const_prefix s of
 11.1845 +          SOME s => Symtab.insert (op =) (s, min_ary)
 11.1846 +        | NONE => I
 11.1847 +      else
 11.1848 +        I
 11.1849 +  in
 11.1850 +    (problem,
 11.1851 +     case pool of SOME the_pool => snd the_pool | NONE => Symtab.empty,
 11.1852 +     offset_of_heading_in_problem conjsN problem 0,
 11.1853 +     offset_of_heading_in_problem factsN problem 0,
 11.1854 +     fact_names |> Vector.fromList,
 11.1855 +     typed_helpers,
 11.1856 +     Symtab.empty |> Symtab.fold add_sym_arity sym_tab)
 11.1857 +  end
 11.1858 +
 11.1859 +(* FUDGE *)
 11.1860 +val conj_weight = 0.0
 11.1861 +val hyp_weight = 0.1
 11.1862 +val fact_min_weight = 0.2
 11.1863 +val fact_max_weight = 1.0
 11.1864 +val type_info_default_weight = 0.8
 11.1865 +
 11.1866 +fun add_term_weights weight (ATerm (s, tms)) =
 11.1867 +  is_tptp_user_symbol s ? Symtab.default (s, weight)
 11.1868 +  #> fold (add_term_weights weight) tms
 11.1869 +fun add_problem_line_weights weight (Formula (_, _, phi, _, _)) =
 11.1870 +    formula_fold NONE (K (add_term_weights weight)) phi
 11.1871 +  | add_problem_line_weights _ _ = I
 11.1872 +
 11.1873 +fun add_conjectures_weights [] = I
 11.1874 +  | add_conjectures_weights conjs =
 11.1875 +    let val (hyps, conj) = split_last conjs in
 11.1876 +      add_problem_line_weights conj_weight conj
 11.1877 +      #> fold (add_problem_line_weights hyp_weight) hyps
 11.1878 +    end
 11.1879 +
 11.1880 +fun add_facts_weights facts =
 11.1881 +  let
 11.1882 +    val num_facts = length facts
 11.1883 +    fun weight_of j =
 11.1884 +      fact_min_weight + (fact_max_weight - fact_min_weight) * Real.fromInt j
 11.1885 +                        / Real.fromInt num_facts
 11.1886 +  in
 11.1887 +    map weight_of (0 upto num_facts - 1) ~~ facts
 11.1888 +    |> fold (uncurry add_problem_line_weights)
 11.1889 +  end
 11.1890 +
 11.1891 +(* Weights are from 0.0 (most important) to 1.0 (least important). *)
 11.1892 +fun atp_problem_weights problem =
 11.1893 +  let val get = these o AList.lookup (op =) problem in
 11.1894 +    Symtab.empty
 11.1895 +    |> add_conjectures_weights (get free_typesN @ get conjsN)
 11.1896 +    |> add_facts_weights (get factsN)
 11.1897 +    |> fold (fold (add_problem_line_weights type_info_default_weight) o get)
 11.1898 +            [explicit_declsN, class_relsN, aritiesN]
 11.1899 +    |> Symtab.dest
 11.1900 +    |> sort (prod_ord Real.compare string_ord o pairself swap)
 11.1901 +  end
 11.1902 +
 11.1903 +end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/ATP/atp_util.ML	Tue May 31 18:13:00 2011 +0200
    12.3 @@ -0,0 +1,257 @@
    12.4 +(*  Title:      HOL/Tools/ATP/atp_util.ML
    12.5 +    Author:     Jasmin Blanchette, TU Muenchen
    12.6 +
    12.7 +General-purpose functions used by the ATP module.
    12.8 +*)
    12.9 +
   12.10 +signature ATP_UTIL =
   12.11 +sig
   12.12 +  val timestamp : unit -> string
   12.13 +  val hashw : word * word -> word
   12.14 +  val hashw_string : string * word -> word
   12.15 +  val strip_spaces : bool -> (char -> bool) -> string -> string
   12.16 +  val nat_subscript : int -> string
   12.17 +  val unyxml : string -> string
   12.18 +  val maybe_quote : string -> string
   12.19 +  val string_from_ext_time : bool * Time.time -> string
   12.20 +  val string_from_time : Time.time -> string
   12.21 +  val varify_type : Proof.context -> typ -> typ
   12.22 +  val instantiate_type : theory -> typ -> typ -> typ -> typ
   12.23 +  val varify_and_instantiate_type : Proof.context -> typ -> typ -> typ -> typ
   12.24 +  val typ_of_dtyp :
   12.25 +    Datatype_Aux.descr -> (Datatype_Aux.dtyp * typ) list -> Datatype_Aux.dtyp
   12.26 +    -> typ
   12.27 +  val is_type_surely_finite : Proof.context -> typ -> bool
   12.28 +  val is_type_surely_infinite : Proof.context -> typ list -> typ -> bool
   12.29 +  val monomorphic_term : Type.tyenv -> term -> term
   12.30 +  val eta_expand : typ list -> term -> int -> term
   12.31 +  val transform_elim_prop : term -> term
   12.32 +  val specialize_type : theory -> (string * typ) -> term -> term
   12.33 +  val strip_subgoal :
   12.34 +    Proof.context -> thm -> int -> (string * typ) list * term list * term
   12.35 +end;
   12.36 +
   12.37 +structure ATP_Util : ATP_UTIL =
   12.38 +struct
   12.39 +
   12.40 +val timestamp = Date.fmt "%Y-%m-%d %H:%M:%S" o Date.fromTimeLocal o Time.now
   12.41 +
   12.42 +(* This hash function is recommended in "Compilers: Principles, Techniques, and
   12.43 +   Tools" by Aho, Sethi, and Ullman. The "hashpjw" function, which they
   12.44 +   particularly recommend, triggers a bug in versions of Poly/ML up to 4.2.0. *)
   12.45 +fun hashw (u, w) = Word.+ (u, Word.* (0w65599, w))
   12.46 +fun hashw_char (c, w) = hashw (Word.fromInt (Char.ord c), w)
   12.47 +fun hashw_string (s : string, w) = CharVector.foldl hashw_char w s
   12.48 +
   12.49 +fun strip_c_style_comment _ [] = []
   12.50 +  | strip_c_style_comment is_evil (#"*" :: #"/" :: cs) =
   12.51 +    strip_spaces_in_list true is_evil cs
   12.52 +  | strip_c_style_comment is_evil (_ :: cs) = strip_c_style_comment is_evil cs
   12.53 +and strip_spaces_in_list _ _ [] = []
   12.54 +  | strip_spaces_in_list true is_evil (#"%" :: cs) =
   12.55 +    strip_spaces_in_list true is_evil
   12.56 +                         (cs |> chop_while (not_equal #"\n") |> snd)
   12.57 +  | strip_spaces_in_list true is_evil (#"/" :: #"*" :: cs) =
   12.58 +    strip_c_style_comment is_evil cs
   12.59 +  | strip_spaces_in_list _ _ [c1] = if Char.isSpace c1 then [] else [str c1]
   12.60 +  | strip_spaces_in_list skip_comments is_evil [c1, c2] =
   12.61 +    strip_spaces_in_list skip_comments is_evil [c1] @
   12.62 +    strip_spaces_in_list skip_comments is_evil [c2]
   12.63 +  | strip_spaces_in_list skip_comments is_evil (c1 :: c2 :: c3 :: cs) =
   12.64 +    if Char.isSpace c1 then
   12.65 +      strip_spaces_in_list skip_comments is_evil (c2 :: c3 :: cs)
   12.66 +    else if Char.isSpace c2 then
   12.67 +      if Char.isSpace c3 then
   12.68 +        strip_spaces_in_list skip_comments is_evil (c1 :: c3 :: cs)
   12.69 +      else
   12.70 +        str c1 :: (if forall is_evil [c1, c3] then [" "] else []) @
   12.71 +        strip_spaces_in_list skip_comments is_evil (c3 :: cs)
   12.72 +    else
   12.73 +      str c1 :: strip_spaces_in_list skip_comments is_evil (c2 :: c3 :: cs)
   12.74 +fun strip_spaces skip_comments is_evil =
   12.75 +  implode o strip_spaces_in_list skip_comments is_evil o String.explode
   12.76 +
   12.77 +val subscript = implode o map (prefix "\<^isub>") o raw_explode  (* FIXME Symbol.explode (?) *)
   12.78 +fun nat_subscript n =
   12.79 +  n |> string_of_int |> print_mode_active Symbol.xsymbolsN ? subscript
   12.80 +
   12.81 +val unyxml = XML.content_of o YXML.parse_body
   12.82 +
   12.83 +val is_long_identifier = forall Lexicon.is_identifier o space_explode "."
   12.84 +fun maybe_quote y =
   12.85 +  let val s = unyxml y in
   12.86 +    y |> ((not (is_long_identifier (perhaps (try (unprefix "'")) s)) andalso
   12.87 +           not (is_long_identifier (perhaps (try (unprefix "?")) s))) orelse
   12.88 +           Keyword.is_keyword s) ? quote
   12.89 +  end
   12.90 +
   12.91 +fun string_from_ext_time (plus, time) =
   12.92 +  let val ms = Time.toMilliseconds time in
   12.93 +    (if plus then "> " else "") ^
   12.94 +    (if plus andalso ms mod 1000 = 0 then
   12.95 +       signed_string_of_int (ms div 1000) ^ " s"
   12.96 +     else if ms < 1000 then
   12.97 +       signed_string_of_int ms ^ " ms"
   12.98 +     else
   12.99 +       string_of_real (0.01 * Real.fromInt (ms div 10)) ^ " s")
  12.100 +  end
  12.101 +
  12.102 +val string_from_time = string_from_ext_time o pair false
  12.103 +
  12.104 +fun varify_type ctxt T =
  12.105 +  Variable.polymorphic_types ctxt [Const (@{const_name undefined}, T)]
  12.106 +  |> snd |> the_single |> dest_Const |> snd
  12.107 +
  12.108 +(* TODO: use "Term_Subst.instantiateT" instead? *)
  12.109 +fun instantiate_type thy T1 T1' T2 =
  12.110 +  Same.commit (Envir.subst_type_same
  12.111 +                   (Sign.typ_match thy (T1, T1') Vartab.empty)) T2
  12.112 +  handle Type.TYPE_MATCH => raise TYPE ("instantiate_type", [T1, T1'], [])
  12.113 +
  12.114 +fun varify_and_instantiate_type ctxt T1 T1' T2 =
  12.115 +  let val thy = Proof_Context.theory_of ctxt in
  12.116 +    instantiate_type thy (varify_type ctxt T1) T1' (varify_type ctxt T2)
  12.117 +  end
  12.118 +
  12.119 +fun typ_of_dtyp _ typ_assoc (Datatype_Aux.DtTFree a) =
  12.120 +    the (AList.lookup (op =) typ_assoc (Datatype_Aux.DtTFree a))
  12.121 +  | typ_of_dtyp descr typ_assoc (Datatype_Aux.DtType (s, Us)) =
  12.122 +    Type (s, map (typ_of_dtyp descr typ_assoc) Us)
  12.123 +  | typ_of_dtyp descr typ_assoc (Datatype_Aux.DtRec i) =
  12.124 +    let val (s, ds, _) = the (AList.lookup (op =) descr i) in
  12.125 +      Type (s, map (typ_of_dtyp descr typ_assoc) ds)
  12.126 +    end
  12.127 +
  12.128 +fun datatype_constrs thy (T as Type (s, Ts)) =
  12.129 +    (case Datatype.get_info thy s of
  12.130 +       SOME {index, descr, ...} =>
  12.131 +       let val (_, dtyps, constrs) = AList.lookup (op =) descr index |> the in
  12.132 +         map (apsnd (fn Us => map (typ_of_dtyp descr (dtyps ~~ Ts)) Us ---> T))
  12.133 +             constrs
  12.134 +       end
  12.135 +     | NONE => [])
  12.136 +  | datatype_constrs _ _ = []
  12.137 +
  12.138 +(* Similar to "Nitpick_HOL.bounded_exact_card_of_type".
  12.139 +   0 means infinite type, 1 means singleton type (e.g., "unit"), and 2 means
  12.140 +   cardinality 2 or more. The specified default cardinality is returned if the
  12.141 +   cardinality of the type can't be determined. *)
  12.142 +fun tiny_card_of_type ctxt default_card assigns T =
  12.143 +  let
  12.144 +    val thy = Proof_Context.theory_of ctxt
  12.145 +    val max = 2 (* 1 would be too small for the "fun" case *)
  12.146 +    fun aux slack avoid T =
  12.147 +      if member (op =) avoid T then
  12.148 +        0
  12.149 +      else case AList.lookup (Sign.typ_instance thy o swap) assigns T of
  12.150 +        SOME k => k
  12.151 +      | NONE =>
  12.152 +        case T of
  12.153 +          Type (@{type_name fun}, [T1, T2]) =>
  12.154 +          (case (aux slack avoid T1, aux slack avoid T2) of
  12.155 +             (k, 1) => if slack andalso k = 0 then 0 else 1
  12.156 +           | (0, _) => 0
  12.157 +           | (_, 0) => 0
  12.158 +           | (k1, k2) =>
  12.159 +             if k1 >= max orelse k2 >= max then max
  12.160 +             else Int.min (max, Integer.pow k2 k1))
  12.161 +        | @{typ prop} => 2
  12.162 +        | @{typ bool} => 2 (* optimization *)
  12.163 +        | @{typ nat} => 0 (* optimization *)
  12.164 +        | Type ("Int.int", []) => 0 (* optimization *)
  12.165 +        | Type (s, _) =>
  12.166 +          (case datatype_constrs thy T of
  12.167 +             constrs as _ :: _ =>
  12.168 +             let
  12.169 +               val constr_cards =
  12.170 +                 map (Integer.prod o map (aux slack (T :: avoid)) o binder_types
  12.171 +                      o snd) constrs
  12.172 +             in
  12.173 +               if exists (curry (op =) 0) constr_cards then 0
  12.174 +               else Int.min (max, Integer.sum constr_cards)
  12.175 +             end
  12.176 +           | [] =>
  12.177 +             case Typedef.get_info ctxt s of
  12.178 +               ({abs_type, rep_type, ...}, _) :: _ =>
  12.179 +               (* We cheat here by assuming that typedef types are infinite if
  12.180 +                  their underlying type is infinite. This is unsound in general
  12.181 +                  but it's hard to think of a realistic example where this would
  12.182 +                  not be the case. We are also slack with representation types:
  12.183 +                  If a representation type has the form "sigma => tau", we
  12.184 +                  consider it enough to check "sigma" for infiniteness. (Look
  12.185 +                  for "slack" in this function.) *)
  12.186 +               (case varify_and_instantiate_type ctxt
  12.187 +                         (Logic.varifyT_global abs_type) T
  12.188 +                         (Logic.varifyT_global rep_type)
  12.189 +                     |> aux true avoid of
  12.190 +                  0 => 0
  12.191 +                | 1 => 1
  12.192 +                | _ => default_card)
  12.193 +             | [] => default_card)
  12.194 +          (* Very slightly unsound: Type variables are assumed not to be
  12.195 +             constrained to cardinality 1. (In practice, the user would most
  12.196 +             likely have used "unit" directly anyway.) *)
  12.197 +        | TFree _ => if default_card = 1 then 2 else default_card
  12.198 +          (* Schematic type variables that contain only unproblematic sorts
  12.199 +             (with no finiteness axiom) can safely be considered infinite. *)
  12.200 +        | TVar _ => default_card
  12.201 +  in Int.min (max, aux false [] T) end
  12.202 +
  12.203 +fun is_type_surely_finite ctxt T = tiny_card_of_type ctxt 0 [] T <> 0
  12.204 +fun is_type_surely_infinite ctxt infinite_Ts T =
  12.205 +  tiny_card_of_type ctxt 1 (map (rpair 0) infinite_Ts) T = 0
  12.206 +
  12.207 +fun monomorphic_term subst t =
  12.208 +  map_types (map_type_tvar (fn v =>
  12.209 +      case Type.lookup subst v of
  12.210 +        SOME typ => typ
  12.211 +      | NONE => raise TERM ("monomorphic_term: uninstanitated schematic type \
  12.212 +                            \variable", [t]))) t
  12.213 +
  12.214 +fun eta_expand _ t 0 = t
  12.215 +  | eta_expand Ts (Abs (s, T, t')) n =
  12.216 +    Abs (s, T, eta_expand (T :: Ts) t' (n - 1))
  12.217 +  | eta_expand Ts t n =
  12.218 +    fold_rev (fn T => fn t' => Abs ("x" ^ nat_subscript n, T, t'))
  12.219 +             (List.take (binder_types (fastype_of1 (Ts, t)), n))
  12.220 +             (list_comb (incr_boundvars n t, map Bound (n - 1 downto 0)))
  12.221 +
  12.222 +(* Converts an elim-rule into an equivalent theorem that does not have the
  12.223 +   predicate variable. Leaves other theorems unchanged. We simply instantiate
  12.224 +   the conclusion variable to False. (Cf. "transform_elim_theorem" in
  12.225 +   "Meson_Clausify".) *)
  12.226 +fun transform_elim_prop t =
  12.227 +  case Logic.strip_imp_concl t of
  12.228 +    @{const Trueprop} $ Var (z, @{typ bool}) =>
  12.229 +    subst_Vars [(z, @{const False})] t
  12.230 +  | Var (z, @{typ prop}) => subst_Vars [(z, @{prop False})] t
  12.231 +  | _ => t
  12.232 +
  12.233 +fun specialize_type thy (s, T) t =
  12.234 +  let
  12.235 +    fun subst_for (Const (s', T')) =
  12.236 +      if s = s' then
  12.237 +        SOME (Sign.typ_match thy (T', T) Vartab.empty)
  12.238 +        handle Type.TYPE_MATCH => NONE
  12.239 +      else
  12.240 +        NONE
  12.241 +    | subst_for (t1 $ t2) =
  12.242 +      (case subst_for t1 of SOME x => SOME x | NONE => subst_for t2)
  12.243 +    | subst_for (Abs (_, _, t')) = subst_for t'
  12.244 +    | subst_for _ = NONE
  12.245 +  in
  12.246 +    case subst_for t of
  12.247 +      SOME subst => monomorphic_term subst t
  12.248 +    | NONE => raise Type.TYPE_MATCH
  12.249 +  end
  12.250 +
  12.251 +fun strip_subgoal ctxt goal i =
  12.252 +  let
  12.253 +    val (t, (frees, params)) =
  12.254 +      Logic.goal_params (prop_of goal) i
  12.255 +      ||> (map dest_Free #> Variable.variant_frees ctxt [] #> `(map Free))
  12.256 +    val hyp_ts = t |> Logic.strip_assums_hyp |> map (curry subst_bounds frees)
  12.257 +    val concl_t = t |> Logic.strip_assums_concl |> curry subst_bounds frees
  12.258 +  in (rev params, hyp_ts, concl_t) end
  12.259 +
  12.260 +end;
    13.1 --- a/src/HOL/Tools/Metis/metis_reconstruct.ML	Tue May 31 15:45:27 2011 +0200
    13.2 +++ b/src/HOL/Tools/Metis/metis_reconstruct.ML	Tue May 31 18:13:00 2011 +0200
    13.3 @@ -20,7 +20,7 @@
    13.4    val lookth : (Metis_Thm.thm * 'a) list -> Metis_Thm.thm -> 'a
    13.5    val untyped_aconv : term -> term -> bool
    13.6    val replay_one_inference :
    13.7 -    Proof.context -> mode -> (string * term) list
    13.8 +    Proof.context -> mode -> (string * term) list -> int Symtab.table
    13.9      -> Metis_Thm.thm * Metis_Proof.inference -> (Metis_Thm.thm * thm) list
   13.10      -> (Metis_Thm.thm * thm) list
   13.11    val discharge_skolem_premises :
   13.12 @@ -30,6 +30,9 @@
   13.13  structure Metis_Reconstruct : METIS_RECONSTRUCT =
   13.14  struct
   13.15  
   13.16 +open ATP_Problem
   13.17 +open ATP_Translate
   13.18 +open ATP_Reconstruct
   13.19  open Metis_Translate
   13.20  
   13.21  exception METIS of string * string
   13.22 @@ -68,9 +71,9 @@
   13.23  fun infer_types ctxt =
   13.24    Syntax.check_terms (Proof_Context.set_mode Proof_Context.mode_pattern ctxt);
   13.25  
   13.26 -(*We use 1 rather than 0 because variable references in clauses may otherwise conflict
   13.27 -  with variable constraints in the goal...at least, type inference often fails otherwise.
   13.28 -  SEE ALSO axiom_inf below.*)
   13.29 +(* We use 1 rather than 0 because variable references in clauses may otherwise
   13.30 +   conflict with variable constraints in the goal...at least, type inference
   13.31 +   often fails otherwise. See also "axiom_inf" below. *)
   13.32  fun mk_var (w, T) = Var ((w, 1), T)
   13.33  
   13.34  (*include the default sort, if available*)
   13.35 @@ -79,8 +82,8 @@
   13.36    in  TFree(ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))  end;
   13.37  
   13.38  (*Remove the "apply" operator from an HO term*)
   13.39 -fun strip_happ args (Metis_Term.Fn(".",[t,u])) = strip_happ (u::args) t
   13.40 -  | strip_happ args x = (x, args);
   13.41 +fun strip_happ args (Metis_Term.Fn (".", [t, u])) = strip_happ (u :: args) t
   13.42 +  | strip_happ args x = (x, args)
   13.43  
   13.44  fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS)
   13.45  
   13.46 @@ -111,13 +114,13 @@
   13.47                  | NONE   => SomeTerm (mk_var (v, HOLogic.typeT)))
   13.48                      (*Var from Metis with a name like _nnn; possibly a type variable*)
   13.49          | tm_to_tt (Metis_Term.Fn ("{}", [arg])) = tm_to_tt arg   (*hBOOL*)
   13.50 -        | tm_to_tt (t as Metis_Term.Fn (".",_)) =
   13.51 -            let val (rator,rands) = strip_happ [] t
   13.52 -            in  case rator of
   13.53 -                    Metis_Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
   13.54 -                  | _ => case tm_to_tt rator of
   13.55 -                             SomeTerm t => SomeTerm (list_comb(t, terms_of (map tm_to_tt rands)))
   13.56 -                           | _ => raise Fail "tm_to_tt: HO application"
   13.57 +        | tm_to_tt (t as Metis_Term.Fn (".", _)) =
   13.58 +            let val (rator,rands) = strip_happ [] t in
   13.59 +              case rator of
   13.60 +                Metis_Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
   13.61 +              | _ => case tm_to_tt rator of
   13.62 +                         SomeTerm t => SomeTerm (list_comb(t, terms_of (map tm_to_tt rands)))
   13.63 +                       | _ => raise Fail "tm_to_tt: HO application"
   13.64              end
   13.65          | tm_to_tt (Metis_Term.Fn (fname, args)) = applic_to_tt (fname,args)
   13.66        and applic_to_tt ("=",ts) =
   13.67 @@ -177,20 +180,20 @@
   13.68            else
   13.69              Const (c, dummyT)
   13.70          end
   13.71 -      fun cvt (Metis_Term.Fn ("ti", [Metis_Term.Var v, _])) =
   13.72 +      fun cvt (Metis_Term.Fn (":", [Metis_Term.Var v, _])) =
   13.73               (case strip_prefix_and_unascii schematic_var_prefix v of
   13.74                    SOME w =>  mk_var(w, dummyT)
   13.75                  | NONE   => mk_var(v, dummyT))
   13.76 -        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn ("=",[]), _])) =
   13.77 +        | cvt (Metis_Term.Fn (":", [Metis_Term.Fn ("=",[]), _])) =
   13.78              Const (@{const_name HOL.eq}, HOLogic.typeT)
   13.79 -        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn (x,[]), ty])) =
   13.80 +        | cvt (Metis_Term.Fn (":", [Metis_Term.Fn (x,[]), ty])) =
   13.81             (case strip_prefix_and_unascii const_prefix x of
   13.82                  SOME c => do_const c
   13.83                | NONE => (*Not a constant. Is it a fixed variable??*)
   13.84              case strip_prefix_and_unascii fixed_var_prefix x of
   13.85                  SOME v => Free (v, hol_type_from_metis_term ctxt ty)
   13.86                | NONE => raise Fail ("hol_term_from_metis_FT bad constant: " ^ x))
   13.87 -        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn (".",[tm1,tm2]), _])) =
   13.88 +        | cvt (Metis_Term.Fn (":", [Metis_Term.Fn (".", [tm1,tm2]), _])) =
   13.89              cvt tm1 $ cvt tm2
   13.90          | cvt (Metis_Term.Fn (".",[tm1,tm2])) = (*untyped application*)
   13.91              cvt tm1 $ cvt tm2
   13.92 @@ -211,11 +214,29 @@
   13.93                     hol_term_from_metis_PT ctxt t)
   13.94    in fol_tm |> cvt end
   13.95  
   13.96 -fun hol_term_from_metis FT = hol_term_from_metis_FT
   13.97 -  | hol_term_from_metis _ = hol_term_from_metis_PT
   13.98 +fun atp_name_from_metis s =
   13.99 +  case find_first (fn (_, (s', _)) => s' = s) metis_name_table of
  13.100 +    SOME ((s, _), (_, swap)) => (s, swap)
  13.101 +  | _ => (s, false)
  13.102 +fun atp_term_from_metis (Metis_Term.Fn (s, tms)) =
  13.103 +    let val (s, swap) = atp_name_from_metis s in
  13.104 +      ATerm (s, tms |> map atp_term_from_metis |> swap ? rev)
  13.105 +    end
  13.106 +  | atp_term_from_metis (Metis_Term.Var s) = ATerm (s, [])
  13.107  
  13.108 -fun hol_terms_from_metis ctxt mode old_skolems fol_tms =
  13.109 -  let val ts = map (hol_term_from_metis mode ctxt) fol_tms
  13.110 +fun hol_term_from_metis_MX sym_tab ctxt =
  13.111 +  let val thy = Proof_Context.theory_of ctxt in
  13.112 +    atp_term_from_metis #> term_from_atp thy false sym_tab []
  13.113 +    (* FIXME ### tfrees instead of []? *) NONE
  13.114 +  end
  13.115 +
  13.116 +fun hol_term_from_metis FO _ = hol_term_from_metis_PT
  13.117 +  | hol_term_from_metis HO _ = hol_term_from_metis_PT
  13.118 +  | hol_term_from_metis FT _ = hol_term_from_metis_FT
  13.119 +  | hol_term_from_metis MX sym_tab = hol_term_from_metis_MX sym_tab
  13.120 +
  13.121 +fun hol_terms_from_metis ctxt mode old_skolems sym_tab fol_tms =
  13.122 +  let val ts = map (hol_term_from_metis mode sym_tab ctxt) fol_tms
  13.123        val _ = trace_msg ctxt (fn () => "  calling type inference:")
  13.124        val _ = app (fn t => trace_msg ctxt
  13.125                                       (fn () => Syntax.string_of_term ctxt t)) ts
  13.126 @@ -239,8 +260,8 @@
  13.127     trace_msg ctxt (fn () => "Isabelle: " ^ Display.string_of_thm_without_context th));
  13.128  *)
  13.129  
  13.130 -fun lookth thpairs (fth : Metis_Thm.thm) =
  13.131 -  the (AList.lookup (uncurry Metis_Thm.equal) thpairs fth)
  13.132 +fun lookth th_pairs fth =
  13.133 +  the (AList.lookup (uncurry Metis_Thm.equal) th_pairs fth)
  13.134    handle Option.Option =>
  13.135           raise Fail ("Failed to find Metis theorem " ^ Metis_Thm.toString fth)
  13.136  
  13.137 @@ -248,8 +269,9 @@
  13.138  
  13.139  (* INFERENCE RULE: AXIOM *)
  13.140  
  13.141 -fun axiom_inf thpairs th = Thm.incr_indexes 1 (lookth thpairs th);
  13.142 -    (*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
  13.143 +(* This causes variables to have an index of 1 by default. See also "mk_var"
  13.144 +   above. *)
  13.145 +fun axiom_inf th_pairs th = Thm.incr_indexes 1 (lookth th_pairs th)
  13.146  
  13.147  (* INFERENCE RULE: ASSUME *)
  13.148  
  13.149 @@ -261,10 +283,10 @@
  13.150        val substs = [(cterm_of thy (Var vx), cterm_of thy i_atm)]
  13.151    in  cterm_instantiate substs th  end;
  13.152  
  13.153 -fun assume_inf ctxt mode skolem_params atm =
  13.154 +fun assume_inf ctxt mode old_skolems sym_tab atm =
  13.155    inst_excluded_middle
  13.156        (Proof_Context.theory_of ctxt)
  13.157 -      (singleton (hol_terms_from_metis ctxt mode skolem_params)
  13.158 +      (singleton (hol_terms_from_metis ctxt mode old_skolems sym_tab)
  13.159                   (Metis_Term.Fn atm))
  13.160  
  13.161  (* INFERENCE RULE: INSTANTIATE (SUBST). Type instantiations are ignored. Trying
  13.162 @@ -272,15 +294,15 @@
  13.163     sorts. Instead we try to arrange that new TVars are distinct and that types
  13.164     can be inferred from terms. *)
  13.165  
  13.166 -fun inst_inf ctxt mode old_skolems thpairs fsubst th =
  13.167 +fun inst_inf ctxt mode old_skolems sym_tab th_pairs fsubst th =
  13.168    let val thy = Proof_Context.theory_of ctxt
  13.169 -      val i_th = lookth thpairs th
  13.170 +      val i_th = lookth th_pairs th
  13.171        val i_th_vars = Term.add_vars (prop_of i_th) []
  13.172        fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars)
  13.173        fun subst_translation (x,y) =
  13.174          let val v = find_var x
  13.175              (* We call "reveal_old_skolem_terms" and "infer_types" below. *)
  13.176 -            val t = hol_term_from_metis mode ctxt y
  13.177 +            val t = hol_term_from_metis mode sym_tab ctxt y
  13.178          in  SOME (cterm_of thy (Var v), t)  end
  13.179          handle Option.Option =>
  13.180                 (trace_msg ctxt (fn () => "\"find_var\" failed for " ^ x ^
  13.181 @@ -397,10 +419,10 @@
  13.182  (* Maps the clause  [P1,...Pn]==>False to [P1,...,P(i-1),P(i+1),...Pn] ==> ~P *)
  13.183  val select_literal = negate_head oo make_last
  13.184  
  13.185 -fun resolve_inf ctxt mode skolem_params thpairs atm th1 th2 =
  13.186 +fun resolve_inf ctxt mode old_skolems sym_tab th_pairs atm th1 th2 =
  13.187    let
  13.188      val thy = Proof_Context.theory_of ctxt
  13.189 -    val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
  13.190 +    val (i_th1, i_th2) = pairself (lookth th_pairs) (th1, th2)
  13.191      val _ = trace_msg ctxt (fn () => "  isa th1 (pos): " ^ Display.string_of_thm ctxt i_th1)
  13.192      val _ = trace_msg ctxt (fn () => "  isa th2 (neg): " ^ Display.string_of_thm ctxt i_th2)
  13.193    in
  13.194 @@ -412,7 +434,7 @@
  13.195      else
  13.196        let
  13.197          val i_atm =
  13.198 -          singleton (hol_terms_from_metis ctxt mode skolem_params)
  13.199 +          singleton (hol_terms_from_metis ctxt mode old_skolems sym_tab)
  13.200                      (Metis_Term.Fn atm)
  13.201          val _ = trace_msg ctxt (fn () => "  atom: " ^ Syntax.string_of_term ctxt i_atm)
  13.202          val prems_th1 = prems_of i_th1
  13.203 @@ -438,12 +460,13 @@
  13.204  val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) [])));
  13.205  val refl_idx = 1 + Thm.maxidx_of REFL_THM;
  13.206  
  13.207 -fun refl_inf ctxt mode skolem_params t =
  13.208 -  let val thy = Proof_Context.theory_of ctxt
  13.209 -      val i_t = singleton (hol_terms_from_metis ctxt mode skolem_params) t
  13.210 -      val _ = trace_msg ctxt (fn () => "  term: " ^ Syntax.string_of_term ctxt i_t)
  13.211 -      val c_t = cterm_incr_types thy refl_idx i_t
  13.212 -  in  cterm_instantiate [(refl_x, c_t)] REFL_THM  end;
  13.213 +fun refl_inf ctxt mode old_skolems sym_tab t =
  13.214 +  let
  13.215 +    val thy = Proof_Context.theory_of ctxt
  13.216 +    val i_t = singleton (hol_terms_from_metis ctxt mode old_skolems sym_tab) t
  13.217 +    val _ = trace_msg ctxt (fn () => "  term: " ^ Syntax.string_of_term ctxt i_t)
  13.218 +    val c_t = cterm_incr_types thy refl_idx i_t
  13.219 +  in cterm_instantiate [(refl_x, c_t)] REFL_THM end
  13.220  
  13.221  (* INFERENCE RULE: EQUALITY *)
  13.222  
  13.223 @@ -452,22 +475,33 @@
  13.224  
  13.225  val metis_eq = Metis_Term.Fn ("=", []);
  13.226  
  13.227 -fun get_ty_arg_size _ (Const (@{const_name HOL.eq}, _)) = 0  (*equality has no type arguments*)
  13.228 -  | get_ty_arg_size thy (Const (c, _)) = (num_type_args thy c handle TYPE _ => 0)
  13.229 -  | get_ty_arg_size _ _ = 0;
  13.230 +(* Equality has no type arguments *)
  13.231 +fun get_ty_arg_size _ (Const (@{const_name HOL.eq}, _)) = 0
  13.232 +  | get_ty_arg_size thy (Const (s, _)) =
  13.233 +    (num_type_args thy s handle TYPE _ => 0)
  13.234 +  | get_ty_arg_size _ _ = 0
  13.235  
  13.236 -fun equality_inf ctxt mode skolem_params (pos, atm) fp fr =
  13.237 +fun equality_inf ctxt mode old_skolems sym_tab (pos, atm) fp fr =
  13.238    let val thy = Proof_Context.theory_of ctxt
  13.239        val m_tm = Metis_Term.Fn atm
  13.240 -      val [i_atm,i_tm] = hol_terms_from_metis ctxt mode skolem_params [m_tm, fr]
  13.241 +      val [i_atm, i_tm] =
  13.242 +        hol_terms_from_metis ctxt mode old_skolems sym_tab [m_tm, fr]
  13.243        val _ = trace_msg ctxt (fn () => "sign of the literal: " ^ Bool.toString pos)
  13.244        fun replace_item_list lx 0 (_::ls) = lx::ls
  13.245          | replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
  13.246 +      fun path_finder_fail mode tm ps t =
  13.247 +        raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  13.248 +                    "equality_inf, path_finder_" ^ string_of_mode mode ^
  13.249 +                    ": path = " ^ space_implode " " (map string_of_int ps) ^
  13.250 +                    " isa-term: " ^ Syntax.string_of_term ctxt tm ^
  13.251 +                    (case t of
  13.252 +                       SOME t => " fol-term: " ^ Metis_Term.toString t
  13.253 +                     | NONE => ""))
  13.254        fun path_finder_FO tm [] = (tm, Bound 0)
  13.255          | path_finder_FO tm (p::ps) =
  13.256              let val (tm1,args) = strip_comb tm
  13.257                  val adjustment = get_ty_arg_size thy tm1
  13.258 -                val p' = if adjustment > p then p else p-adjustment
  13.259 +                val p' = if adjustment > p then p else p - adjustment
  13.260                  val tm_p = nth args p'
  13.261                    handle Subscript =>
  13.262                           raise METIS ("equality_inf",
  13.263 @@ -483,24 +517,41 @@
  13.264        fun path_finder_HO tm [] = (tm, Bound 0)
  13.265          | path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
  13.266          | path_finder_HO (t$u) (_::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
  13.267 -        | path_finder_HO tm ps =
  13.268 -          raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  13.269 -                      "equality_inf, path_finder_HO: path = " ^
  13.270 -                      space_implode " " (map string_of_int ps) ^
  13.271 -                      " isa-term: " ^  Syntax.string_of_term ctxt tm)
  13.272 +        | path_finder_HO tm ps = path_finder_fail HO tm ps NONE
  13.273        fun path_finder_FT tm [] _ = (tm, Bound 0)
  13.274 -        | path_finder_FT tm (0::ps) (Metis_Term.Fn ("ti", [t1, _])) =
  13.275 +        | path_finder_FT tm (0::ps) (Metis_Term.Fn (":", [t1, _])) =
  13.276              path_finder_FT tm ps t1
  13.277          | path_finder_FT (t$u) (0::ps) (Metis_Term.Fn (".", [t1, _])) =
  13.278              (fn(x,y) => (x, y$u)) (path_finder_FT t ps t1)
  13.279          | path_finder_FT (t$u) (1::ps) (Metis_Term.Fn (".", [_, t2])) =
  13.280              (fn(x,y) => (x, t$y)) (path_finder_FT u ps t2)
  13.281 -        | path_finder_FT tm ps t =
  13.282 -          raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  13.283 -                      "equality_inf, path_finder_FT: path = " ^
  13.284 -                      space_implode " " (map string_of_int ps) ^
  13.285 -                      " isa-term: " ^  Syntax.string_of_term ctxt tm ^
  13.286 -                      " fol-term: " ^ Metis_Term.toString t)
  13.287 +        | path_finder_FT tm ps t = path_finder_fail FT tm ps (SOME t)
  13.288 +      fun path_finder_MX tm [] _ = (tm, Bound 0)
  13.289 +        | path_finder_MX tm (p :: ps) (t as Metis_Term.Fn (s, ts)) =
  13.290 +          (* FIXME ### what if these are mangled? *) 
  13.291 +          if s = metis_type_tag then
  13.292 +            if p = 0 then path_finder_MX tm ps (hd ts)
  13.293 +            else path_finder_fail MX tm (p :: ps) (SOME t)
  13.294 +          else if s = metis_app_op then
  13.295 +            let
  13.296 +              val (tm1, tm2) = dest_comb tm in
  13.297 +              if p = 0 then path_finder_MX tm1 ps (hd ts) ||> (fn y => y $ tm2)
  13.298 +              else path_finder_MX tm2 ps (nth ts 1) ||> (fn y => tm1 $ y)
  13.299 +            end
  13.300 +          else
  13.301 +            let
  13.302 +              val (tm1, args) = strip_comb tm
  13.303 +              val adjustment = length ts - length args
  13.304 +              val p' = if adjustment > p then p else p - adjustment
  13.305 +              val tm_p = nth args p'
  13.306 +                handle Subscript =>
  13.307 +                       path_finder_fail MX tm (p :: ps) (SOME t)
  13.308 +              val _ = trace_msg ctxt (fn () =>
  13.309 +                  "path_finder: " ^ string_of_int p ^ "  " ^
  13.310 +                  Syntax.string_of_term ctxt tm_p)
  13.311 +              val (r, t) = path_finder_MX tm_p ps (nth ts p)
  13.312 +            in (r, list_comb (tm1, replace_item_list t p' args)) end
  13.313 +        | path_finder_MX tm ps t = path_finder_fail MX tm ps (SOME t)
  13.314        fun path_finder FO tm ps _ = path_finder_FO tm ps
  13.315          | path_finder HO (tm as Const(@{const_name HOL.eq},_) $ _ $ _) (p::ps) _ =
  13.316               (*equality: not curried, as other predicates are*)
  13.317 @@ -512,14 +563,15 @@
  13.318                              (Metis_Term.Fn ("=", [t1,t2])) =
  13.319               (*equality: not curried, as other predicates are*)
  13.320               if p=0 then path_finder_FT tm (0::1::ps)
  13.321 -                          (Metis_Term.Fn (".", [Metis_Term.Fn (".", [metis_eq,t1]), t2]))
  13.322 +                          (Metis_Term.Fn (metis_app_op, [Metis_Term.Fn (metis_app_op, [metis_eq,t1]), t2]))
  13.323                            (*select first operand*)
  13.324               else path_finder_FT tm (p::ps)
  13.325 -                   (Metis_Term.Fn (".", [metis_eq,t2]))
  13.326 +                   (Metis_Term.Fn (metis_app_op, [metis_eq, t2]))
  13.327                     (*1 selects second operand*)
  13.328          | path_finder FT tm (_ :: ps) (Metis_Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1
  13.329               (*if not equality, ignore head to skip the hBOOL predicate*)
  13.330          | path_finder FT tm ps t = path_finder_FT tm ps t  (*really an error case!*)
  13.331 +        | path_finder MX tm ps t = path_finder_MX tm ps t
  13.332        fun path_finder_lit ((nt as Const (@{const_name Not}, _)) $ tm_a) idx =
  13.333              let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm
  13.334              in (tm, nt $ tm_rslt) end
  13.335 @@ -536,19 +588,21 @@
  13.336          (ListPair.zip (OldTerm.term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm]))
  13.337    in  cterm_instantiate eq_terms subst'  end;
  13.338  
  13.339 -val factor = Seq.hd o distinct_subgoals_tac;
  13.340 +val factor = Seq.hd o distinct_subgoals_tac
  13.341  
  13.342 -fun step ctxt mode skolem_params thpairs p =
  13.343 +fun one_step ctxt mode old_skolems sym_tab th_pairs p =
  13.344    case p of
  13.345 -    (fol_th, Metis_Proof.Axiom _) => factor (axiom_inf thpairs fol_th)
  13.346 -  | (_, Metis_Proof.Assume f_atm) => assume_inf ctxt mode skolem_params f_atm
  13.347 +    (fol_th, Metis_Proof.Axiom _) => axiom_inf th_pairs fol_th |> factor
  13.348 +  | (_, Metis_Proof.Assume f_atm) =>
  13.349 +    assume_inf ctxt mode old_skolems sym_tab f_atm
  13.350    | (_, Metis_Proof.Metis_Subst (f_subst, f_th1)) =>
  13.351 -    factor (inst_inf ctxt mode skolem_params thpairs f_subst f_th1)
  13.352 +    inst_inf ctxt mode old_skolems sym_tab th_pairs f_subst f_th1 |> factor
  13.353    | (_, Metis_Proof.Resolve(f_atm, f_th1, f_th2)) =>
  13.354 -    factor (resolve_inf ctxt mode skolem_params thpairs f_atm f_th1 f_th2)
  13.355 -  | (_, Metis_Proof.Refl f_tm) => refl_inf ctxt mode skolem_params f_tm
  13.356 +    resolve_inf ctxt mode old_skolems sym_tab th_pairs f_atm f_th1 f_th2
  13.357 +    |> factor
  13.358 +  | (_, Metis_Proof.Refl f_tm) => refl_inf ctxt mode old_skolems sym_tab f_tm
  13.359    | (_, Metis_Proof.Equality (f_lit, f_p, f_r)) =>
  13.360 -    equality_inf ctxt mode skolem_params f_lit f_p f_r
  13.361 +    equality_inf ctxt mode old_skolems sym_tab f_lit f_p f_r
  13.362  
  13.363  fun flexflex_first_order th =
  13.364    case Thm.tpairs_of th of
  13.365 @@ -596,12 +650,13 @@
  13.366        end
  13.367    end
  13.368  
  13.369 -fun replay_one_inference ctxt mode skolem_params (fol_th, inf) thpairs =
  13.370 -  if not (null thpairs) andalso prop_of (snd (hd thpairs)) aconv @{prop False} then
  13.371 +fun replay_one_inference ctxt mode old_skolems sym_tab (fol_th, inf) th_pairs =
  13.372 +  if not (null th_pairs) andalso
  13.373 +     prop_of (snd (hd th_pairs)) aconv @{prop False} then
  13.374      (* Isabelle sometimes identifies literals (premises) that are distinct in
  13.375         Metis (e.g., because of type variables). We give the Isabelle proof the
  13.376         benefice of the doubt. *)
  13.377 -    thpairs
  13.378 +    th_pairs
  13.379    else
  13.380      let
  13.381        val _ = trace_msg ctxt
  13.382 @@ -610,14 +665,14 @@
  13.383                    (fn () => "METIS THM: " ^ Metis_Thm.toString fol_th)
  13.384        val _ = trace_msg ctxt
  13.385                    (fn () => "INFERENCE: " ^ Metis_Proof.inferenceToString inf)
  13.386 -      val th = step ctxt mode skolem_params thpairs (fol_th, inf)
  13.387 +      val th = one_step ctxt mode old_skolems sym_tab th_pairs (fol_th, inf)
  13.388                 |> flexflex_first_order
  13.389                 |> resynchronize ctxt fol_th
  13.390        val _ = trace_msg ctxt
  13.391                    (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th)
  13.392        val _ = trace_msg ctxt
  13.393                    (fn () => "=============================================")
  13.394 -    in (fol_th, th) :: thpairs end
  13.395 +    in (fol_th, th) :: th_pairs end
  13.396  
  13.397  (* It is normally sufficient to apply "assume_tac" to unify the conclusion with
  13.398     one of the premises. Unfortunately, this sometimes yields "Variable
    14.1 --- a/src/HOL/Tools/Metis/metis_tactics.ML	Tue May 31 15:45:27 2011 +0200
    14.2 +++ b/src/HOL/Tools/Metis/metis_tactics.ML	Tue May 31 18:13:00 2011 +0200
    14.3 @@ -9,36 +9,42 @@
    14.4  
    14.5  signature METIS_TACTICS =
    14.6  sig
    14.7 +  type type_sys = ATP_Translate.type_sys
    14.8 +
    14.9    val metisN : string
   14.10    val metisF_N : string
   14.11    val metisFT_N : string
   14.12 +  val metisX_N : string
   14.13    val trace : bool Config.T
   14.14    val verbose : bool Config.T
   14.15 -  val type_lits : bool Config.T
   14.16    val new_skolemizer : bool Config.T
   14.17    val metis_tac : Proof.context -> thm list -> int -> tactic
   14.18    val metisF_tac : Proof.context -> thm list -> int -> tactic
   14.19    val metisFT_tac : Proof.context -> thm list -> int -> tactic
   14.20    val metisHO_tac : Proof.context -> thm list -> int -> tactic
   14.21 +  val metisX_tac : Proof.context -> type_sys option -> thm list -> int -> tactic
   14.22    val setup : theory -> theory
   14.23  end
   14.24  
   14.25  structure Metis_Tactics : METIS_TACTICS =
   14.26  struct
   14.27  
   14.28 +open ATP_Translate
   14.29  open Metis_Translate
   14.30  open Metis_Reconstruct
   14.31  
   14.32  fun method_binding_for_mode HO = @{binding metis}
   14.33    | method_binding_for_mode FO = @{binding metisF}
   14.34    | method_binding_for_mode FT = @{binding metisFT}
   14.35 +  | method_binding_for_mode MX = @{binding metisX}
   14.36  
   14.37  val metisN = Binding.qualified_name_of (method_binding_for_mode HO)
   14.38  val metisF_N = Binding.qualified_name_of (method_binding_for_mode FO)
   14.39  val metisFT_N = Binding.qualified_name_of (method_binding_for_mode FT)
   14.40 +val metisX_N = Binding.qualified_name_of (method_binding_for_mode MX)
   14.41  
   14.42 -val type_lits = Attrib.setup_config_bool @{binding metis_type_lits} (K true)
   14.43 -val new_skolemizer = Attrib.setup_config_bool @{binding metis_new_skolemizer} (K false)
   14.44 +val new_skolemizer =
   14.45 +  Attrib.setup_config_bool @{binding metis_new_skolemizer} (K false)
   14.46  
   14.47  fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const);
   14.48  
   14.49 @@ -65,9 +71,8 @@
   14.50  val resolution_params = {active = active_params, waiting = waiting_params}
   14.51  
   14.52  (* Main function to start Metis proof and reconstruction *)
   14.53 -fun FOL_SOLVE (mode :: fallback_modes) ctxt cls ths0 =
   14.54 +fun FOL_SOLVE type_sys (mode :: fallback_modes) ctxt cls ths0 =
   14.55    let val thy = Proof_Context.theory_of ctxt
   14.56 -      val type_lits = Config.get ctxt type_lits
   14.57        val new_skolemizer =
   14.58          Config.get ctxt new_skolemizer orelse null (Meson.choice_theorems thy)
   14.59        val th_cls_pairs =
   14.60 @@ -75,18 +80,14 @@
   14.61                  (Thm.get_name_hint th,
   14.62                   Meson_Clausify.cnf_axiom ctxt new_skolemizer j th))
   14.63               (0 upto length ths0 - 1) ths0
   14.64 -      val thss = map (snd o snd) th_cls_pairs
   14.65 +      val ths = maps (snd o snd) th_cls_pairs
   14.66        val dischargers = map (fst o snd) th_cls_pairs
   14.67        val _ = trace_msg ctxt (fn () => "FOL_SOLVE: CONJECTURE CLAUSES")
   14.68        val _ = app (fn th => trace_msg ctxt (fn () => Display.string_of_thm ctxt th)) cls
   14.69        val _ = trace_msg ctxt (fn () => "THEOREM CLAUSES")
   14.70 -      val _ = app (app (fn th => trace_msg ctxt (fn () => Display.string_of_thm ctxt th))) thss
   14.71 -      val (mode, {axioms, tfrees, old_skolems}) =
   14.72 -        prepare_metis_problem mode ctxt type_lits cls thss
   14.73 -      val _ = if null tfrees then ()
   14.74 -              else (trace_msg ctxt (fn () => "TFREE CLAUSES");
   14.75 -                    app (fn TyLitFree ((s, _), (s', _)) =>
   14.76 -                            trace_msg ctxt (fn () => s ^ "(" ^ s' ^ ")")) tfrees)
   14.77 +      val _ = app (fn th => trace_msg ctxt (fn () => Display.string_of_thm ctxt th)) ths
   14.78 +      val (mode, sym_tab, {axioms, old_skolems, ...}) =
   14.79 +        prepare_metis_problem ctxt mode type_sys cls ths
   14.80        val _ = trace_msg ctxt (fn () => "CLAUSES GIVEN TO METIS")
   14.81        val thms = map #1 axioms
   14.82        val _ = app (fn th => trace_msg ctxt (fn () => Metis_Thm.toString th)) thms
   14.83 @@ -104,8 +105,9 @@
   14.84                  val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
   14.85                               (*add constraints arising from converting goal to clause form*)
   14.86                  val proof = Metis_Proof.proof mth
   14.87 -                val result = fold (replay_one_inference ctxt' mode old_skolems)
   14.88 -                                  proof axioms
   14.89 +                val result =
   14.90 +                  fold (replay_one_inference ctxt' mode old_skolems sym_tab)
   14.91 +                       proof axioms
   14.92                  and used = map_filter (used_axioms axioms) proof
   14.93                  val _ = trace_msg ctxt (fn () => "METIS COMPLETED...clauses actually used:")
   14.94                  val _ = app (fn th => trace_msg ctxt (fn () => Display.string_of_thm ctxt th)) used
   14.95 @@ -145,7 +147,7 @@
   14.96                  ("Falling back on " ^
   14.97                   quote (Binding.qualified_name_of
   14.98                              (method_binding_for_mode mode)) ^ "...");
   14.99 -            FOL_SOLVE fallback_modes ctxt cls ths0)
  14.100 +            FOL_SOLVE type_sys fallback_modes ctxt cls ths0)
  14.101  
  14.102  val neg_clausify =
  14.103    single
  14.104 @@ -164,56 +166,63 @@
  14.105  val type_has_top_sort =
  14.106    exists_subtype (fn TFree (_, []) => true | TVar (_, []) => true | _ => false)
  14.107  
  14.108 -fun generic_metis_tac modes ctxt ths i st0 =
  14.109 +fun generic_metis_tac modes type_sys ctxt ths i st0 =
  14.110    let
  14.111      val _ = trace_msg ctxt (fn () =>
  14.112          "Metis called with theorems " ^
  14.113          cat_lines (map (Display.string_of_thm ctxt) ths))
  14.114 +    fun tac clause = resolve_tac (FOL_SOLVE type_sys modes ctxt clause ths) 1
  14.115    in
  14.116      if exists_type type_has_top_sort (prop_of st0) then
  14.117        (verbose_warning ctxt "Proof state contains the universal sort {}";
  14.118         Seq.empty)
  14.119      else
  14.120 -      Meson.MESON (preskolem_tac ctxt) (maps neg_clausify)
  14.121 -                  (fn cls => resolve_tac (FOL_SOLVE modes ctxt cls ths) 1)
  14.122 -                  ctxt i st0
  14.123 +      Meson.MESON (preskolem_tac ctxt) (maps neg_clausify) tac ctxt i st0
  14.124    end
  14.125  
  14.126  val metis_modes = [HO, FT]
  14.127  val metisF_modes = [FO, FT]
  14.128  val metisFT_modes = [FT]
  14.129  val metisHO_modes = [HO]
  14.130 +val metisX_modes = [MX]
  14.131  
  14.132 -val metis_tac = generic_metis_tac metis_modes
  14.133 -val metisF_tac = generic_metis_tac metisF_modes
  14.134 -val metisFT_tac = generic_metis_tac metisFT_modes
  14.135 -val metisHO_tac = generic_metis_tac metisHO_modes
  14.136 +val metis_tac = generic_metis_tac metis_modes NONE
  14.137 +val metisF_tac = generic_metis_tac metisF_modes NONE
  14.138 +val metisFT_tac = generic_metis_tac metisFT_modes NONE
  14.139 +val metisHO_tac = generic_metis_tac metisHO_modes NONE
  14.140 +fun metisX_tac ctxt type_sys = generic_metis_tac metisX_modes type_sys ctxt
  14.141  
  14.142  (* Whenever "X" has schematic type variables, we treat "using X by metis" as
  14.143 -   "by (metis X)", to prevent "Subgoal.FOCUS" from freezing the type variables.
  14.144 +   "by (metis X)" to prevent "Subgoal.FOCUS" from freezing the type variables.
  14.145     We don't do it for nonschematic facts "X" because this breaks a few proofs
  14.146     (in the rare and subtle case where a proof relied on extensionality not being
  14.147     applied) and brings few benefits. *)
  14.148  val has_tvar =
  14.149    exists_type (exists_subtype (fn TVar _ => true | _ => false)) o prop_of
  14.150  
  14.151 +fun method modes (type_sys, ths) ctxt facts =
  14.152 +  let
  14.153 +    val (schem_facts, nonschem_facts) = List.partition has_tvar facts
  14.154 +    val type_sys = type_sys |> Option.map type_sys_from_string
  14.155 +  in
  14.156 +    HEADGOAL (Method.insert_tac nonschem_facts THEN'
  14.157 +              CHANGED_PROP
  14.158 +              o generic_metis_tac modes type_sys ctxt (schem_facts @ ths))
  14.159 +  end
  14.160 +
  14.161  fun setup_method (modes as mode :: _) =
  14.162    Method.setup (method_binding_for_mode mode)
  14.163 -    (Attrib.thms >> (fn ths => fn ctxt =>
  14.164 -       METHOD (fn facts =>
  14.165 -                  let
  14.166 -                    val (schem_facts, nonschem_facts) =
  14.167 -                      List.partition has_tvar facts
  14.168 -                  in
  14.169 -                    HEADGOAL (Method.insert_tac nonschem_facts THEN'
  14.170 -                              CHANGED_PROP
  14.171 -                              o generic_metis_tac modes ctxt (schem_facts @ ths))
  14.172 -                  end)))
  14.173 +               ((if mode = MX then
  14.174 +                   Scan.lift (Scan.option (Args.parens Parse.short_ident))
  14.175 +                 else
  14.176 +                   Scan.succeed NONE)
  14.177 +                -- Attrib.thms >> (METHOD oo method modes))
  14.178  
  14.179  val setup =
  14.180    [(metis_modes, "Metis for FOL and HOL problems"),
  14.181     (metisF_modes, "Metis for FOL problems"),
  14.182 -   (metisFT_modes, "Metis for FOL/HOL problems with fully-typed translation")]
  14.183 +   (metisFT_modes, "Metis for FOL/HOL problems with fully-typed translation"),
  14.184 +   (metisX_modes, "Metis for FOL and HOL problems (experimental)")]
  14.185    |> fold (uncurry setup_method)
  14.186  
  14.187  end;
    15.1 --- a/src/HOL/Tools/Metis/metis_translate.ML	Tue May 31 15:45:27 2011 +0200
    15.2 +++ b/src/HOL/Tools/Metis/metis_translate.ML	Tue May 31 18:13:00 2011 +0200
    15.3 @@ -9,428 +9,47 @@
    15.4  
    15.5  signature METIS_TRANSLATE =
    15.6  sig
    15.7 -  type name = string * string
    15.8 +  type type_literal = ATP_Translate.type_literal
    15.9 +  type type_sys = ATP_Translate.type_sys
   15.10 +
   15.11 +  datatype mode = FO | HO | FT | MX
   15.12  
   15.13 -  datatype type_literal =
   15.14 -    TyLitVar of name * name |
   15.15 -    TyLitFree of name * name
   15.16 -  datatype arity_literal =
   15.17 -    TConsLit of name * name * name list |
   15.18 -    TVarLit of name * name
   15.19 -  datatype arity_clause =
   15.20 -    ArityClause of
   15.21 -      {name: string,
   15.22 -       prem_lits: arity_literal list,
   15.23 -       concl_lits: arity_literal}
   15.24 -  datatype class_rel_clause =
   15.25 -    ClassRelClause of {name: string, subclass: name, superclass: name}
   15.26 -  datatype combterm =
   15.27 -    CombConst of name * typ * typ list |
   15.28 -    CombVar of name * typ |
   15.29 -    CombApp of combterm * combterm
   15.30 -  datatype fol_literal = FOLLiteral of bool * combterm
   15.31 +  type metis_problem =
   15.32 +    {axioms : (Metis_Thm.thm * thm) list,
   15.33 +     tfrees : type_literal list,
   15.34 +     old_skolems : (string * term) list}
   15.35  
   15.36 -  datatype mode = FO | HO | FT
   15.37 -  type metis_problem =
   15.38 -    {axioms: (Metis_Thm.thm * thm) list,
   15.39 -     tfrees: type_literal list,
   15.40 -     old_skolems: (string * term) list}
   15.41 -
   15.42 +  val metis_equal : string
   15.43 +  val metis_predicator : string
   15.44 +  val metis_app_op : string
   15.45 +  val metis_type_tag : string
   15.46    val metis_generated_var_prefix : string
   15.47 -  val type_tag_name : string
   15.48 -  val bound_var_prefix : string
   15.49 -  val schematic_var_prefix: string
   15.50 -  val fixed_var_prefix: string
   15.51 -  val tvar_prefix: string
   15.52 -  val tfree_prefix: string
   15.53 -  val const_prefix: string
   15.54 -  val type_const_prefix: string
   15.55 -  val class_prefix: string
   15.56 -  val new_skolem_const_prefix : string
   15.57 -  val proxify_const : string -> (int * (string * string)) option
   15.58 -  val invert_const: string -> string
   15.59 -  val unproxify_const: string -> string
   15.60 -  val ascii_of: string -> string
   15.61 -  val unascii_of: string -> string
   15.62 -  val strip_prefix_and_unascii: string -> string -> string option
   15.63 -  val make_bound_var : string -> string
   15.64 -  val make_schematic_var : string * int -> string
   15.65 -  val make_fixed_var : string -> string
   15.66 -  val make_schematic_type_var : string * int -> string
   15.67 -  val make_fixed_type_var : string -> string
   15.68 -  val make_fixed_const : string -> string
   15.69 -  val make_fixed_type_const : string -> string
   15.70 -  val make_type_class : string -> string
   15.71 -  val num_type_args: theory -> string -> int
   15.72 -  val new_skolem_var_name_from_const : string -> string
   15.73 -  val type_literals_for_types : typ list -> type_literal list
   15.74 -  val make_class_rel_clauses :
   15.75 -    theory -> class list -> class list -> class_rel_clause list
   15.76 -  val make_arity_clauses :
   15.77 -    theory -> string list -> class list -> class list * arity_clause list
   15.78 -  val combtyp_of : combterm -> typ
   15.79 -  val strip_combterm_comb : combterm -> combterm * combterm list
   15.80 -  val atyps_of : typ -> typ list
   15.81 -  val combterm_from_term :
   15.82 -    theory -> (string * typ) list -> term -> combterm * typ list
   15.83 +  val metis_name_table : ((string * int) * (string * bool)) list
   15.84    val reveal_old_skolem_terms : (string * term) list -> term -> term
   15.85 -  val tfree_classes_of_terms : term list -> string list
   15.86 -  val tvar_classes_of_terms : term list -> string list
   15.87 -  val type_consts_of_terms : theory -> term list -> string list
   15.88    val string_of_mode : mode -> string
   15.89 -  val metis_helpers : (string * (bool * thm list)) list
   15.90    val prepare_metis_problem :
   15.91 -    mode -> Proof.context -> bool -> thm list -> thm list list
   15.92 -    -> mode * metis_problem
   15.93 +    Proof.context -> mode -> type_sys option -> thm list -> thm list
   15.94 +    -> mode * int Symtab.table * metis_problem
   15.95  end
   15.96  
   15.97  structure Metis_Translate : METIS_TRANSLATE =
   15.98  struct
   15.99  
  15.100 +open ATP_Problem
  15.101 +open ATP_Translate
  15.102 +
  15.103 +val metis_equal = "="
  15.104 +val metis_predicator = "{}"
  15.105 +val metis_app_op = "."
  15.106 +val metis_type_tag = ":"
  15.107  val metis_generated_var_prefix = "_"
  15.108  
  15.109 -val type_tag_name = "ti"
  15.110 -
  15.111 -val bound_var_prefix = "B_"
  15.112 -val schematic_var_prefix = "V_"
  15.113 -val fixed_var_prefix = "v_"
  15.114 -
  15.115 -val tvar_prefix = "T_";
  15.116 -val tfree_prefix = "t_";
  15.117 -
  15.118 -val const_prefix = "c_";
  15.119 -val type_const_prefix = "tc_";
  15.120 -val class_prefix = "class_";
  15.121 -
  15.122 -val skolem_const_prefix = "Sledgehammer" ^ Long_Name.separator ^ "Sko"
  15.123 -val old_skolem_const_prefix = skolem_const_prefix ^ "o"
  15.124 -val new_skolem_const_prefix = skolem_const_prefix ^ "n"
  15.125 -
  15.126 -fun union_all xss = fold (union (op =)) xss []
  15.127 -
  15.128 -val metis_proxies =
  15.129 -  [("c_False",
  15.130 -    (@{const_name False}, (0, ("fFalse", @{const_name Metis.fFalse})))),
  15.131 -   ("c_True", (@{const_name True}, (0, ("fTrue", @{const_name Metis.fTrue})))),
  15.132 -   ("c_Not", (@{const_name Not}, (1, ("fNot", @{const_name Metis.fNot})))),
  15.133 -   ("c_conj", (@{const_name conj}, (2, ("fconj", @{const_name Metis.fconj})))),
  15.134 -   ("c_disj", (@{const_name disj}, (2, ("fdisj", @{const_name Metis.fdisj})))),
  15.135 -   ("c_implies",
  15.136 -    (@{const_name implies}, (2, ("fimplies", @{const_name Metis.fimplies})))),
  15.137 -   ("equal",
  15.138 -    (@{const_name HOL.eq}, (2, ("fequal", @{const_name Metis.fequal}))))]
  15.139 -
  15.140 -val proxify_const = AList.lookup (op =) metis_proxies #> Option.map snd
  15.141 -
  15.142 -(* Readable names for the more common symbolic functions. Do not mess with the
  15.143 -   table unless you know what you are doing. *)
  15.144 -val const_trans_table =
  15.145 -  [(@{type_name Product_Type.prod}, "prod"),
  15.146 -   (@{type_name Sum_Type.sum}, "sum"),
  15.147 -   (@{const_name False}, "False"),
  15.148 -   (@{const_name True}, "True"),
  15.149 -   (@{const_name Not}, "Not"),
  15.150 -   (@{const_name conj}, "conj"),
  15.151 -   (@{const_name disj}, "disj"),
  15.152 -   (@{const_name implies}, "implies"),
  15.153 -   (@{const_name HOL.eq}, "equal"),
  15.154 -   (@{const_name If}, "If"),
  15.155 -   (@{const_name Set.member}, "member"),
  15.156 -   (@{const_name Meson.COMBI}, "COMBI"),
  15.157 -   (@{const_name Meson.COMBK}, "COMBK"),
  15.158 -   (@{const_name Meson.COMBB}, "COMBB"),
  15.159 -   (@{const_name Meson.COMBC}, "COMBC"),
  15.160 -   (@{const_name Meson.COMBS}, "COMBS")]
  15.161 -  |> Symtab.make
  15.162 -  |> fold (Symtab.update o swap o snd o snd o snd) metis_proxies
  15.163 -
  15.164 -(* Invert the table of translations between Isabelle and Metis. *)
  15.165 -val const_trans_table_inv =
  15.166 -  const_trans_table |> Symtab.dest |> map swap |> Symtab.make
  15.167 -val const_trans_table_unprox =
  15.168 -  Symtab.empty
  15.169 -  |> fold (fn (_, (isa, (_, (_, metis)))) => Symtab.update (metis, isa))
  15.170 -          metis_proxies
  15.171 -
  15.172 -val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
  15.173 -val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox)
  15.174 -
  15.175 -(*Escaping of special characters.
  15.176 -  Alphanumeric characters are left unchanged.
  15.177 -  The character _ goes to __
  15.178 -  Characters in the range ASCII space to / go to _A to _P, respectively.
  15.179 -  Other characters go to _nnn where nnn is the decimal ASCII code.*)
  15.180 -val A_minus_space = Char.ord #"A" - Char.ord #" ";
  15.181 -
  15.182 -fun stringN_of_int 0 _ = ""
  15.183 -  | stringN_of_int k n = stringN_of_int (k-1) (n div 10) ^ string_of_int (n mod 10);
  15.184 -
  15.185 -fun ascii_of_c c =
  15.186 -  if Char.isAlphaNum c then String.str c
  15.187 -  else if c = #"_" then "__"
  15.188 -  else if #" " <= c andalso c <= #"/"
  15.189 -       then "_" ^ String.str (Char.chr (Char.ord c + A_minus_space))
  15.190 -  else ("_" ^ stringN_of_int 3 (Char.ord c))  (*fixed width, in case more digits follow*)
  15.191 -
  15.192 -val ascii_of = String.translate ascii_of_c;
  15.193 -
  15.194 -(** Remove ASCII armouring from names in proof files **)
  15.195 -
  15.196 -(*We don't raise error exceptions because this code can run inside the watcher.
  15.197 -  Also, the errors are "impossible" (hah!)*)
  15.198 -fun unascii_aux rcs [] = String.implode(rev rcs)
  15.199 -  | unascii_aux rcs [#"_"] = unascii_aux (#"_"::rcs) []  (*ERROR*)
  15.200 -      (*Three types of _ escapes: __, _A to _P, _nnn*)
  15.201 -  | unascii_aux rcs (#"_" :: #"_" :: cs) = unascii_aux (#"_"::rcs) cs
  15.202 -  | unascii_aux rcs (#"_" :: c :: cs) =
  15.203 -      if #"A" <= c andalso c<= #"P"  (*translation of #" " to #"/"*)
  15.204 -      then unascii_aux (Char.chr(Char.ord c - A_minus_space) :: rcs) cs
  15.205 -      else
  15.206 -        let val digits = List.take (c::cs, 3) handle Subscript => []
  15.207 -        in
  15.208 -            case Int.fromString (String.implode digits) of
  15.209 -                NONE => unascii_aux (c:: #"_"::rcs) cs  (*ERROR*)
  15.210 -              | SOME n => unascii_aux (Char.chr n :: rcs) (List.drop (cs, 2))
  15.211 -        end
  15.212 -  | unascii_aux rcs (c::cs) = unascii_aux (c::rcs) cs
  15.213 -val unascii_of = unascii_aux [] o String.explode
  15.214 -
  15.215 -(* If string s has the prefix s1, return the result of deleting it,
  15.216 -   un-ASCII'd. *)
  15.217 -fun strip_prefix_and_unascii s1 s =
  15.218 -  if String.isPrefix s1 s then
  15.219 -    SOME (unascii_of (String.extract (s, size s1, NONE)))
  15.220 -  else
  15.221 -    NONE
  15.222 -
  15.223 -(*Remove the initial ' character from a type variable, if it is present*)
  15.224 -fun trim_type_var s =
  15.225 -  if s <> "" andalso String.sub(s,0) = #"'" then String.extract(s,1,NONE)
  15.226 -  else raise Fail ("trim_type: Malformed type variable encountered: " ^ s)
  15.227 -
  15.228 -fun ascii_of_indexname (v,0) = ascii_of v
  15.229 -  | ascii_of_indexname (v,i) = ascii_of v ^ "_" ^ string_of_int i;
  15.230 -
  15.231 -fun make_bound_var x = bound_var_prefix ^ ascii_of x
  15.232 -fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
  15.233 -fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
  15.234 -
  15.235 -fun make_schematic_type_var (x,i) =
  15.236 -      tvar_prefix ^ (ascii_of_indexname (trim_type_var x,i));
  15.237 -fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (trim_type_var x));
  15.238 -
  15.239 -fun lookup_const c =
  15.240 -  case Symtab.lookup const_trans_table c of
  15.241 -    SOME c' => c'
  15.242 -  | NONE => ascii_of c
  15.243 -
  15.244 -(* HOL.eq MUST BE "equal" because it's built into ATPs. *)
  15.245 -fun make_fixed_const @{const_name HOL.eq} = "equal"
  15.246 -  | make_fixed_const c = const_prefix ^ lookup_const c
  15.247 -
  15.248 -fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
  15.249 -
  15.250 -fun make_type_class clas = class_prefix ^ ascii_of clas;
  15.251 -
  15.252 -(* The number of type arguments of a constant, zero if it's monomorphic. For
  15.253 -   (instances of) Skolem pseudoconstants, this information is encoded in the
  15.254 -   constant name. *)
  15.255 -fun num_type_args thy s =
  15.256 -  if String.isPrefix skolem_const_prefix s then
  15.257 -    s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the
  15.258 -  else
  15.259 -    (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length
  15.260 -
  15.261 -fun new_skolem_var_name_from_const s =
  15.262 -  let val ss = s |> space_explode Long_Name.separator in
  15.263 -    nth ss (length ss - 2)
  15.264 -  end
  15.265 -
  15.266 -
  15.267 -(**** Definitions and functions for FOL clauses for TPTP format output ****)
  15.268 -
  15.269 -type name = string * string
  15.270 -
  15.271 -(**** Isabelle FOL clauses ****)
  15.272 -
  15.273 -(* The first component is the type class; the second is a TVar or TFree. *)
  15.274 -datatype type_literal =
  15.275 -  TyLitVar of name * name |
  15.276 -  TyLitFree of name * name
  15.277 -
  15.278 -(*Make literals for sorted type variables*)
  15.279 -fun sorts_on_typs_aux (_, [])   = []
  15.280 -  | sorts_on_typs_aux ((x,i),  s::ss) =
  15.281 -      let val sorts = sorts_on_typs_aux ((x,i), ss)
  15.282 -      in
  15.283 -          if s = the_single @{sort HOL.type} then sorts
  15.284 -          else if i = ~1 then TyLitFree (`make_type_class s, `make_fixed_type_var x) :: sorts
  15.285 -          else TyLitVar (`make_type_class s, (make_schematic_type_var (x,i), x)) :: sorts
  15.286 -      end;
  15.287 -
  15.288 -fun sorts_on_typs (TFree (a,s)) = sorts_on_typs_aux ((a,~1),s)
  15.289 -  | sorts_on_typs (TVar (v,s))  = sorts_on_typs_aux (v,s);
  15.290 -
  15.291 -(*Given a list of sorted type variables, return a list of type literals.*)
  15.292 -fun type_literals_for_types Ts =
  15.293 -  fold (union (op =)) (map sorts_on_typs Ts) []
  15.294 -
  15.295 -(** make axiom and conjecture clauses. **)
  15.296 -
  15.297 -(**** Isabelle arities ****)
  15.298 -
  15.299 -datatype arity_literal =
  15.300 -  TConsLit of name * name * name list |
  15.301 -  TVarLit of name * name
  15.302 -
  15.303 -datatype arity_clause =
  15.304 -  ArityClause of
  15.305 -    {name: string,
  15.306 -     prem_lits: arity_literal list,
  15.307 -     concl_lits: arity_literal}
  15.308 -
  15.309 -fun gen_TVars 0 = []
  15.310 -  | gen_TVars n = ("T_" ^ string_of_int n) :: gen_TVars (n-1);
  15.311 -
  15.312 -fun pack_sort(_,[])  = []
  15.313 -  | pack_sort(tvar, "HOL.type"::srt) = pack_sort (tvar, srt)   (*IGNORE sort "type"*)
  15.314 -  | pack_sort(tvar, cls::srt) =
  15.315 -    (`make_type_class cls, `I tvar) :: pack_sort (tvar, srt)
  15.316 -
  15.317 -(*Arity of type constructor tcon :: (arg1,...,argN)res*)
  15.318 -fun make_axiom_arity_clause (tcons, name, (cls,args)) =
  15.319 -  let
  15.320 -    val tvars = gen_TVars (length args)
  15.321 -    val tvars_srts = ListPair.zip (tvars, args)
  15.322 -  in
  15.323 -    ArityClause {name = name,
  15.324 -                 prem_lits = map TVarLit (union_all (map pack_sort tvars_srts)),
  15.325 -                 concl_lits = TConsLit (`make_type_class cls,
  15.326 -                                        `make_fixed_type_const tcons,
  15.327 -                                        tvars ~~ tvars)}
  15.328 -  end
  15.329 -
  15.330 -
  15.331 -(**** Isabelle class relations ****)
  15.332 -
  15.333 -datatype class_rel_clause =
  15.334 -  ClassRelClause of {name: string, subclass: name, superclass: name}
  15.335 -
  15.336 -(*Generate all pairs (sub,super) such that sub is a proper subclass of super in theory thy.*)
  15.337 -fun class_pairs _ [] _ = []
  15.338 -  | class_pairs thy subs supers =
  15.339 -      let
  15.340 -        val class_less = Sorts.class_less (Sign.classes_of thy)
  15.341 -        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
  15.342 -        fun add_supers sub = fold (add_super sub) supers
  15.343 -      in fold add_supers subs [] end
  15.344 -
  15.345 -fun make_class_rel_clause (sub,super) =
  15.346 -  ClassRelClause {name = sub ^ "_" ^ super,
  15.347 -                  subclass = `make_type_class sub,
  15.348 -                  superclass = `make_type_class super}
  15.349 -
  15.350 -fun make_class_rel_clauses thy subs supers =
  15.351 -  map make_class_rel_clause (class_pairs thy subs supers);
  15.352 -
  15.353 -
  15.354 -(** Isabelle arities **)
  15.355 -
  15.356 -fun arity_clause _ _ (_, []) = []
  15.357 -  | arity_clause seen n (tcons, ("HOL.type",_)::ars) =  (*ignore*)
  15.358 -      arity_clause seen n (tcons,ars)
  15.359 -  | arity_clause seen n (tcons, (ar as (class,_)) :: ars) =
  15.360 -      if member (op =) seen class then (*multiple arities for the same tycon, class pair*)
  15.361 -          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class ^ "_" ^ string_of_int n, ar) ::
  15.362 -          arity_clause seen (n+1) (tcons,ars)
  15.363 -      else
  15.364 -          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class, ar) ::
  15.365 -          arity_clause (class::seen) n (tcons,ars)
  15.366 -
  15.367 -fun multi_arity_clause [] = []
  15.368 -  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
  15.369 -      arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
  15.370 -
  15.371 -(*Generate all pairs (tycon,class,sorts) such that tycon belongs to class in theory thy
  15.372 -  provided its arguments have the corresponding sorts.*)
  15.373 -fun type_class_pairs thy tycons classes =
  15.374 -  let val alg = Sign.classes_of thy
  15.375 -      fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
  15.376 -      fun add_class tycon class =
  15.377 -        cons (class, domain_sorts tycon class)
  15.378 -        handle Sorts.CLASS_ERROR _ => I
  15.379 -      fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
  15.380 -  in  map try_classes tycons  end;
  15.381 -
  15.382 -(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  15.383 -fun iter_type_class_pairs _ _ [] = ([], [])
  15.384 -  | iter_type_class_pairs thy tycons classes =
  15.385 -      let val cpairs = type_class_pairs thy tycons classes
  15.386 -          val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs)))
  15.387 -            |> subtract (op =) classes |> subtract (op =) HOLogic.typeS
  15.388 -          val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  15.389 -      in (union (op =) classes' classes, union (op =) cpairs' cpairs) end;
  15.390 -
  15.391 -fun make_arity_clauses thy tycons =
  15.392 -  iter_type_class_pairs thy tycons ##> multi_arity_clause
  15.393 -
  15.394 -datatype combterm =
  15.395 -  CombConst of name * typ * typ list (* Const and Free *) |
  15.396 -  CombVar of name * typ |
  15.397 -  CombApp of combterm * combterm
  15.398 -
  15.399 -datatype fol_literal = FOLLiteral of bool * combterm
  15.400 -
  15.401 -(*********************************************************************)
  15.402 -(* convert a clause with type Term.term to a clause with type clause *)
  15.403 -(*********************************************************************)
  15.404 -
  15.405 -fun combtyp_of (CombConst (_, T, _)) = T
  15.406 -  | combtyp_of (CombVar (_, T)) = T
  15.407 -  | combtyp_of (CombApp (t1, _)) = snd (dest_funT (combtyp_of t1))
  15.408 -
  15.409 -(*gets the head of a combinator application, along with the list of arguments*)
  15.410 -fun strip_combterm_comb u =
  15.411 -    let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
  15.412 -        |   stripc  x =  x
  15.413 -    in stripc(u,[]) end
  15.414 -
  15.415 -fun atyps_of T = fold_atyps (insert (op =)) T []
  15.416 -
  15.417 -fun new_skolem_const_name s num_T_args =
  15.418 -  [new_skolem_const_prefix, s, string_of_int num_T_args]
  15.419 -  |> space_implode Long_Name.separator
  15.420 -
  15.421 -(* Converts a term (with combinators) into a combterm. Also accumulates sort
  15.422 -   infomation. *)
  15.423 -fun combterm_from_term thy bs (P $ Q) =
  15.424 -    let
  15.425 -      val (P', P_atomics_Ts) = combterm_from_term thy bs P
  15.426 -      val (Q', Q_atomics_Ts) = combterm_from_term thy bs Q
  15.427 -    in (CombApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end
  15.428 -  | combterm_from_term thy _ (Const (c, T)) =
  15.429 -    let
  15.430 -      val tvar_list =
  15.431 -        (if String.isPrefix old_skolem_const_prefix c then
  15.432 -           [] |> Term.add_tvarsT T |> map TVar
  15.433 -         else
  15.434 -           (c, T) |> Sign.const_typargs thy)
  15.435 -      val c' = CombConst (`make_fixed_const c, T, tvar_list)
  15.436 -    in (c', atyps_of T) end
  15.437 -  | combterm_from_term _ _ (Free (v, T)) =
  15.438 -    (CombConst (`make_fixed_var v, T, []), atyps_of T)
  15.439 -  | combterm_from_term _ _ (Var (v as (s, _), T)) =
  15.440 -    (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
  15.441 -       let
  15.442 -         val Ts = T |> strip_type |> swap |> op ::
  15.443 -         val s' = new_skolem_const_name s (length Ts)
  15.444 -       in CombConst (`make_fixed_const s', T, Ts) end
  15.445 -     else
  15.446 -       CombVar ((make_schematic_var v, s), T), atyps_of T)
  15.447 -  | combterm_from_term _ bs (Bound j) =
  15.448 -    nth bs j
  15.449 -    |> (fn (s, T) => (CombConst (`make_bound_var s, T, []), atyps_of T))
  15.450 -  | combterm_from_term _ _ (Abs _) = raise Fail "HOL clause: Abs"
  15.451 +val metis_name_table =
  15.452 +  [((tptp_equal, 2), (metis_equal, false)),
  15.453 +   ((tptp_old_equal, 2), (metis_equal, false)),
  15.454 +   ((const_prefix ^ predicator_name, 1), (metis_predicator, false)),
  15.455 +   ((const_prefix ^ app_op_name, 2), (metis_app_op, false)),
  15.456 +   ((const_prefix ^ type_tag_name, 2), (metis_type_tag, true))]
  15.457  
  15.458  fun predicate_of thy ((@{const Not} $ P), pos) = predicate_of thy (P, not pos)
  15.459    | predicate_of thy (t, pos) =
  15.460 @@ -442,7 +61,7 @@
  15.461      literals_of_term1 (literals_of_term1 args thy P) thy Q
  15.462    | literals_of_term1 (lits, ts) thy P =
  15.463      let val ((pred, ts'), pol) = predicate_of thy (P, true) in
  15.464 -      (FOLLiteral (pol, pred) :: lits, union (op =) ts ts')
  15.465 +      ((pol, pred) :: lits, union (op =) ts ts')
  15.466      end
  15.467  val literals_of_term = literals_of_term1 ([], [])
  15.468  
  15.469 @@ -491,52 +110,17 @@
  15.470                 | t => t)
  15.471  
  15.472  
  15.473 -(***************************************************************)
  15.474 -(* Type Classes Present in the Axiom or Conjecture Clauses     *)
  15.475 -(***************************************************************)
  15.476 -
  15.477 -fun set_insert (x, s) = Symtab.update (x, ()) s
  15.478 -
  15.479 -fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
  15.480 -
  15.481 -(*Remove this trivial type class*)
  15.482 -fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset;
  15.483 -
  15.484 -fun tfree_classes_of_terms ts =
  15.485 -  let val sorts_list = map (map #2 o OldTerm.term_tfrees) ts
  15.486 -  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  15.487 -
  15.488 -fun tvar_classes_of_terms ts =
  15.489 -  let val sorts_list = map (map #2 o OldTerm.term_tvars) ts
  15.490 -  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  15.491 -
  15.492 -(*fold type constructors*)
  15.493 -fun fold_type_consts f (Type (a, Ts)) x = fold (fold_type_consts f) Ts (f (a,x))
  15.494 -  | fold_type_consts _ _ x = x;
  15.495 -
  15.496 -(*Type constructors used to instantiate overloaded constants are the only ones needed.*)
  15.497 -fun add_type_consts_in_term thy =
  15.498 -  let
  15.499 -    fun aux (Const (@{const_name Meson.skolem}, _) $ _) = I
  15.500 -      | aux (t $ u) = aux t #> aux u
  15.501 -      | aux (Const x) =
  15.502 -        fold (fold_type_consts set_insert) (Sign.const_typargs thy x)
  15.503 -      | aux (Abs (_, _, u)) = aux u
  15.504 -      | aux _ = I
  15.505 -  in aux end
  15.506 -
  15.507 -fun type_consts_of_terms thy ts =
  15.508 -  Symtab.keys (fold (add_type_consts_in_term thy) ts Symtab.empty);
  15.509 -
  15.510  (* ------------------------------------------------------------------------- *)
  15.511  (* HOL to FOL  (Isabelle to Metis)                                           *)
  15.512  (* ------------------------------------------------------------------------- *)
  15.513  
  15.514 -datatype mode = FO | HO | FT  (* first-order, higher-order, fully-typed *)
  15.515 +(* first-order, higher-order, fully-typed, mode X (fleXible) *)
  15.516 +datatype mode = FO | HO | FT | MX
  15.517  
  15.518  fun string_of_mode FO = "FO"
  15.519    | string_of_mode HO = "HO"
  15.520    | string_of_mode FT = "FT"
  15.521 +  | string_of_mode MX = "MX"
  15.522  
  15.523  fun fn_isa_to_met_sublevel "equal" = "c_fequal"
  15.524    | fn_isa_to_met_sublevel "c_False" = "c_fFalse"
  15.525 @@ -547,7 +131,7 @@
  15.526    | fn_isa_to_met_sublevel "c_implies" = "c_fimplies"
  15.527    | fn_isa_to_met_sublevel x = x
  15.528  
  15.529 -fun fn_isa_to_met_toplevel "equal" = "="
  15.530 +fun fn_isa_to_met_toplevel "equal" = metis_equal
  15.531    | fn_isa_to_met_toplevel x = x
  15.532  
  15.533  fun metis_lit b c args = (b, (c, args));
  15.534 @@ -572,39 +156,40 @@
  15.535      | _ => raise Fail "non-first-order combterm"
  15.536  
  15.537  fun hol_term_to_fol_HO (CombConst ((a, _), _, Ts)) =
  15.538 -      Metis_Term.Fn (fn_isa_to_met_sublevel a, map metis_term_from_typ Ts)
  15.539 +    Metis_Term.Fn (fn_isa_to_met_sublevel a, map metis_term_from_typ Ts)
  15.540    | hol_term_to_fol_HO (CombVar ((s, _), _)) = Metis_Term.Var s
  15.541    | hol_term_to_fol_HO (CombApp (tm1, tm2)) =
  15.542 -       Metis_Term.Fn (".", map hol_term_to_fol_HO [tm1, tm2]);
  15.543 +    Metis_Term.Fn (metis_app_op, map hol_term_to_fol_HO [tm1, tm2])
  15.544  
  15.545  (*The fully-typed translation, to avoid type errors*)
  15.546  fun tag_with_type tm T =
  15.547 -  Metis_Term.Fn (type_tag_name, [tm, metis_term_from_typ T])
  15.548 +  Metis_Term.Fn (metis_type_tag, [tm, metis_term_from_typ T])
  15.549  
  15.550  fun hol_term_to_fol_FT (CombVar ((s, _), ty)) =
  15.551      tag_with_type (Metis_Term.Var s) ty
  15.552    | hol_term_to_fol_FT (CombConst ((a, _), ty, _)) =
  15.553      tag_with_type (Metis_Term.Fn (fn_isa_to_met_sublevel a, [])) ty
  15.554    | hol_term_to_fol_FT (tm as CombApp (tm1,tm2)) =
  15.555 -    tag_with_type (Metis_Term.Fn (".", map hol_term_to_fol_FT [tm1, tm2]))
  15.556 -                  (combtyp_of tm)
  15.557 +    tag_with_type
  15.558 +        (Metis_Term.Fn (metis_app_op, map hol_term_to_fol_FT [tm1, tm2]))
  15.559 +        (combtyp_of tm)
  15.560  
  15.561 -fun hol_literal_to_fol FO (FOLLiteral (pos, tm)) =
  15.562 +fun hol_literal_to_fol FO (pos, tm) =
  15.563        let
  15.564          val (CombConst((p, _), _, Ts), tms) = strip_combterm_comb tm
  15.565          val tylits = if p = "equal" then [] else map metis_term_from_typ Ts
  15.566          val lits = map hol_term_to_fol_FO tms
  15.567        in metis_lit pos (fn_isa_to_met_toplevel p) (tylits @ lits) end
  15.568 -  | hol_literal_to_fol HO (FOLLiteral (pos, tm)) =
  15.569 +  | hol_literal_to_fol HO (pos, tm) =
  15.570       (case strip_combterm_comb tm of
  15.571            (CombConst(("equal", _), _, _), tms) =>
  15.572 -            metis_lit pos "=" (map hol_term_to_fol_HO tms)
  15.573 -        | _ => metis_lit pos "{}" [hol_term_to_fol_HO tm])   (*hBOOL*)
  15.574 -  | hol_literal_to_fol FT (FOLLiteral (pos, tm)) =
  15.575 +            metis_lit pos metis_equal (map hol_term_to_fol_HO tms)
  15.576 +        | _ => metis_lit pos metis_predicator [hol_term_to_fol_HO tm])
  15.577 +  | hol_literal_to_fol FT (pos, tm) =
  15.578       (case strip_combterm_comb tm of
  15.579            (CombConst(("equal", _), _, _), tms) =>
  15.580 -            metis_lit pos "=" (map hol_term_to_fol_FT tms)
  15.581 -        | _ => metis_lit pos "{}" [hol_term_to_fol_FT tm])   (*hBOOL*);
  15.582 +            metis_lit pos metis_equal (map hol_term_to_fol_FT tms)
  15.583 +        | _ => metis_lit pos metis_predicator [hol_term_to_fol_FT tm])
  15.584  
  15.585  fun literals_of_hol_term thy mode t =
  15.586    let val (lits, types_sorts) = literals_of_term thy t in
  15.587 @@ -624,7 +209,7 @@
  15.588  fun metis_of_tfree tf =
  15.589    Metis_Thm.axiom (Metis_LiteralSet.singleton (metis_of_type_literals true tf));
  15.590  
  15.591 -fun hol_thm_to_fol is_conjecture ctxt type_lits mode j old_skolems th =
  15.592 +fun hol_thm_to_fol is_conjecture ctxt mode j old_skolems th =
  15.593    let
  15.594      val thy = Proof_Context.theory_of ctxt
  15.595      val (old_skolems, (mlits, types_sorts)) =
  15.596 @@ -634,61 +219,26 @@
  15.597    in
  15.598      if is_conjecture then
  15.599        (Metis_Thm.axiom (Metis_LiteralSet.fromList mlits),
  15.600 -       type_literals_for_types types_sorts, old_skolems)
  15.601 +       raw_type_literals_for_types types_sorts, old_skolems)
  15.602      else
  15.603        let
  15.604          val tylits = types_sorts |> filter_out (has_default_sort ctxt)
  15.605 -                                 |> type_literals_for_types
  15.606 -        val mtylits =
  15.607 -          if type_lits then map (metis_of_type_literals false) tylits else []
  15.608 +                                 |> raw_type_literals_for_types
  15.609 +        val mtylits = map (metis_of_type_literals false) tylits
  15.610        in
  15.611          (Metis_Thm.axiom (Metis_LiteralSet.fromList(mtylits @ mlits)), [],
  15.612           old_skolems)
  15.613        end
  15.614    end;
  15.615  
  15.616 -(* The Boolean indicates that a fairly sound type encoding is needed. *)
  15.617 -val metis_helpers =
  15.618 -  [("COMBI", (false, @{thms Meson.COMBI_def})),
  15.619 -   ("COMBK", (false, @{thms Meson.COMBK_def})),
  15.620 -   ("COMBB", (false, @{thms Meson.COMBB_def})),
  15.621 -   ("COMBC", (false, @{thms Meson.COMBC_def})),
  15.622 -   ("COMBS", (false, @{thms Meson.COMBS_def})),
  15.623 -   ("fequal",
  15.624 -    (* This is a lie: Higher-order equality doesn't need a sound type encoding.
  15.625 -       However, this is done so for backward compatibility: Including the
  15.626 -       equality helpers by default in Metis breaks a few existing proofs. *)
  15.627 -    (true, @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1]
  15.628 -                  fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]})),
  15.629 -   ("fFalse", (true, @{thms True_or_False})),
  15.630 -   ("fFalse", (false, [@{lemma "~ fFalse" by (unfold fFalse_def) fast}])),
  15.631 -   ("fTrue", (true, @{thms True_or_False})),
  15.632 -   ("fTrue", (false, [@{lemma "fTrue" by (unfold fTrue_def) fast}])),
  15.633 -   ("fNot",
  15.634 -    (false, @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1]
  15.635 -                   fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]})),
  15.636 -   ("fconj",
  15.637 -    (false,
  15.638 -     @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q"
  15.639 -         by (unfold fconj_def) fast+})),
  15.640 -   ("fdisj",
  15.641 -    (false,
  15.642 -     @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q"
  15.643 -         by (unfold fdisj_def) fast+})),
  15.644 -   ("fimplies",
  15.645 -    (false, @{lemma "P | fimplies P Q" "~ Q | fimplies P Q"
  15.646 -                    "~ fimplies P Q | ~ P | Q"
  15.647 -                by (unfold fimplies_def) fast+})),
  15.648 -   ("If", (true, @{thms if_True if_False True_or_False}))]
  15.649 -
  15.650  (* ------------------------------------------------------------------------- *)
  15.651  (* Logic maps manage the interface between HOL and first-order logic.        *)
  15.652  (* ------------------------------------------------------------------------- *)
  15.653  
  15.654  type metis_problem =
  15.655 -  {axioms: (Metis_Thm.thm * thm) list,
  15.656 -   tfrees: type_literal list,
  15.657 -   old_skolems: (string * term) list}
  15.658 +  {axioms : (Metis_Thm.thm * thm) list,
  15.659 +   tfrees : type_literal list,
  15.660 +   old_skolems : (string * term) list}
  15.661  
  15.662  fun is_quasi_fol_clause thy =
  15.663    Meson.is_fol_term thy o snd o conceal_old_skolem_terms ~1 [] o prop_of
  15.664 @@ -697,21 +247,9 @@
  15.665  fun init_tfrees ctxt =
  15.666    let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts in
  15.667      Vartab.fold add (#2 (Variable.constraints_of ctxt)) []
  15.668 -    |> type_literals_for_types
  15.669 +    |> raw_type_literals_for_types
  15.670    end;
  15.671  
  15.672 -(*Insert non-logical axioms corresponding to all accumulated TFrees*)
  15.673 -fun add_tfrees {axioms, tfrees, old_skolems} : metis_problem =
  15.674 -     {axioms = map (rpair TrueI o metis_of_tfree) (distinct (op =) tfrees) @
  15.675 -               axioms,
  15.676 -      tfrees = tfrees, old_skolems = old_skolems}
  15.677 -
  15.678 -(*transform isabelle type / arity clause to metis clause *)
  15.679 -fun add_type_thm [] lmap = lmap
  15.680 -  | add_type_thm ((ith, mth) :: cls) {axioms, tfrees, old_skolems} =
  15.681 -      add_type_thm cls {axioms = (mth, ith) :: axioms, tfrees = tfrees,
  15.682 -                        old_skolems = old_skolems}
  15.683 -
  15.684  fun const_in_metis c (pred, tm_list) =
  15.685    let
  15.686      fun in_mterm (Metis_Term.Var _) = false
  15.687 @@ -725,57 +263,121 @@
  15.688    | m_arity_cls (TVarLit ((c, _), (s, _))) =
  15.689      metis_lit false c [Metis_Term.Var s]
  15.690  (*TrueI is returned as the Isabelle counterpart because there isn't any.*)
  15.691 -fun arity_cls (ArityClause {prem_lits, concl_lits, ...}) =
  15.692 +fun arity_cls ({prem_lits, concl_lits, ...} : arity_clause) =
  15.693    (TrueI,
  15.694     Metis_Thm.axiom (Metis_LiteralSet.fromList
  15.695                          (map m_arity_cls (concl_lits :: prem_lits))));
  15.696  
  15.697  (* CLASSREL CLAUSE *)
  15.698  fun m_class_rel_cls (subclass, _) (superclass, _) =
  15.699 -  [metis_lit false subclass [Metis_Term.Var "T"], metis_lit true superclass [Metis_Term.Var "T"]];
  15.700 -fun class_rel_cls (ClassRelClause {subclass, superclass, ...}) =
  15.701 -  (TrueI, Metis_Thm.axiom (Metis_LiteralSet.fromList (m_class_rel_cls subclass superclass)));
  15.702 +  [metis_lit false subclass [Metis_Term.Var "T"],
  15.703 +   metis_lit true superclass [Metis_Term.Var "T"]]
  15.704 +fun class_rel_cls ({subclass, superclass, ...} : class_rel_clause) =
  15.705 +  (TrueI, m_class_rel_cls subclass superclass
  15.706 +          |> Metis_LiteralSet.fromList |> Metis_Thm.axiom)
  15.707  
  15.708  fun type_ext thy tms =
  15.709 -  let val subs = tfree_classes_of_terms tms
  15.710 -      val supers = tvar_classes_of_terms tms
  15.711 -      val tycons = type_consts_of_terms thy tms
  15.712 -      val (supers', arity_clauses) = make_arity_clauses thy tycons supers
  15.713 -      val class_rel_clauses = make_class_rel_clauses thy subs supers'
  15.714 -  in  map class_rel_cls class_rel_clauses @ map arity_cls arity_clauses
  15.715 -  end;
  15.716 +  let
  15.717 +    val subs = tfree_classes_of_terms tms
  15.718 +    val supers = tvar_classes_of_terms tms
  15.719 +    val tycons = type_consts_of_terms thy tms
  15.720 +    val (supers', arity_clauses) = make_arity_clauses thy tycons supers
  15.721 +    val class_rel_clauses = make_class_rel_clauses thy subs supers'
  15.722 +  in map class_rel_cls class_rel_clauses @ map arity_cls arity_clauses end
  15.723 +
  15.724 +fun metis_name_from_atp s ary =
  15.725 +  AList.lookup (op =) metis_name_table (s, ary) |> the_default (s, false)
  15.726 +fun metis_term_from_atp (ATerm (s, tms)) =
  15.727 +  if is_tptp_variable s then
  15.728 +    Metis_Term.Var s
  15.729 +  else
  15.730 +    let val (s, swap) = metis_name_from_atp s (length tms) in
  15.731 +      Metis_Term.Fn (s, tms |> map metis_term_from_atp |> swap ? rev)
  15.732 +    end
  15.733 +fun metis_atom_from_atp (AAtom tm) =
  15.734 +    (case metis_term_from_atp tm of
  15.735 +       Metis_Term.Fn x => x
  15.736 +     | _ => raise Fail "non CNF -- expected function")
  15.737 +  | metis_atom_from_atp _ = raise Fail "not CNF -- expected atom"
  15.738 +fun metis_literal_from_atp (AConn (ANot, [phi])) =
  15.739 +    (false, metis_atom_from_atp phi)
  15.740 +  | metis_literal_from_atp phi = (true, metis_atom_from_atp phi)
  15.741 +fun metis_literals_from_atp (AConn (AOr, [phi1, phi2])) =
  15.742 +    uncurry (union (op =)) (pairself metis_literals_from_atp (phi1, phi2))
  15.743 +  | metis_literals_from_atp phi = [metis_literal_from_atp phi]
  15.744 +fun metis_axiom_from_atp clauses (Formula (ident, _, phi, _, _)) =
  15.745 +    (phi |> metis_literals_from_atp |> Metis_LiteralSet.fromList
  15.746 +         |> Metis_Thm.axiom,
  15.747 +     case try (unprefix conjecture_prefix) ident of
  15.748 +       SOME s => Meson.make_meta_clause (nth clauses (the (Int.fromString s)))
  15.749 +     | NONE => TrueI)
  15.750 +  | metis_axiom_from_atp _ _ = raise Fail "not CNF -- expected formula"
  15.751 +
  15.752 +val default_type_sys = Preds (Polymorphic, Nonmonotonic_Types, Light)
  15.753  
  15.754  (* Function to generate metis clauses, including comb and type clauses *)
  15.755 -fun prepare_metis_problem mode0 ctxt type_lits cls thss =
  15.756 -  let val thy = Proof_Context.theory_of ctxt
  15.757 -      (*The modes FO and FT are sticky. HO can be downgraded to FO.*)
  15.758 -      fun set_mode FO = FO
  15.759 -        | set_mode HO =
  15.760 -          if forall (forall (is_quasi_fol_clause thy)) (cls :: thss) then FO
  15.761 -          else HO
  15.762 -        | set_mode FT = FT
  15.763 -      val mode = set_mode mode0
  15.764 -      (*transform isabelle clause to metis clause *)
  15.765 +fun prepare_metis_problem ctxt MX type_sys conj_clauses fact_clauses =
  15.766 +    let
  15.767 +      val type_sys = type_sys |> the_default default_type_sys
  15.768 +      val explicit_apply = NONE
  15.769 +      val clauses =
  15.770 +        conj_clauses @ fact_clauses
  15.771 +        |> (if polymorphism_of_type_sys type_sys = Polymorphic then
  15.772 +              I
  15.773 +            else
  15.774 +              map (pair 0)
  15.775 +              #> rpair ctxt
  15.776 +              #-> Monomorph.monomorph Monomorph.all_schematic_consts_of
  15.777 +              #> fst #> maps (map snd))
  15.778 +      val (atp_problem, _, _, _, _, _, sym_tab) =
  15.779 +        prepare_atp_problem ctxt CNF Hypothesis Axiom type_sys explicit_apply
  15.780 +                            false false (map prop_of clauses) @{prop False} []
  15.781 +      val axioms =
  15.782 +        atp_problem
  15.783 +        |> maps (map_filter (try (metis_axiom_from_atp clauses)) o snd)
  15.784 +    in
  15.785 +      (MX, sym_tab,
  15.786 +       {axioms = axioms, tfrees = [], old_skolems = [] (* FIXME ### *)})
  15.787 +    end
  15.788 +  | prepare_metis_problem ctxt mode _ conj_clauses fact_clauses =
  15.789 +    let
  15.790 +      val thy = Proof_Context.theory_of ctxt
  15.791 +      (* The modes FO and FT are sticky. HO can be downgraded to FO. *)
  15.792 +      val mode =
  15.793 +        if mode = HO andalso
  15.794 +           forall (forall (is_quasi_fol_clause thy))
  15.795 +                  [conj_clauses, fact_clauses] then
  15.796 +          FO
  15.797 +        else
  15.798 +          mode
  15.799        fun add_thm is_conjecture (isa_ith, metis_ith)
  15.800                    {axioms, tfrees, old_skolems} : metis_problem =
  15.801          let
  15.802            val (mth, tfree_lits, old_skolems) =
  15.803 -            hol_thm_to_fol is_conjecture ctxt type_lits mode (length axioms)
  15.804 -                           old_skolems metis_ith
  15.805 +            hol_thm_to_fol is_conjecture ctxt mode (length axioms) old_skolems
  15.806 +                           metis_ith
  15.807          in
  15.808 -           {axioms = (mth, isa_ith) :: axioms,
  15.809 -            tfrees = union (op =) tfree_lits tfrees, old_skolems = old_skolems}
  15.810 +          {axioms = (mth, isa_ith) :: axioms,
  15.811 +           tfrees = union (op =) tfree_lits tfrees, old_skolems = old_skolems}
  15.812          end;
  15.813 -      val lmap = {axioms = [], tfrees = init_tfrees ctxt, old_skolems = []}
  15.814 -                 |> fold (add_thm true o `Meson.make_meta_clause) cls
  15.815 -                 |> add_tfrees
  15.816 -                 |> fold (fold (add_thm false o `Meson.make_meta_clause)) thss
  15.817 -      val clause_lists = map (Metis_Thm.clause o #1) (#axioms lmap)
  15.818 +      fun add_type_thm (ith, mth) {axioms, tfrees, old_skolems} =
  15.819 +        {axioms = (mth, ith) :: axioms, tfrees = tfrees,
  15.820 +         old_skolems = old_skolems}
  15.821 +      fun add_tfrees {axioms, tfrees, old_skolems} =
  15.822 +        {axioms =
  15.823 +           map (rpair TrueI o metis_of_tfree) (distinct (op =) tfrees) @ axioms,
  15.824 +         tfrees = tfrees, old_skolems = old_skolems}
  15.825 +      val problem =
  15.826 +        {axioms = [], tfrees = init_tfrees ctxt, old_skolems = []}
  15.827 +        |> fold (add_thm true o `Meson.make_meta_clause) conj_clauses
  15.828 +        |> add_tfrees
  15.829 +        |> fold (add_thm false o `Meson.make_meta_clause) fact_clauses
  15.830 +      val clause_lists = map (Metis_Thm.clause o #1) (#axioms problem)
  15.831        fun is_used c =
  15.832          exists (Metis_LiteralSet.exists (const_in_metis c o #2)) clause_lists
  15.833 -      val lmap =
  15.834 +      val problem =
  15.835          if mode = FO then
  15.836 -          lmap
  15.837 +          problem
  15.838          else
  15.839            let
  15.840              val fdefs = @{thms fFalse_def fTrue_def fNot_def fconj_def fdisj_def
  15.841 @@ -785,14 +387,13 @@
  15.842                #> `(Meson.make_meta_clause
  15.843                     #> rewrite_rule (map safe_mk_meta_eq fdefs))
  15.844              val helper_ths =
  15.845 -              metis_helpers
  15.846 +              helper_table
  15.847                |> filter (is_used o prefix const_prefix o fst)
  15.848                |> maps (fn (_, (needs_full_types, thms)) =>
  15.849                            if needs_full_types andalso mode <> FT then []
  15.850                            else map prepare_helper thms)
  15.851 -          in lmap |> fold (add_thm false) helper_ths end
  15.852 -  in
  15.853 -    (mode, add_type_thm (type_ext thy (maps (map prop_of) (cls :: thss))) lmap)
  15.854 -  end
  15.855 +          in problem |> fold (add_thm false) helper_ths end
  15.856 +      val type_ths = type_ext thy (map prop_of (conj_clauses @ fact_clauses))
  15.857 +    in (mode, Symtab.empty, fold add_type_thm type_ths problem) end
  15.858  
  15.859  end;
    16.1 --- a/src/HOL/Tools/Nitpick/kodkod.ML	Tue May 31 15:45:27 2011 +0200
    16.2 +++ b/src/HOL/Tools/Nitpick/kodkod.ML	Tue May 31 18:13:00 2011 +0200
    16.3 @@ -860,7 +860,7 @@
    16.4           out "solve "; out_outmost_f formula; out ";\n")
    16.5    in
    16.6      out ("// This file was generated by Isabelle (most likely Nitpick)\n" ^
    16.7 -         "// " ^ ATP_Problem.timestamp () ^ "\n");
    16.8 +         "// " ^ ATP_Util.timestamp () ^ "\n");
    16.9      map out_problem problems
   16.10    end
   16.11  
    17.1 --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML	Tue May 31 15:45:27 2011 +0200
    17.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML	Tue May 31 18:13:00 2011 +0200
    17.3 @@ -969,7 +969,7 @@
    17.4                      handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
    17.5                             default_card)
    17.6  
    17.7 -(* Similar to "Sledgehammer_ATP_Translate.tiny_card_of_type". *)
    17.8 +(* Similar to "ATP_Translate.tiny_card_of_type". *)
    17.9  fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card
   17.10                                 assigns T =
   17.11    let
    18.1 --- a/src/HOL/Tools/Nitpick/nitpick_util.ML	Tue May 31 15:45:27 2011 +0200
    18.2 +++ b/src/HOL/Tools/Nitpick/nitpick_util.ML	Tue May 31 18:13:00 2011 +0200
    18.3 @@ -240,7 +240,7 @@
    18.4  
    18.5  val parse_bool_option = Sledgehammer_Util.parse_bool_option
    18.6  val parse_time_option = Sledgehammer_Util.parse_time_option
    18.7 -val string_from_time = Sledgehammer_Util.string_from_time
    18.8 +val string_from_time = ATP_Util.string_from_time
    18.9  
   18.10  val i_subscript = implode o map (prefix "\<^isub>") o raw_explode  (* FIXME Symbol.explode (?) *)
   18.11  fun be_subscript s = "\<^bsub>" ^ s ^ "\<^esub>"
   18.12 @@ -265,15 +265,15 @@
   18.13  
   18.14  val simple_string_of_typ = Refute.string_of_typ
   18.15  val is_real_constr = Refute.is_IDT_constructor
   18.16 -val typ_of_dtyp = Sledgehammer_Util.typ_of_dtyp
   18.17 -val varify_type = Sledgehammer_Util.varify_type
   18.18 -val instantiate_type = Sledgehammer_Util.instantiate_type
   18.19 -val varify_and_instantiate_type = Sledgehammer_Util.varify_and_instantiate_type
   18.20 +val typ_of_dtyp = ATP_Util.typ_of_dtyp
   18.21 +val varify_type = ATP_Util.varify_type
   18.22 +val instantiate_type = ATP_Util.instantiate_type
   18.23 +val varify_and_instantiate_type = ATP_Util.varify_and_instantiate_type
   18.24  val is_of_class_const = Refute.is_const_of_class
   18.25  val get_class_def = Refute.get_classdef
   18.26 -val monomorphic_term = Sledgehammer_Util.monomorphic_term
   18.27 -val specialize_type = Sledgehammer_Util.specialize_type
   18.28 -val eta_expand = Sledgehammer_Util.eta_expand
   18.29 +val monomorphic_term = ATP_Util.monomorphic_term
   18.30 +val specialize_type = ATP_Util.specialize_type
   18.31 +val eta_expand = ATP_Util.eta_expand
   18.32  
   18.33  fun time_limit NONE = I
   18.34    | time_limit (SOME delay) = TimeLimit.timeLimit delay
   18.35 @@ -290,15 +290,15 @@
   18.36  
   18.37  val pstrs = Pretty.breaks o map Pretty.str o space_explode " "
   18.38  
   18.39 -val unyxml = Sledgehammer_Util.unyxml
   18.40 +val unyxml = ATP_Util.unyxml
   18.41  
   18.42 -val maybe_quote = Sledgehammer_Util.maybe_quote
   18.43 +val maybe_quote = ATP_Util.maybe_quote
   18.44  fun pretty_maybe_quote pretty =
   18.45    let val s = Pretty.str_of pretty in
   18.46      if maybe_quote s = s then pretty else Pretty.enum "" "\"" "\"" [pretty]
   18.47    end
   18.48  
   18.49 -val hashw = ATP_Problem.hashw
   18.50 -val hashw_string = ATP_Problem.hashw_string
   18.51 +val hashw = ATP_Util.hashw
   18.52 +val hashw_string = ATP_Util.hashw_string
   18.53  
   18.54  end;
    19.1 --- a/src/HOL/Tools/Nitpick/nitrox.ML	Tue May 31 15:45:27 2011 +0200
    19.2 +++ b/src/HOL/Tools/Nitpick/nitrox.ML	Tue May 31 18:13:00 2011 +0200
    19.3 @@ -13,6 +13,7 @@
    19.4  structure Nitrox : NITROX =
    19.5  struct
    19.6  
    19.7 +open ATP_Util
    19.8  open ATP_Problem
    19.9  open ATP_Proof
   19.10  open Nitpick
    20.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_atp_reconstruct.ML	Tue May 31 15:45:27 2011 +0200
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,1098 +0,0 @@
    20.4 -(*  Title:      HOL/Tools/Sledgehammer/sledgehammer_atp_reconstruct.ML
    20.5 -    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    20.6 -    Author:     Claire Quigley, Cambridge University Computer Laboratory
    20.7 -    Author:     Jasmin Blanchette, TU Muenchen
    20.8 -
    20.9 -Proof reconstruction for Sledgehammer.
   20.10 -*)
   20.11 -
   20.12 -signature SLEDGEHAMMER_ATP_RECONSTRUCT =
   20.13 -sig
   20.14 -  type 'a proof = 'a ATP_Proof.proof
   20.15 -  type locality = Sledgehammer_Filter.locality
   20.16 -  type type_system = Sledgehammer_ATP_Translate.type_system
   20.17 -
   20.18 -  datatype reconstructor =
   20.19 -    Metis |
   20.20 -    MetisFT |
   20.21 -    SMT of string
   20.22 -
   20.23 -  datatype play =
   20.24 -    Played of reconstructor * Time.time |
   20.25 -    Trust_Playable of reconstructor * Time.time option|
   20.26 -    Failed_to_Play
   20.27 -
   20.28 -  type minimize_command = string list -> string
   20.29 -  type one_line_params =
   20.30 -    play * string * (string * locality) list * minimize_command * int * int
   20.31 -  type isar_params =
   20.32 -    bool * bool * int * type_system * string Symtab.table * int list list
   20.33 -    * int * (string * locality) list vector * int Symtab.table * string proof
   20.34 -    * thm
   20.35 -  val repair_conjecture_shape_and_fact_names :
   20.36 -    type_system -> string -> int list list -> int
   20.37 -    -> (string * locality) list vector -> int list
   20.38 -    -> int list list * int * (string * locality) list vector * int list
   20.39 -  val used_facts_in_atp_proof :
   20.40 -    Proof.context -> type_system -> int -> (string * locality) list vector
   20.41 -    -> string proof -> (string * locality) list
   20.42 -  val used_facts_in_unsound_atp_proof :
   20.43 -    Proof.context -> type_system -> int list list -> int
   20.44 -    -> (string * locality) list vector -> 'a proof -> string list option
   20.45 -  val uses_typed_helpers : int list -> 'a proof -> bool
   20.46 -  val reconstructor_name : reconstructor -> string
   20.47 -  val one_line_proof_text : one_line_params -> string
   20.48 -  val isar_proof_text :
   20.49 -    Proof.context -> bool -> isar_params -> one_line_params -> string
   20.50 -  val proof_text :
   20.51 -    Proof.context -> bool -> isar_params -> one_line_params -> string
   20.52 -end;
   20.53 -
   20.54 -structure Sledgehammer_ATP_Reconstruct : SLEDGEHAMMER_ATP_RECONSTRUCT =
   20.55 -struct
   20.56 -
   20.57 -open ATP_Problem
   20.58 -open ATP_Proof
   20.59 -open Metis_Translate
   20.60 -open Sledgehammer_Util
   20.61 -open Sledgehammer_Filter
   20.62 -open Sledgehammer_ATP_Translate
   20.63 -
   20.64 -datatype reconstructor =
   20.65 -  Metis |
   20.66 -  MetisFT |
   20.67 -  SMT of string
   20.68 -
   20.69 -datatype play =
   20.70 -  Played of reconstructor * Time.time |
   20.71 -  Trust_Playable of reconstructor * Time.time option |
   20.72 -  Failed_to_Play
   20.73 -
   20.74 -type minimize_command = string list -> string
   20.75 -type one_line_params =
   20.76 -  play * string * (string * locality) list * minimize_command * int * int
   20.77 -type isar_params =
   20.78 -  bool * bool * int * type_system * string Symtab.table * int list list * int
   20.79 -  * (string * locality) list vector * int Symtab.table * string proof * thm
   20.80 -
   20.81 -fun is_head_digit s = Char.isDigit (String.sub (s, 0))
   20.82 -val scan_integer = Scan.many1 is_head_digit >> (the o Int.fromString o implode)
   20.83 -
   20.84 -val is_typed_helper_name =
   20.85 -  String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix
   20.86 -
   20.87 -fun find_first_in_list_vector vec key =
   20.88 -  Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key
   20.89 -                 | (_, value) => value) NONE vec
   20.90 -
   20.91 -
   20.92 -(** SPASS's FLOTTER hack **)
   20.93 -
   20.94 -(* This is a hack required for keeping track of facts after they have been
   20.95 -   clausified by SPASS's FLOTTER preprocessor. The "ATP/scripts/spass" script is
   20.96 -   also part of this hack. *)
   20.97 -
   20.98 -val set_ClauseFormulaRelationN = "set_ClauseFormulaRelation"
   20.99 -
  20.100 -fun extract_clause_sequence output =
  20.101 -  let
  20.102 -    val tokens_of = String.tokens (not o Char.isAlphaNum)
  20.103 -    fun extract_num ("clause" :: (ss as _ :: _)) = Int.fromString (List.last ss)
  20.104 -      | extract_num _ = NONE
  20.105 -  in output |> split_lines |> map_filter (extract_num o tokens_of) end
  20.106 -
  20.107 -val parse_clause_formula_pair =
  20.108 -  $$ "(" |-- scan_integer --| $$ ","
  20.109 -  -- (Symbol.scan_id ::: Scan.repeat ($$ "," |-- Symbol.scan_id)) --| $$ ")"
  20.110 -  --| Scan.option ($$ ",")
  20.111 -val parse_clause_formula_relation =
  20.112 -  Scan.this_string set_ClauseFormulaRelationN |-- $$ "("
  20.113 -  |-- Scan.repeat parse_clause_formula_pair
  20.114 -val extract_clause_formula_relation =
  20.115 -  Substring.full #> Substring.position set_ClauseFormulaRelationN
  20.116 -  #> snd #> Substring.position "." #> fst #> Substring.string
  20.117 -  #> raw_explode #> filter_out Symbol.is_blank #> parse_clause_formula_relation
  20.118 -  #> fst
  20.119 -
  20.120 -fun maybe_unprefix_fact_number type_sys =
  20.121 -  polymorphism_of_type_sys type_sys <> Polymorphic
  20.122 -  ? (space_implode "_" o tl o space_explode "_")
  20.123 -
  20.124 -fun repair_conjecture_shape_and_fact_names type_sys output conjecture_shape
  20.125 -        fact_offset fact_names typed_helpers =
  20.126 -  if String.isSubstring set_ClauseFormulaRelationN output then
  20.127 -    let
  20.128 -      val j0 = hd (hd conjecture_shape)
  20.129 -      val seq = extract_clause_sequence output
  20.130 -      val name_map = extract_clause_formula_relation output
  20.131 -      fun renumber_conjecture j =
  20.132 -        conjecture_prefix ^ string_of_int (j - j0)
  20.133 -        |> AList.find (fn (s, ss) => member (op =) ss s) name_map
  20.134 -        |> map (fn s => find_index (curry (op =) s) seq + 1)
  20.135 -      fun names_for_number j =
  20.136 -        j |> AList.lookup (op =) name_map |> these
  20.137 -          |> map_filter (try (unascii_of o maybe_unprefix_fact_number type_sys
  20.138 -                              o unprefix fact_prefix))
  20.139 -          |> map (fn name =>
  20.140 -                     (name, name |> find_first_in_list_vector fact_names |> the)
  20.141 -                     handle Option.Option =>
  20.142 -                            error ("No such fact: " ^ quote name ^ "."))
  20.143 -    in
  20.144 -      (conjecture_shape |> map (maps renumber_conjecture), 0,
  20.145 -       seq |> map names_for_number |> Vector.fromList,
  20.146 -       name_map |> filter (forall is_typed_helper_name o snd) |> map fst)
  20.147 -    end
  20.148 -  else
  20.149 -    (conjecture_shape, fact_offset, fact_names, typed_helpers)
  20.150 -
  20.151 -val vampire_step_prefix = "f" (* grrr... *)
  20.152 -
  20.153 -val extract_step_number =
  20.154 -  Int.fromString o perhaps (try (unprefix vampire_step_prefix))
  20.155 -
  20.156 -fun resolve_fact type_sys _ fact_names (_, SOME s) =
  20.157 -    (case try (unprefix fact_prefix) s of
  20.158 -       SOME s' =>
  20.159 -       let val s' = s' |> maybe_unprefix_fact_number type_sys |> unascii_of in
  20.160 -         case find_first_in_list_vector fact_names s' of
  20.161 -           SOME x => [(s', x)]
  20.162 -         | NONE => []
  20.163 -       end
  20.164 -     | NONE => [])
  20.165 -  | resolve_fact _ facts_offset fact_names (num, NONE) =
  20.166 -    (case extract_step_number num of
  20.167 -       SOME j =>
  20.168 -       let val j = j - facts_offset in
  20.169 -         if j > 0 andalso j <= Vector.length fact_names then
  20.170 -           Vector.sub (fact_names, j - 1)
  20.171 -         else
  20.172 -           []
  20.173 -       end
  20.174 -     | NONE => [])
  20.175 -
  20.176 -fun is_fact type_sys conjecture_shape =
  20.177 -  not o null o resolve_fact type_sys 0 conjecture_shape
  20.178 -
  20.179 -fun resolve_conjecture _ (_, SOME s) =
  20.180 -    (case try (unprefix conjecture_prefix) s of
  20.181 -       SOME s' =>
  20.182 -       (case Int.fromString s' of
  20.183 -          SOME j => [j]
  20.184 -        | NONE => [])
  20.185 -     | NONE => [])
  20.186 -  | resolve_conjecture conjecture_shape (num, NONE) =
  20.187 -    case extract_step_number num of
  20.188 -      SOME i => (case find_index (exists (curry (op =) i)) conjecture_shape of
  20.189 -                   ~1 => []
  20.190 -                 | j => [j])
  20.191 -    | NONE => []
  20.192 -
  20.193 -fun is_conjecture conjecture_shape =
  20.194 -  not o null o resolve_conjecture conjecture_shape
  20.195 -
  20.196 -fun is_typed_helper _ (_, SOME s) = is_typed_helper_name s
  20.197 -  | is_typed_helper typed_helpers (num, NONE) =
  20.198 -    (case extract_step_number num of
  20.199 -       SOME i => member (op =) typed_helpers i
  20.200 -     | NONE => false)
  20.201 -
  20.202 -val leo2_ext = "extcnf_equal_neg"
  20.203 -val isa_ext = Thm.get_name_hint @{thm ext}
  20.204 -val isa_short_ext = Long_Name.base_name isa_ext
  20.205 -
  20.206 -fun ext_name ctxt =
  20.207 -  if Thm.eq_thm_prop (@{thm ext},
  20.208 -         singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then
  20.209 -    isa_short_ext
  20.210 -  else
  20.211 -    isa_ext
  20.212 -
  20.213 -fun add_fact _ type_sys facts_offset fact_names (Inference (name, _, [])) =
  20.214 -    union (op =) (resolve_fact type_sys facts_offset fact_names name)
  20.215 -  | add_fact ctxt _ _ _ (Inference (_, _, deps)) =
  20.216 -    if AList.defined (op =) deps leo2_ext then
  20.217 -      insert (op =) (ext_name ctxt, General (* or Chained... *))
  20.218 -    else
  20.219 -      I
  20.220 -  | add_fact _ _ _ _ _ = I
  20.221 -
  20.222 -fun used_facts_in_atp_proof ctxt type_sys facts_offset fact_names atp_proof =
  20.223 -  if null atp_proof then Vector.foldl (op @) [] fact_names
  20.224 -  else fold (add_fact ctxt type_sys facts_offset fact_names) atp_proof []
  20.225 -
  20.226 -fun is_conjecture_referred_to_in_proof conjecture_shape =
  20.227 -  exists (fn Inference (name, _, []) => is_conjecture conjecture_shape name
  20.228 -           | _ => false)
  20.229 -
  20.230 -fun used_facts_in_unsound_atp_proof ctxt type_sys conjecture_shape facts_offset
  20.231 -                                    fact_names atp_proof =
  20.232 -  let
  20.233 -    val used_facts =
  20.234 -      used_facts_in_atp_proof ctxt type_sys facts_offset fact_names atp_proof
  20.235 -  in
  20.236 -    if forall (is_locality_global o snd) used_facts andalso
  20.237 -       not (is_conjecture_referred_to_in_proof conjecture_shape atp_proof) then
  20.238 -      SOME (map fst used_facts)
  20.239 -    else
  20.240 -      NONE
  20.241 -  end
  20.242 -
  20.243 -fun uses_typed_helpers typed_helpers =
  20.244 -  exists (fn Inference (name, _, []) => is_typed_helper typed_helpers name
  20.245 -           | _ => false)
  20.246 -
  20.247 -
  20.248 -(** Soft-core proof reconstruction: Metis one-liner **)
  20.249 -
  20.250 -fun reconstructor_name Metis = "metis"
  20.251 -  | reconstructor_name MetisFT = "metisFT"
  20.252 -  | reconstructor_name (SMT _) = "smt"
  20.253 -
  20.254 -fun reconstructor_settings (SMT settings) = settings
  20.255 -  | reconstructor_settings _ = ""
  20.256 -
  20.257 -fun string_for_label (s, num) = s ^ string_of_int num
  20.258 -
  20.259 -fun show_time NONE = ""
  20.260 -  | show_time (SOME ext_time) = " (" ^ string_from_ext_time ext_time ^ ")"
  20.261 -
  20.262 -fun set_settings "" = ""
  20.263 -  | set_settings settings = "using [[" ^ settings ^ "]] "
  20.264 -fun apply_on_subgoal settings _ 1 = set_settings settings ^ "by "
  20.265 -  | apply_on_subgoal settings 1 _ = set_settings settings ^ "apply "
  20.266 -  | apply_on_subgoal settings i n =
  20.267 -    "prefer " ^ string_of_int i ^ " " ^ apply_on_subgoal settings 1 n
  20.268 -fun command_call name [] = name
  20.269 -  | command_call name args = "(" ^ name ^ " " ^ space_implode " " args ^ ")"
  20.270 -fun try_command_line banner time command =
  20.271 -  banner ^ ": " ^ Markup.markup Markup.sendback command ^ show_time time ^ "."
  20.272 -fun using_labels [] = ""
  20.273 -  | using_labels ls =
  20.274 -    "using " ^ space_implode " " (map string_for_label ls) ^ " "
  20.275 -fun reconstructor_command reconstructor i n (ls, ss) =
  20.276 -  using_labels ls ^
  20.277 -  apply_on_subgoal (reconstructor_settings reconstructor) i n ^
  20.278 -  command_call (reconstructor_name reconstructor) ss
  20.279 -fun minimize_line _ [] = ""
  20.280 -  | minimize_line minimize_command ss =
  20.281 -    case minimize_command ss of
  20.282 -      "" => ""
  20.283 -    | command => "\nTo minimize: " ^ Markup.markup Markup.sendback command ^ "."
  20.284 -
  20.285 -val split_used_facts =
  20.286 -  List.partition (curry (op =) Chained o snd)
  20.287 -  #> pairself (sort_distinct (string_ord o pairself fst))
  20.288 -
  20.289 -fun one_line_proof_text (preplay, banner, used_facts, minimize_command,
  20.290 -                         subgoal, subgoal_count) =
  20.291 -  let
  20.292 -    val (chained, extra) = split_used_facts used_facts
  20.293 -    val (reconstructor, ext_time) =
  20.294 -      case preplay of
  20.295 -        Played (reconstructor, time) =>
  20.296 -        (SOME reconstructor, (SOME (false, time)))
  20.297 -      | Trust_Playable (reconstructor, time) =>
  20.298 -        (SOME reconstructor,
  20.299 -         case time of
  20.300 -           NONE => NONE
  20.301 -         | SOME time =>
  20.302 -           if time = Time.zeroTime then NONE else SOME (true, time))
  20.303 -      | Failed_to_Play => (NONE, NONE)
  20.304 -    val try_line =
  20.305 -      case reconstructor of
  20.306 -        SOME r => ([], map fst extra)
  20.307 -                  |> reconstructor_command r subgoal subgoal_count
  20.308 -                  |> try_command_line banner ext_time
  20.309 -      | NONE => "One-line proof reconstruction failed."
  20.310 -  in try_line ^ minimize_line minimize_command (map fst (extra @ chained)) end
  20.311 -
  20.312 -(** Hard-core proof reconstruction: structured Isar proofs **)
  20.313 -
  20.314 -(* Simple simplifications to ensure that sort annotations don't leave a trail of
  20.315 -   spurious "True"s. *)
  20.316 -fun s_not (Const (@{const_name All}, T) $ Abs (s, T', t')) =
  20.317 -    Const (@{const_name Ex}, T) $ Abs (s, T', s_not t')
  20.318 -  | s_not (Const (@{const_name Ex}, T) $ Abs (s, T', t')) =
  20.319 -    Const (@{const_name All}, T) $ Abs (s, T', s_not t')
  20.320 -  | s_not (@{const HOL.implies} $ t1 $ t2) = @{const HOL.conj} $ t1 $ s_not t2
  20.321 -  | s_not (@{const HOL.conj} $ t1 $ t2) =
  20.322 -    @{const HOL.disj} $ s_not t1 $ s_not t2
  20.323 -  | s_not (@{const HOL.disj} $ t1 $ t2) =
  20.324 -    @{const HOL.conj} $ s_not t1 $ s_not t2
  20.325 -  | s_not (@{const False}) = @{const True}
  20.326 -  | s_not (@{const True}) = @{const False}
  20.327 -  | s_not (@{const Not} $ t) = t
  20.328 -  | s_not t = @{const Not} $ t
  20.329 -fun s_conj (@{const True}, t2) = t2
  20.330 -  | s_conj (t1, @{const True}) = t1
  20.331 -  | s_conj p = HOLogic.mk_conj p
  20.332 -fun s_disj (@{const False}, t2) = t2
  20.333 -  | s_disj (t1, @{const False}) = t1
  20.334 -  | s_disj p = HOLogic.mk_disj p
  20.335 -fun s_imp (@{const True}, t2) = t2
  20.336 -  | s_imp (t1, @{const False}) = s_not t1
  20.337 -  | s_imp p = HOLogic.mk_imp p
  20.338 -fun s_iff (@{const True}, t2) = t2
  20.339 -  | s_iff (t1, @{const True}) = t1
  20.340 -  | s_iff (t1, t2) = HOLogic.eq_const HOLogic.boolT $ t1 $ t2
  20.341 -
  20.342 -fun forall_of v t = HOLogic.all_const (fastype_of v) $ lambda v t
  20.343 -fun exists_of v t = HOLogic.exists_const (fastype_of v) $ lambda v t
  20.344 -
  20.345 -val indent_size = 2
  20.346 -val no_label = ("", ~1)
  20.347 -
  20.348 -val raw_prefix = "X"
  20.349 -val assum_prefix = "A"
  20.350 -val have_prefix = "F"
  20.351 -
  20.352 -fun raw_label_for_name conjecture_shape name =
  20.353 -  case resolve_conjecture conjecture_shape name of
  20.354 -    [j] => (conjecture_prefix, j)
  20.355 -  | _ => case Int.fromString (fst name) of
  20.356 -           SOME j => (raw_prefix, j)
  20.357 -         | NONE => (raw_prefix ^ fst name, 0)
  20.358 -
  20.359 -(**** INTERPRETATION OF TSTP SYNTAX TREES ****)
  20.360 -
  20.361 -exception FO_TERM of string fo_term list
  20.362 -exception FORMULA of (string, string, string fo_term) formula list
  20.363 -exception SAME of unit
  20.364 -
  20.365 -(* Type variables are given the basic sort "HOL.type". Some will later be
  20.366 -   constrained by information from type literals, or by type inference. *)
  20.367 -fun typ_from_fo_term tfrees (u as ATerm (a, us)) =
  20.368 -  let val Ts = map (typ_from_fo_term tfrees) us in
  20.369 -    case strip_prefix_and_unascii type_const_prefix a of
  20.370 -      SOME b => Type (invert_const b, Ts)
  20.371 -    | NONE =>
  20.372 -      if not (null us) then
  20.373 -        raise FO_TERM [u]  (* only "tconst"s have type arguments *)
  20.374 -      else case strip_prefix_and_unascii tfree_prefix a of
  20.375 -        SOME b =>
  20.376 -        let val s = "'" ^ b in
  20.377 -          TFree (s, AList.lookup (op =) tfrees s |> the_default HOLogic.typeS)
  20.378 -        end
  20.379 -      | NONE =>
  20.380 -        case strip_prefix_and_unascii tvar_prefix a of
  20.381 -          SOME b => TVar (("'" ^ b, 0), HOLogic.typeS)
  20.382 -        | NONE =>
  20.383 -          (* Variable from the ATP, say "X1" *)
  20.384 -          Type_Infer.param 0 (a, HOLogic.typeS)
  20.385 -  end
  20.386 -
  20.387 -(* Type class literal applied to a type. Returns triple of polarity, class,
  20.388 -   type. *)
  20.389 -fun type_constraint_from_term tfrees (u as ATerm (a, us)) =
  20.390 -  case (strip_prefix_and_unascii class_prefix a,
  20.391 -        map (typ_from_fo_term tfrees) us) of
  20.392 -    (SOME b, [T]) => (b, T)
  20.393 -  | _ => raise FO_TERM [u]
  20.394 -
  20.395 -(** Accumulate type constraints in a formula: negative type literals **)
  20.396 -fun add_var (key, z)  = Vartab.map_default (key, []) (cons z)
  20.397 -fun add_type_constraint false (cl, TFree (a ,_)) = add_var ((a, ~1), cl)
  20.398 -  | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl)
  20.399 -  | add_type_constraint _ _ = I
  20.400 -
  20.401 -fun repair_tptp_variable_name f s =
  20.402 -  let
  20.403 -    fun subscript_name s n = s ^ nat_subscript n
  20.404 -    val s = String.map f s
  20.405 -  in
  20.406 -    case space_explode "_" s of
  20.407 -      [_] => (case take_suffix Char.isDigit (String.explode s) of
  20.408 -                (cs1 as _ :: _, cs2 as _ :: _) =>
  20.409 -                subscript_name (String.implode cs1)
  20.410 -                               (the (Int.fromString (String.implode cs2)))
  20.411 -              | (_, _) => s)
  20.412 -    | [s1, s2] => (case Int.fromString s2 of
  20.413 -                     SOME n => subscript_name s1 n
  20.414 -                   | NONE => s)
  20.415 -    | _ => s
  20.416 -  end
  20.417 -
  20.418 -(* First-order translation. No types are known for variables. "HOLogic.typeT"
  20.419 -   should allow them to be inferred. *)
  20.420 -fun raw_term_from_pred thy sym_tab tfrees =
  20.421 -  let
  20.422 -    fun aux opt_T extra_us u =
  20.423 -      case u of
  20.424 -        ATerm (a, us) =>
  20.425 -        if String.isPrefix simple_type_prefix a then
  20.426 -          @{const True} (* ignore TPTP type information *)
  20.427 -        else if a = tptp_equal then
  20.428 -          let val ts = map (aux NONE []) us in
  20.429 -            if length ts = 2 andalso hd ts aconv List.last ts then
  20.430 -              (* Vampire is keen on producing these. *)
  20.431 -              @{const True}
  20.432 -            else
  20.433 -              list_comb (Const (@{const_name HOL.eq}, HOLogic.typeT), ts)
  20.434 -          end
  20.435 -        else case strip_prefix_and_unascii const_prefix a of
  20.436 -          SOME s =>
  20.437 -          let
  20.438 -            val ((s', s), mangled_us) = s |> unmangled_const |>> `invert_const
  20.439 -          in
  20.440 -            if s' = type_tag_name then
  20.441 -              case mangled_us @ us of
  20.442 -                [typ_u, term_u] =>
  20.443 -                aux (SOME (typ_from_fo_term tfrees typ_u)) extra_us term_u
  20.444 -              | _ => raise FO_TERM us
  20.445 -            else if s' = predicator_name then
  20.446 -              aux (SOME @{typ bool}) [] (hd us)
  20.447 -            else if s' = app_op_name then
  20.448 -              aux opt_T (nth us 1 :: extra_us) (hd us)
  20.449 -            else if s' = type_pred_name then
  20.450 -              @{const True} (* ignore type predicates *)
  20.451 -            else
  20.452 -              let
  20.453 -                val num_ty_args =
  20.454 -                  length us - the_default 0 (Symtab.lookup sym_tab s)
  20.455 -                val (type_us, term_us) =
  20.456 -                  chop num_ty_args us |>> append mangled_us
  20.457 -                (* Extra args from "hAPP" come after any arguments given
  20.458 -                   directly to the constant. *)
  20.459 -                val term_ts = map (aux NONE []) term_us
  20.460 -                val extra_ts = map (aux NONE []) extra_us
  20.461 -                val T =
  20.462 -                  if num_type_args thy s' = length type_us then
  20.463 -                    Sign.const_instance thy
  20.464 -                        (s', map (typ_from_fo_term tfrees) type_us)
  20.465 -                  else case opt_T of
  20.466 -                    SOME T => map fastype_of (term_ts @ extra_ts) ---> T
  20.467 -                  | NONE => HOLogic.typeT
  20.468 -                val s' = s' |> unproxify_const
  20.469 -              in list_comb (Const (s', T), term_ts @ extra_ts) end
  20.470 -          end
  20.471 -        | NONE => (* a free or schematic variable *)
  20.472 -          let
  20.473 -            val ts = map (aux NONE []) (us @ extra_us)
  20.474 -            val T = map fastype_of ts ---> HOLogic.typeT
  20.475 -            val t =
  20.476 -              case strip_prefix_and_unascii fixed_var_prefix a of
  20.477 -                SOME b => Free (b, T)
  20.478 -              | NONE =>
  20.479 -                case strip_prefix_and_unascii schematic_var_prefix a of
  20.480 -                  SOME b => Var ((b, 0), T)
  20.481 -                | NONE =>
  20.482 -                  if is_tptp_variable a then
  20.483 -                    Var ((repair_tptp_variable_name Char.toLower a, 0), T)
  20.484 -                  else
  20.485 -                    (* Skolem constants? *)
  20.486 -                    Var ((repair_tptp_variable_name Char.toUpper a, 0), T)
  20.487 -          in list_comb (t, ts) end
  20.488 -  in aux (SOME HOLogic.boolT) [] end
  20.489 -
  20.490 -fun term_from_pred thy sym_tab tfrees pos (u as ATerm (s, _)) =
  20.491 -  if String.isPrefix class_prefix s then
  20.492 -    add_type_constraint pos (type_constraint_from_term tfrees u)
  20.493 -    #> pair @{const True}
  20.494 -  else
  20.495 -    pair (raw_term_from_pred thy sym_tab tfrees u)
  20.496 -
  20.497 -val combinator_table =
  20.498 -  [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}),
  20.499 -   (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}),
  20.500 -   (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}),
  20.501 -   (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}),
  20.502 -   (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})]
  20.503 -
  20.504 -fun uncombine_term thy =
  20.505 -  let
  20.506 -    fun aux (t1 $ t2) = betapply (pairself aux (t1, t2))
  20.507 -      | aux (Abs (s, T, t')) = Abs (s, T, aux t')
  20.508 -      | aux (t as Const (x as (s, _))) =
  20.509 -        (case AList.lookup (op =) combinator_table s of
  20.510 -           SOME thm => thm |> prop_of |> specialize_type thy x
  20.511 -                           |> Logic.dest_equals |> snd
  20.512 -         | NONE => t)
  20.513 -      | aux t = t
  20.514 -  in aux end
  20.515 -
  20.516 -(* Update schematic type variables with detected sort constraints. It's not
  20.517 -   totally clear whether this code is necessary. *)
  20.518 -fun repair_tvar_sorts (t, tvar_tab) =
  20.519 -  let
  20.520 -    fun do_type (Type (a, Ts)) = Type (a, map do_type Ts)
  20.521 -      | do_type (TVar (xi, s)) =
  20.522 -        TVar (xi, the_default s (Vartab.lookup tvar_tab xi))
  20.523 -      | do_type (TFree z) = TFree z
  20.524 -    fun do_term (Const (a, T)) = Const (a, do_type T)
  20.525 -      | do_term (Free (a, T)) = Free (a, do_type T)
  20.526 -      | do_term (Var (xi, T)) = Var (xi, do_type T)
  20.527 -      | do_term (t as Bound _) = t
  20.528 -      | do_term (Abs (a, T, t)) = Abs (a, do_type T, do_term t)
  20.529 -      | do_term (t1 $ t2) = do_term t1 $ do_term t2
  20.530 -  in t |> not (Vartab.is_empty tvar_tab) ? do_term end
  20.531 -
  20.532 -fun quantify_over_var quant_of var_s t =
  20.533 -  let
  20.534 -    val vars = [] |> Term.add_vars t |> filter (fn ((s, _), _) => s = var_s)
  20.535 -                  |> map Var
  20.536 -  in fold_rev quant_of vars t end
  20.537 -
  20.538 -(* Interpret an ATP formula as a HOL term, extracting sort constraints as they
  20.539 -   appear in the formula. *)
  20.540 -fun prop_from_formula thy sym_tab tfrees phi =
  20.541 -  let
  20.542 -    fun do_formula pos phi =
  20.543 -      case phi of
  20.544 -        AQuant (_, [], phi) => do_formula pos phi
  20.545 -      | AQuant (q, (s, _) :: xs, phi') =>
  20.546 -        do_formula pos (AQuant (q, xs, phi'))
  20.547 -        (* FIXME: TFF *)
  20.548 -        #>> quantify_over_var (case q of
  20.549 -                                 AForall => forall_of
  20.550 -                               | AExists => exists_of)
  20.551 -                              (repair_tptp_variable_name Char.toLower s)
  20.552 -      | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not
  20.553 -      | AConn (c, [phi1, phi2]) =>
  20.554 -        do_formula (pos |> c = AImplies ? not) phi1
  20.555 -        ##>> do_formula pos phi2
  20.556 -        #>> (case c of
  20.557 -               AAnd => s_conj
  20.558 -             | AOr => s_disj
  20.559 -             | AImplies => s_imp
  20.560 -             | AIf => s_imp o swap
  20.561 -             | AIff => s_iff
  20.562 -             | ANotIff => s_not o s_iff
  20.563 -             | _ => raise Fail "unexpected connective")
  20.564 -      | AAtom tm => term_from_pred thy sym_tab tfrees pos tm
  20.565 -      | _ => raise FORMULA [phi]
  20.566 -  in repair_tvar_sorts (do_formula true phi Vartab.empty) end
  20.567 -
  20.568 -fun check_formula ctxt =
  20.569 -  Type.constraint HOLogic.boolT
  20.570 -  #> Syntax.check_term
  20.571 -         (Proof_Context.set_mode Proof_Context.mode_schematic ctxt)
  20.572 -
  20.573 -(**** Translation of TSTP files to Isar Proofs ****)
  20.574 -
  20.575 -fun unvarify_term (Var ((s, 0), T)) = Free (s, T)
  20.576 -  | unvarify_term t = raise TERM ("unvarify_term: non-Var", [t])
  20.577 -
  20.578 -fun decode_line sym_tab tfrees (Definition (name, phi1, phi2)) ctxt =
  20.579 -    let
  20.580 -      val thy = Proof_Context.theory_of ctxt
  20.581 -      val t1 = prop_from_formula thy sym_tab tfrees phi1
  20.582 -      val vars = snd (strip_comb t1)
  20.583 -      val frees = map unvarify_term vars
  20.584 -      val unvarify_args = subst_atomic (vars ~~ frees)
  20.585 -      val t2 = prop_from_formula thy sym_tab tfrees phi2
  20.586 -      val (t1, t2) =
  20.587 -        HOLogic.eq_const HOLogic.typeT $ t1 $ t2
  20.588 -        |> unvarify_args |> uncombine_term thy |> check_formula ctxt
  20.589 -        |> HOLogic.dest_eq
  20.590 -    in
  20.591 -      (Definition (name, t1, t2),
  20.592 -       fold Variable.declare_term (maps OldTerm.term_frees [t1, t2]) ctxt)
  20.593 -    end
  20.594 -  | decode_line sym_tab tfrees (Inference (name, u, deps)) ctxt =
  20.595 -    let
  20.596 -      val thy = Proof_Context.theory_of ctxt
  20.597 -      val t = u |> prop_from_formula thy sym_tab tfrees
  20.598 -                |> uncombine_term thy |> check_formula ctxt
  20.599 -    in
  20.600 -      (Inference (name, t, deps),
  20.601 -       fold Variable.declare_term (OldTerm.term_frees t) ctxt)
  20.602 -    end
  20.603 -fun decode_lines ctxt sym_tab tfrees lines =
  20.604 -  fst (fold_map (decode_line sym_tab tfrees) lines ctxt)
  20.605 -
  20.606 -fun is_same_inference _ (Definition _) = false
  20.607 -  | is_same_inference t (Inference (_, t', _)) = t aconv t'
  20.608 -
  20.609 -(* No "real" literals means only type information (tfree_tcs, clsrel, or
  20.610 -   clsarity). *)
  20.611 -val is_only_type_information = curry (op aconv) HOLogic.true_const
  20.612 -
  20.613 -fun replace_one_dependency (old, new) dep =
  20.614 -  if is_same_atp_step dep old then new else [dep]
  20.615 -fun replace_dependencies_in_line _ (line as Definition _) = line
  20.616 -  | replace_dependencies_in_line p (Inference (name, t, deps)) =
  20.617 -    Inference (name, t, fold (union (op =) o replace_one_dependency p) deps [])
  20.618 -
  20.619 -(* Discard facts; consolidate adjacent lines that prove the same formula, since
  20.620 -   they differ only in type information.*)
  20.621 -fun add_line _ _ _ (line as Definition _) lines = line :: lines
  20.622 -  | add_line type_sys conjecture_shape fact_names (Inference (name, t, []))
  20.623 -             lines =
  20.624 -    (* No dependencies: fact, conjecture, or (for Vampire) internal facts or
  20.625 -       definitions. *)
  20.626 -    if is_fact type_sys fact_names name then
  20.627 -      (* Facts are not proof lines. *)
  20.628 -      if is_only_type_information t then
  20.629 -        map (replace_dependencies_in_line (name, [])) lines
  20.630 -      (* Is there a repetition? If so, replace later line by earlier one. *)
  20.631 -      else case take_prefix (not o is_same_inference t) lines of
  20.632 -        (_, []) => lines (* no repetition of proof line *)
  20.633 -      | (pre, Inference (name', _, _) :: post) =>
  20.634 -        pre @ map (replace_dependencies_in_line (name', [name])) post
  20.635 -      | _ => raise Fail "unexpected inference"
  20.636 -    else if is_conjecture conjecture_shape name then
  20.637 -      Inference (name, s_not t, []) :: lines
  20.638 -    else
  20.639 -      map (replace_dependencies_in_line (name, [])) lines
  20.640 -  | add_line _ _ _ (Inference (name, t, deps)) lines =
  20.641 -    (* Type information will be deleted later; skip repetition test. *)
  20.642 -    if is_only_type_information t then
  20.643 -      Inference (name, t, deps) :: lines
  20.644 -    (* Is there a repetition? If so, replace later line by earlier one. *)
  20.645 -    else case take_prefix (not o is_same_inference t) lines of
  20.646 -      (* FIXME: Doesn't this code risk conflating proofs involving different
  20.647 -         types? *)
  20.648 -       (_, []) => Inference (name, t, deps) :: lines
  20.649 -     | (pre, Inference (name', t', _) :: post) =>
  20.650 -       Inference (name, t', deps) ::
  20.651 -       pre @ map (replace_dependencies_in_line (name', [name])) post
  20.652 -     | _ => raise Fail "unexpected inference"
  20.653 -
  20.654 -(* Recursively delete empty lines (type information) from the proof. *)
  20.655 -fun add_nontrivial_line (Inference (name, t, [])) lines =
  20.656 -    if is_only_type_information t then delete_dependency name lines
  20.657 -    else Inference (name, t, []) :: lines
  20.658 -  | add_nontrivial_line line lines = line :: lines
  20.659 -and delete_dependency name lines =
  20.660 -  fold_rev add_nontrivial_line
  20.661 -           (map (replace_dependencies_in_line (name, [])) lines) []
  20.662 -
  20.663 -(* ATPs sometimes reuse free variable names in the strangest ways. Removing
  20.664 -   offending lines often does the trick. *)
  20.665 -fun is_bad_free frees (Free x) = not (member (op =) frees x)
  20.666 -  | is_bad_free _ _ = false
  20.667 -
  20.668 -fun add_desired_line _ _ _ _ _ (line as Definition (name, _, _)) (j, lines) =
  20.669 -    (j, line :: map (replace_dependencies_in_line (name, [])) lines)
  20.670 -  | add_desired_line type_sys isar_shrink_factor conjecture_shape fact_names
  20.671 -                     frees (Inference (name, t, deps)) (j, lines) =
  20.672 -    (j + 1,
  20.673 -     if is_fact type_sys fact_names name orelse
  20.674 -        is_conjecture conjecture_shape name orelse
  20.675 -        (* the last line must be kept *)
  20.676 -        j = 0 orelse
  20.677 -        (not (is_only_type_information t) andalso
  20.678 -         null (Term.add_tvars t []) andalso
  20.679 -         not (exists_subterm (is_bad_free frees) t) andalso
  20.680 -         length deps >= 2 andalso j mod isar_shrink_factor = 0 andalso
  20.681 -         (* kill next to last line, which usually results in a trivial step *)
  20.682 -         j <> 1) then
  20.683 -       Inference (name, t, deps) :: lines  (* keep line *)
  20.684 -     else
  20.685 -       map (replace_dependencies_in_line (name, deps)) lines)  (* drop line *)
  20.686 -
  20.687 -(** Isar proof construction and manipulation **)
  20.688 -
  20.689 -fun merge_fact_sets (ls1, ss1) (ls2, ss2) =
  20.690 -  (union (op =) ls1 ls2, union (op =) ss1 ss2)
  20.691 -
  20.692 -type label = string * int
  20.693 -type facts = label list * string list
  20.694 -
  20.695 -datatype isar_qualifier = Show | Then | Moreover | Ultimately
  20.696 -
  20.697 -datatype isar_step =
  20.698 -  Fix of (string * typ) list |
  20.699 -  Let of term * term |
  20.700 -  Assume of label * term |
  20.701 -  Have of isar_qualifier list * label * term * byline
  20.702 -and byline =
  20.703 -  ByMetis of facts |
  20.704 -  CaseSplit of isar_step list list * facts
  20.705 -
  20.706 -fun smart_case_split [] facts = ByMetis facts
  20.707 -  | smart_case_split proofs facts = CaseSplit (proofs, facts)
  20.708 -
  20.709 -fun add_fact_from_dependency type_sys conjecture_shape facts_offset fact_names
  20.710 -                             name =
  20.711 -  if is_fact type_sys fact_names name then
  20.712 -    apsnd (union (op =)
  20.713 -          (map fst (resolve_fact type_sys facts_offset fact_names name)))
  20.714 -  else
  20.715 -    apfst (insert (op =) (raw_label_for_name conjecture_shape name))
  20.716 -
  20.717 -fun step_for_line _ _ _ _ _ (Definition (_, t1, t2)) = Let (t1, t2)
  20.718 -  | step_for_line _ conjecture_shape _ _ _ (Inference (name, t, [])) =
  20.719 -    Assume (raw_label_for_name conjecture_shape name, t)
  20.720 -  | step_for_line type_sys conjecture_shape facts_offset
  20.721 -                  fact_names j (Inference (name, t, deps)) =
  20.722 -    Have (if j = 1 then [Show] else [],
  20.723 -          raw_label_for_name conjecture_shape name,
  20.724 -          fold_rev forall_of (map Var (Term.add_vars t [])) t,
  20.725 -          ByMetis (fold (add_fact_from_dependency type_sys conjecture_shape
  20.726 -                                                  facts_offset fact_names)
  20.727 -                        deps ([], [])))
  20.728 -
  20.729 -fun repair_name "$true" = "c_True"
  20.730 -  | repair_name "$false" = "c_False"
  20.731 -  | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *)
  20.732 -  | repair_name s =
  20.733 -    if is_tptp_equal s orelse
  20.734 -       (* seen in Vampire proofs *)
  20.735 -       (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then
  20.736 -      tptp_equal
  20.737 -    else
  20.738 -      s
  20.739 -
  20.740 -fun isar_proof_from_atp_proof pool ctxt type_sys tfrees isar_shrink_factor
  20.741 -        conjecture_shape facts_offset fact_names sym_tab params frees
  20.742 -        atp_proof =
  20.743 -  let
  20.744 -    val lines =
  20.745 -      atp_proof
  20.746 -      |> clean_up_atp_proof_dependencies
  20.747 -      |> nasty_atp_proof pool
  20.748 -      |> map_term_names_in_atp_proof repair_name
  20.749 -      |> decode_lines ctxt sym_tab tfrees
  20.750 -      |> rpair [] |-> fold_rev (add_line type_sys conjecture_shape fact_names)
  20.751 -      |> rpair [] |-> fold_rev add_nontrivial_line
  20.752 -      |> rpair (0, [])
  20.753 -      |-> fold_rev (add_desired_line type_sys isar_shrink_factor
  20.754 -                                     conjecture_shape fact_names frees)
  20.755 -      |> snd
  20.756 -  in
  20.757 -    (if null params then [] else [Fix params]) @
  20.758 -    map2 (step_for_line type_sys conjecture_shape facts_offset fact_names)
  20.759 -         (length lines downto 1) lines
  20.760 -  end
  20.761 -
  20.762 -(* When redirecting proofs, we keep information about the labels seen so far in
  20.763 -   the "backpatches" data structure. The first component indicates which facts
  20.764 -   should be associated with forthcoming proof steps. The second component is a
  20.765 -   pair ("assum_ls", "drop_ls"), where "assum_ls" are the labels that should
  20.766 -   become assumptions and "drop_ls" are the labels that should be dropped in a
  20.767 -   case split. *)
  20.768 -type backpatches = (label * facts) list * (label list * label list)
  20.769 -
  20.770 -fun used_labels_of_step (Have (_, _, _, by)) =
  20.771 -    (case by of
  20.772 -       ByMetis (ls, _) => ls
  20.773 -     | CaseSplit (proofs, (ls, _)) =>
  20.774 -       fold (union (op =) o used_labels_of) proofs ls)
  20.775 -  | used_labels_of_step _ = []
  20.776 -and used_labels_of proof = fold (union (op =) o used_labels_of_step) proof []
  20.777 -
  20.778 -fun new_labels_of_step (Fix _) = []
  20.779 -  | new_labels_of_step (Let _) = []
  20.780 -  | new_labels_of_step (Assume (l, _)) = [l]
  20.781 -  | new_labels_of_step (Have (_, l, _, _)) = [l]
  20.782 -val new_labels_of = maps new_labels_of_step
  20.783 -
  20.784 -val join_proofs =
  20.785 -  let
  20.786 -    fun aux _ [] = NONE
  20.787 -      | aux proof_tail (proofs as (proof1 :: _)) =
  20.788 -        if exists null proofs then
  20.789 -          NONE
  20.790 -        else if forall (curry (op =) (hd proof1) o hd) (tl proofs) then
  20.791 -          aux (hd proof1 :: proof_tail) (map tl proofs)
  20.792 -        else case hd proof1 of
  20.793 -          Have ([], l, t, _) => (* FIXME: should we really ignore the "by"? *)
  20.794 -          if forall (fn Have ([], l', t', _) :: _ => (l, t) = (l', t')
  20.795 -                      | _ => false) (tl proofs) andalso
  20.796 -             not (exists (member (op =) (maps new_labels_of proofs))
  20.797 -                         (used_labels_of proof_tail)) then
  20.798 -            SOME (l, t, map rev proofs, proof_tail)
  20.799 -          else
  20.800 -            NONE
  20.801 -        | _ => NONE
  20.802 -  in aux [] o map rev end
  20.803 -
  20.804 -fun case_split_qualifiers proofs =
  20.805 -  case length proofs of
  20.806 -    0 => []
  20.807 -  | 1 => [Then]
  20.808 -  | _ => [Ultimately]
  20.809 -
  20.810 -fun redirect_proof hyp_ts concl_t proof =
  20.811 -  let
  20.812 -    (* The first pass outputs those steps that are independent of the negated
  20.813 -       conjecture. The second pass flips the proof by contradiction to obtain a
  20.814 -       direct proof, introducing case splits when an inference depends on
  20.815 -       several facts that depend on the negated conjecture. *)
  20.816 -     val concl_l = (conjecture_prefix, length hyp_ts)
  20.817 -     fun first_pass ([], contra) = ([], contra)
  20.818 -       | first_pass ((step as Fix _) :: proof, contra) =
  20.819 -         first_pass (proof, contra) |>> cons step
  20.820 -       | first_pass ((step as Let _) :: proof, contra) =
  20.821 -         first_pass (proof, contra) |>> cons step
  20.822 -       | first_pass ((step as Assume (l as (_, j), _)) :: proof, contra) =
  20.823 -         if l = concl_l then first_pass (proof, contra ||> cons step)
  20.824 -         else first_pass (proof, contra) |>> cons (Assume (l, nth hyp_ts j))
  20.825 -       | first_pass (Have (qs, l, t, ByMetis (ls, ss)) :: proof, contra) =
  20.826 -         let val step = Have (qs, l, t, ByMetis (ls, ss)) in
  20.827 -           if exists (member (op =) (fst contra)) ls then
  20.828 -             first_pass (proof, contra |>> cons l ||> cons step)
  20.829 -           else
  20.830 -             first_pass (proof, contra) |>> cons step
  20.831 -         end
  20.832 -       | first_pass _ = raise Fail "malformed proof"
  20.833 -    val (proof_top, (contra_ls, contra_proof)) =
  20.834 -      first_pass (proof, ([concl_l], []))
  20.835 -    val backpatch_label = the_default ([], []) oo AList.lookup (op =) o fst
  20.836 -    fun backpatch_labels patches ls =
  20.837 -      fold merge_fact_sets (map (backpatch_label patches) ls) ([], [])
  20.838 -    fun second_pass end_qs ([], assums, patches) =
  20.839 -        ([Have (end_qs, no_label, concl_t,
  20.840 -                ByMetis (backpatch_labels patches (map snd assums)))], patches)
  20.841 -      | second_pass end_qs (Assume (l, t) :: proof, assums, patches) =
  20.842 -        second_pass end_qs (proof, (t, l) :: assums, patches)
  20.843 -      | second_pass end_qs (Have (qs, l, t, ByMetis (ls, ss)) :: proof, assums,
  20.844 -                            patches) =
  20.845 -        (if member (op =) (snd (snd patches)) l andalso
  20.846 -            not (member (op =) (fst (snd patches)) l) andalso
  20.847 -            not (AList.defined (op =) (fst patches) l) then
  20.848 -           second_pass end_qs (proof, assums, patches ||> apsnd (append ls))
  20.849 -         else case List.partition (member (op =) contra_ls) ls of
  20.850 -           ([contra_l], co_ls) =>
  20.851 -           if member (op =) qs Show then
  20.852 -             second_pass end_qs (proof, assums,
  20.853 -                                 patches |>> cons (contra_l, (co_ls, ss)))
  20.854 -           else
  20.855 -             second_pass end_qs
  20.856 -                         (proof, assums,
  20.857 -                          patches |>> cons (contra_l, (l :: co_ls, ss)))
  20.858 -             |>> cons (if member (op =) (fst (snd patches)) l then
  20.859 -                         Assume (l, s_not t)
  20.860 -                       else
  20.861 -                         Have (qs, l, s_not t,
  20.862 -                               ByMetis (backpatch_label patches l)))
  20.863 -         | (contra_ls as _ :: _, co_ls) =>
  20.864 -           let
  20.865 -             val proofs =
  20.866 -               map_filter
  20.867 -                   (fn l =>
  20.868 -                       if l = concl_l then
  20.869 -                         NONE
  20.870 -                       else
  20.871 -                         let
  20.872 -                           val drop_ls = filter (curry (op <>) l) contra_ls
  20.873 -                         in
  20.874 -                           second_pass []
  20.875 -                               (proof, assums,
  20.876 -                                patches ||> apfst (insert (op =) l)
  20.877 -                                        ||> apsnd (union (op =) drop_ls))
  20.878 -                           |> fst |> SOME
  20.879 -                         end) contra_ls
  20.880 -             val (assumes, facts) =
  20.881 -               if member (op =) (fst (snd patches)) l then
  20.882 -                 ([Assume (l, s_not t)], (l :: co_ls, ss))
  20.883 -               else
  20.884 -                 ([], (co_ls, ss))
  20.885 -           in
  20.886 -             (case join_proofs proofs of
  20.887 -                SOME (l, t, proofs, proof_tail) =>
  20.888 -                Have (case_split_qualifiers proofs @
  20.889 -                      (if null proof_tail then end_qs else []), l, t,
  20.890 -                      smart_case_split proofs facts) :: proof_tail
  20.891 -              | NONE =>
  20.892 -                [Have (case_split_qualifiers proofs @ end_qs, no_label,
  20.893 -                       concl_t, smart_case_split proofs facts)],
  20.894 -              patches)
  20.895 -             |>> append assumes
  20.896 -           end
  20.897 -         | _ => raise Fail "malformed proof")
  20.898 -       | second_pass _ _ = raise Fail "malformed proof"
  20.899 -    val proof_bottom =
  20.900 -      second_pass [Show] (contra_proof, [], ([], ([], []))) |> fst
  20.901 -  in proof_top @ proof_bottom end
  20.902 -
  20.903 -(* FIXME: Still needed? Probably not. *)
  20.904 -val kill_duplicate_assumptions_in_proof =
  20.905 -  let
  20.906 -    fun relabel_facts subst =
  20.907 -      apfst (map (fn l => AList.lookup (op =) subst l |> the_default l))
  20.908 -    fun do_step (step as Assume (l, t)) (proof, subst, assums) =
  20.909 -        (case AList.lookup (op aconv) assums t of
  20.910 -           SOME l' => (proof, (l, l') :: subst, assums)
  20.911 -         | NONE => (step :: proof, subst, (t, l) :: assums))
  20.912 -      | do_step (Have (qs, l, t, by)) (proof, subst, assums) =
  20.913 -        (Have (qs, l, t,
  20.914 -               case by of
  20.915 -                 ByMetis facts => ByMetis (relabel_facts subst facts)
  20.916 -               | CaseSplit (proofs, facts) =>
  20.917 -                 CaseSplit (map do_proof proofs, relabel_facts subst facts)) ::
  20.918 -         proof, subst, assums)
  20.919 -      | do_step step (proof, subst, assums) = (step :: proof, subst, assums)
  20.920 -    and do_proof proof = fold do_step proof ([], [], []) |> #1 |> rev
  20.921 -  in do_proof end
  20.922 -
  20.923 -val then_chain_proof =
  20.924 -  let
  20.925 -    fun aux _ [] = []
  20.926 -      | aux _ ((step as Assume (l, _)) :: proof) = step :: aux l proof
  20.927 -      | aux l' (Have (qs, l, t, by) :: proof) =
  20.928 -        (case by of
  20.929 -           ByMetis (ls, ss) =>
  20.930 -           Have (if member (op =) ls l' then
  20.931 -                   (Then :: qs, l, t,
  20.932 -                    ByMetis (filter_out (curry (op =) l') ls, ss))
  20.933 -                 else
  20.934 -                   (qs, l, t, ByMetis (ls, ss)))
  20.935 -         | CaseSplit (proofs, facts) =>
  20.936 -           Have (qs, l, t, CaseSplit (map (aux no_label) proofs, facts))) ::
  20.937 -        aux l proof
  20.938 -      | aux _ (step :: proof) = step :: aux no_label proof
  20.939 -  in aux no_label end
  20.940 -
  20.941 -fun kill_useless_labels_in_proof proof =
  20.942 -  let
  20.943 -    val used_ls = used_labels_of proof
  20.944 -    fun do_label l = if member (op =) used_ls l then l else no_label
  20.945 -    fun do_step (Assume (l, t)) = Assume (do_label l, t)
  20.946 -      | do_step (Have (qs, l, t, by)) =
  20.947 -        Have (qs, do_label l, t,
  20.948 -              case by of
  20.949 -                CaseSplit (proofs, facts) =>
  20.950 -                CaseSplit (map (map do_step) proofs, facts)
  20.951 -              | _ => by)
  20.952 -      | do_step step = step
  20.953 -  in map do_step proof end
  20.954 -
  20.955 -fun prefix_for_depth n = replicate_string (n + 1)
  20.956 -
  20.957 -val relabel_proof =
  20.958 -  let
  20.959 -    fun aux _ _ _ [] = []
  20.960 -      | aux subst depth (next_assum, next_fact) (Assume (l, t) :: proof) =
  20.961 -        if l = no_label then
  20.962 -          Assume (l, t) :: aux subst depth (next_assum, next_fact) proof
  20.963 -        else
  20.964 -          let val l' = (prefix_for_depth depth assum_prefix, next_assum) in
  20.965 -            Assume (l', t) ::
  20.966 -            aux ((l, l') :: subst) depth (next_assum + 1, next_fact) proof
  20.967 -          end
  20.968 -      | aux subst depth (next_assum, next_fact) (Have (qs, l, t, by) :: proof) =
  20.969 -        let
  20.970 -          val (l', subst, next_fact) =
  20.971 -            if l = no_label then
  20.972 -              (l, subst, next_fact)
  20.973 -            else
  20.974 -              let
  20.975 -                val l' = (prefix_for_depth depth have_prefix, next_fact)
  20.976 -              in (l', (l, l') :: subst, next_fact + 1) end
  20.977 -          val relabel_facts =
  20.978 -            apfst (maps (the_list o AList.lookup (op =) subst))
  20.979 -          val by =
  20.980 -            case by of
  20.981 -              ByMetis facts => ByMetis (relabel_facts facts)
  20.982 -            | CaseSplit (proofs, facts) =>
  20.983 -              CaseSplit (map (aux subst (depth + 1) (1, 1)) proofs,
  20.984 -                         relabel_facts facts)
  20.985 -        in
  20.986 -          Have (qs, l', t, by) ::
  20.987 -          aux subst depth (next_assum, next_fact) proof
  20.988 -        end
  20.989 -      | aux subst depth nextp (step :: proof) =
  20.990 -        step :: aux subst depth nextp proof
  20.991 -  in aux [] 0 (1, 1) end
  20.992 -
  20.993 -fun string_for_proof ctxt0 full_types i n =
  20.994 -  let
  20.995 -    val ctxt =
  20.996 -      ctxt0 |> Config.put show_free_types false
  20.997 -            |> Config.put show_types true
  20.998 -            |> Config.put show_sorts true
  20.999 -    fun fix_print_mode f x =
 20.1000 -      Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN)
 20.1001 -                               (print_mode_value ())) f x
 20.1002 -    fun do_indent ind = replicate_string (ind * indent_size) " "
 20.1003 -    fun do_free (s, T) =
 20.1004 -      maybe_quote s ^ " :: " ^
 20.1005 -      maybe_quote (fix_print_mode (Syntax.string_of_typ ctxt) T)
 20.1006 -    fun do_label l = if l = no_label then "" else string_for_label l ^ ": "
 20.1007 -    fun do_have qs =
 20.1008 -      (if member (op =) qs Moreover then "moreover " else "") ^
 20.1009 -      (if member (op =) qs Ultimately then "ultimately " else "") ^
 20.1010 -      (if member (op =) qs Then then
 20.1011 -         if member (op =) qs Show then "thus" else "hence"
 20.1012 -       else
 20.1013 -         if member (op =) qs Show then "show" else "have")
 20.1014 -    val do_term = maybe_quote o fix_print_mode (Syntax.string_of_term ctxt)
 20.1015 -    val reconstructor = if full_types then MetisFT else Metis
 20.1016 -    fun do_facts (ls, ss) =
 20.1017 -      reconstructor_command reconstructor 1 1
 20.1018 -          (ls |> sort_distinct (prod_ord string_ord int_ord),
 20.1019 -           ss |> sort_distinct string_ord)
 20.1020 -    and do_step ind (Fix xs) =
 20.1021 -        do_indent ind ^ "fix " ^ space_implode " and " (map do_free xs) ^ "\n"
 20.1022 -      | do_step ind (Let (t1, t2)) =
 20.1023 -        do_indent ind ^ "let " ^ do_term t1 ^ " = " ^ do_term t2 ^ "\n"
 20.1024 -      | do_step ind (Assume (l, t)) =
 20.1025 -        do_indent ind ^ "assume " ^ do_label l ^ do_term t ^ "\n"
 20.1026 -      | do_step ind (Have (qs, l, t, ByMetis facts)) =
 20.1027 -        do_indent ind ^ do_have qs ^ " " ^
 20.1028 -        do_label l ^ do_term t ^ " " ^ do_facts facts ^ "\n"
 20.1029 -      | do_step ind (Have (qs, l, t, CaseSplit (proofs, facts))) =
 20.1030 -        space_implode (do_indent ind ^ "moreover\n")
 20.1031 -                      (map (do_block ind) proofs) ^
 20.1032 -        do_indent ind ^ do_have qs ^ " " ^ do_label l ^ do_term t ^ " " ^
 20.1033 -        do_facts facts ^ "\n"
 20.1034 -    and do_steps prefix suffix ind steps =
 20.1035 -      let val s = implode (map (do_step ind) steps) in
 20.1036 -        replicate_string (ind * indent_size - size prefix) " " ^ prefix ^
 20.1037 -        String.extract (s, ind * indent_size,
 20.1038 -                        SOME (size s - ind * indent_size - 1)) ^
 20.1039 -        suffix ^ "\n"
 20.1040 -      end
 20.1041 -    and do_block ind proof = do_steps "{ " " }" (ind + 1) proof
 20.1042 -    (* One-step proofs are pointless; better use the Metis one-liner
 20.1043 -       directly. *)
 20.1044 -    and do_proof [Have (_, _, _, ByMetis _)] = ""
 20.1045 -      | do_proof proof =
 20.1046 -        (if i <> 1 then "prefer " ^ string_of_int i ^ "\n" else "") ^
 20.1047 -        do_indent 0 ^ "proof -\n" ^ do_steps "" "" 1 proof ^ do_indent 0 ^
 20.1048 -        (if n <> 1 then "next" else "qed")
 20.1049 -  in do_proof end
 20.1050 -
 20.1051 -fun isar_proof_text ctxt isar_proof_requested
 20.1052 -        (debug, full_types, isar_shrink_factor, type_sys, pool,
 20.1053 -         conjecture_shape, facts_offset, fact_names, sym_tab, atp_proof, goal)
 20.1054 -        (one_line_params as (_, _, _, _, subgoal, subgoal_count)) =
 20.1055 -  let
 20.1056 -    val isar_shrink_factor =
 20.1057 -      (if isar_proof_requested then 1 else 2) * isar_shrink_factor
 20.1058 -    val (params, hyp_ts, concl_t) = strip_subgoal ctxt goal subgoal
 20.1059 -    val frees = fold Term.add_frees (concl_t :: hyp_ts) []
 20.1060 -    val tfrees = fold Term.add_tfrees (concl_t :: hyp_ts) []
 20.1061 -    val one_line_proof = one_line_proof_text one_line_params
 20.1062 -    fun isar_proof_for () =
 20.1063 -      case atp_proof
 20.1064 -           |> isar_proof_from_atp_proof pool ctxt type_sys tfrees
 20.1065 -                  isar_shrink_factor conjecture_shape facts_offset
 20.1066 -                  fact_names sym_tab params frees
 20.1067 -           |> redirect_proof hyp_ts concl_t
 20.1068 -           |> kill_duplicate_assumptions_in_proof
 20.1069 -           |> then_chain_proof
 20.1070 -           |> kill_useless_labels_in_proof
 20.1071 -           |> relabel_proof
 20.1072 -           |> string_for_proof ctxt full_types subgoal subgoal_count of
 20.1073 -        "" =>
 20.1074 -        if isar_proof_requested then
 20.1075 -          "\nNo structured proof available (proof too short)."
 20.1076 -        else
 20.1077 -          ""
 20.1078 -      | proof =>
 20.1079 -        "\n\n" ^ (if isar_proof_requested then "Structured proof"
 20.1080 -                  else "Perhaps this will work") ^
 20.1081 -        ":\n" ^ Markup.markup Markup.sendback proof
 20.1082 -    val isar_proof =
 20.1083 -      if debug then
 20.1084 -        isar_proof_for ()
 20.1085 -      else
 20.1086 -        case try isar_proof_for () of
 20.1087 -          SOME s => s
 20.1088 -        | NONE => if isar_proof_requested then
 20.1089 -                    "\nWarning: The Isar proof construction failed."
 20.1090 -                  else
 20.1091 -                    ""
 20.1092 -  in one_line_proof ^ isar_proof end
 20.1093 -
 20.1094 -fun proof_text ctxt isar_proof isar_params
 20.1095 -               (one_line_params as (preplay, _, _, _, _, _)) =
 20.1096 -  (if isar_proof orelse preplay = Failed_to_Play then
 20.1097 -     isar_proof_text ctxt isar_proof isar_params
 20.1098 -   else
 20.1099 -     one_line_proof_text) one_line_params
 20.1100 -
 20.1101 -end;
    21.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML	Tue May 31 15:45:27 2011 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,1389 +0,0 @@
    21.4 -(*  Title:      HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML
    21.5 -    Author:     Fabian Immler, TU Muenchen
    21.6 -    Author:     Makarius
    21.7 -    Author:     Jasmin Blanchette, TU Muenchen
    21.8 -
    21.9 -Translation of HOL to FOL for Sledgehammer.
   21.10 -*)
   21.11 -
   21.12 -signature SLEDGEHAMMER_ATP_TRANSLATE =
   21.13 -sig
   21.14 -  type 'a fo_term = 'a ATP_Problem.fo_term
   21.15 -  type format = ATP_Problem.format
   21.16 -  type formula_kind = ATP_Problem.formula_kind
   21.17 -  type 'a problem = 'a ATP_Problem.problem
   21.18 -  type locality = Sledgehammer_Filter.locality
   21.19 -
   21.20 -  datatype polymorphism = Polymorphic | Monomorphic | Mangled_Monomorphic
   21.21 -  datatype type_level =
   21.22 -    All_Types | Nonmonotonic_Types | Finite_Types | Const_Arg_Types | No_Types
   21.23 -  datatype type_heaviness = Heavy | Light
   21.24 -
   21.25 -  datatype type_system =
   21.26 -    Simple_Types of type_level |
   21.27 -    Preds of polymorphism * type_level * type_heaviness |
   21.28 -    Tags of polymorphism * type_level * type_heaviness
   21.29 -
   21.30 -  type translated_formula
   21.31 -
   21.32 -  val readable_names : bool Config.T
   21.33 -  val fact_prefix : string
   21.34 -  val conjecture_prefix : string
   21.35 -  val helper_prefix : string
   21.36 -  val typed_helper_suffix : string
   21.37 -  val predicator_name : string
   21.38 -  val app_op_name : string
   21.39 -  val type_pred_name : string
   21.40 -  val simple_type_prefix : string
   21.41 -  val type_sys_from_string : string -> type_system
   21.42 -  val polymorphism_of_type_sys : type_system -> polymorphism
   21.43 -  val level_of_type_sys : type_system -> type_level
   21.44 -  val is_type_sys_virtually_sound : type_system -> bool
   21.45 -  val is_type_sys_fairly_sound : type_system -> bool
   21.46 -  val unmangled_const : string -> string * string fo_term list
   21.47 -  val translate_atp_fact :
   21.48 -    Proof.context -> format -> type_system -> bool -> (string * locality) * thm
   21.49 -    -> translated_formula option * ((string * locality) * thm)
   21.50 -  val prepare_atp_problem :
   21.51 -    Proof.context -> format -> formula_kind -> formula_kind -> type_system
   21.52 -    -> bool option -> term list -> term
   21.53 -    -> (translated_formula option * ((string * 'a) * thm)) list
   21.54 -    -> string problem * string Symtab.table * int * int
   21.55 -       * (string * 'a) list vector * int list * int Symtab.table
   21.56 -  val atp_problem_weights : string problem -> (string * real) list
   21.57 -end;
   21.58 -
   21.59 -structure Sledgehammer_ATP_Translate : SLEDGEHAMMER_ATP_TRANSLATE =
   21.60 -struct
   21.61 -
   21.62 -open ATP_Problem
   21.63 -open Metis_Translate
   21.64 -open Sledgehammer_Util
   21.65 -open Sledgehammer_Filter
   21.66 -
   21.67 -(* experimental *)
   21.68 -val generate_useful_info = false
   21.69 -
   21.70 -fun useful_isabelle_info s =
   21.71 -  if generate_useful_info then
   21.72 -    SOME (ATerm ("[]", [ATerm ("isabelle_" ^ s, [])]))
   21.73 -  else
   21.74 -    NONE
   21.75 -
   21.76 -val intro_info = useful_isabelle_info "intro"
   21.77 -val elim_info = useful_isabelle_info "elim"
   21.78 -val simp_info = useful_isabelle_info "simp"
   21.79 -
   21.80 -(* Readable names are often much shorter, especially if types are mangled in
   21.81 -   names. Also, the logic for generating legal SNARK sort names is only
   21.82 -   implemented for readable names. Finally, readable names are, well, more
   21.83 -   readable. For these reason, they are enabled by default. *)
   21.84 -val readable_names =
   21.85 -  Attrib.setup_config_bool @{binding sledgehammer_atp_readable_names} (K true)
   21.86 -
   21.87 -val type_decl_prefix = "ty_"
   21.88 -val sym_decl_prefix = "sy_"
   21.89 -val sym_formula_prefix = "sym_"
   21.90 -val fact_prefix = "fact_"
   21.91 -val conjecture_prefix = "conj_"
   21.92 -val helper_prefix = "help_"
   21.93 -val class_rel_clause_prefix = "crel_";
   21.94 -val arity_clause_prefix = "arity_"
   21.95 -val tfree_prefix = "tfree_"
   21.96 -
   21.97 -val typed_helper_suffix = "_T"
   21.98 -val untyped_helper_suffix = "_U"
   21.99 -
  21.100 -val predicator_name = "hBOOL"
  21.101 -val app_op_name = "hAPP"
  21.102 -val type_pred_name = "is"
  21.103 -val simple_type_prefix = "ty_"
  21.104 -
  21.105 -fun make_simple_type s =
  21.106 -  if s = tptp_bool_type orelse s = tptp_fun_type orelse
  21.107 -     s = tptp_individual_type then
  21.108 -    s
  21.109 -  else
  21.110 -    simple_type_prefix ^ ascii_of s
  21.111 -
  21.112 -(* Freshness almost guaranteed! *)
  21.113 -val sledgehammer_weak_prefix = "Sledgehammer:"
  21.114 -
  21.115 -datatype polymorphism = Polymorphic | Monomorphic | Mangled_Monomorphic
  21.116 -datatype type_level =
  21.117 -  All_Types | Nonmonotonic_Types | Finite_Types | Const_Arg_Types | No_Types
  21.118 -datatype type_heaviness = Heavy | Light
  21.119 -
  21.120 -datatype type_system =
  21.121 -  Simple_Types of type_level |
  21.122 -  Preds of polymorphism * type_level * type_heaviness |
  21.123 -  Tags of polymorphism * type_level * type_heaviness
  21.124 -
  21.125 -fun try_unsuffixes ss s =
  21.126 -  fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE
  21.127 -
  21.128 -fun type_sys_from_string s =
  21.129 -  (case try (unprefix "poly_") s of
  21.130 -     SOME s => (SOME Polymorphic, s)
  21.131 -   | NONE =>
  21.132 -     case try (unprefix "mono_") s of
  21.133 -       SOME s => (SOME Monomorphic, s)
  21.134 -     | NONE =>
  21.135 -       case try (unprefix "mangled_") s of
  21.136 -         SOME s => (SOME Mangled_Monomorphic, s)
  21.137 -       | NONE => (NONE, s))
  21.138 -  ||> (fn s =>
  21.139 -          (* "_query" and "_bang" are for the ASCII-challenged Mirabelle. *)
  21.140 -          case try_unsuffixes ["?", "_query"] s of
  21.141 -            SOME s => (Nonmonotonic_Types, s)
  21.142 -          | NONE =>
  21.143 -            case try_unsuffixes ["!", "_bang"] s of
  21.144 -              SOME s => (Finite_Types, s)
  21.145 -            | NONE => (All_Types, s))
  21.146 -  ||> apsnd (fn s =>
  21.147 -                case try (unsuffix "_heavy") s of
  21.148 -                  SOME s => (Heavy, s)
  21.149 -                | NONE => (Light, s))
  21.150 -  |> (fn (poly, (level, (heaviness, core))) =>
  21.151 -         case (core, (poly, level, heaviness)) of
  21.152 -           ("simple", (NONE, _, Light)) => Simple_Types level
  21.153 -         | ("preds", (SOME poly, _, _)) => Preds (poly, level, heaviness)
  21.154 -         | ("tags", (SOME Polymorphic, All_Types, _)) =>
  21.155 -           Tags (Polymorphic, All_Types, heaviness)
  21.156 -         | ("tags", (SOME Polymorphic, _, _)) =>
  21.157 -           (* The actual light encoding is very unsound. *)
  21.158 -           Tags (Polymorphic, level, Heavy)
  21.159 -         | ("tags", (SOME poly, _, _)) => Tags (poly, level, heaviness)
  21.160 -         | ("args", (SOME poly, All_Types (* naja *), Light)) =>
  21.161 -           Preds (poly, Const_Arg_Types, Light)
  21.162 -         | ("erased", (NONE, All_Types (* naja *), Light)) =>
  21.163 -           Preds (Polymorphic, No_Types, Light)
  21.164 -         | _ => raise Same.SAME)
  21.165 -  handle Same.SAME => error ("Unknown type system: " ^ quote s ^ ".")
  21.166 -
  21.167 -fun polymorphism_of_type_sys (Simple_Types _) = Mangled_Monomorphic
  21.168 -  | polymorphism_of_type_sys (Preds (poly, _, _)) = poly
  21.169 -  | polymorphism_of_type_sys (Tags (poly, _, _)) = poly
  21.170 -
  21.171 -fun level_of_type_sys (Simple_Types level) = level
  21.172 -  | level_of_type_sys (Preds (_, level, _)) = level
  21.173 -  | level_of_type_sys (Tags (_, level, _)) = level
  21.174 -
  21.175 -fun heaviness_of_type_sys (Simple_Types _) = Heavy
  21.176 -  | heaviness_of_type_sys (Preds (_, _, heaviness)) = heaviness
  21.177 -  | heaviness_of_type_sys (Tags (_, _, heaviness)) = heaviness
  21.178 -
  21.179 -fun is_type_level_virtually_sound level =
  21.180 -  level = All_Types orelse level = Nonmonotonic_Types
  21.181 -val is_type_sys_virtually_sound =
  21.182 -  is_type_level_virtually_sound o level_of_type_sys
  21.183 -
  21.184 -fun is_type_level_fairly_sound level =
  21.185 -  is_type_level_virtually_sound level orelse level = Finite_Types
  21.186 -val is_type_sys_fairly_sound = is_type_level_fairly_sound o level_of_type_sys
  21.187 -
  21.188 -fun is_setting_higher_order THF (Simple_Types _) = true
  21.189 -  | is_setting_higher_order _ _ = false
  21.190 -
  21.191 -type translated_formula =
  21.192 -  {name: string,
  21.193 -   locality: locality,
  21.194 -   kind: formula_kind,
  21.195 -   combformula: (name, typ, combterm) formula,
  21.196 -   atomic_types: typ list}
  21.197 -
  21.198 -fun update_combformula f ({name, locality, kind, combformula, atomic_types}
  21.199 -                          : translated_formula) =
  21.200 -  {name = name, locality = locality, kind = kind, combformula = f combformula,
  21.201 -   atomic_types = atomic_types} : translated_formula
  21.202 -
  21.203 -fun fact_lift f ({combformula, ...} : translated_formula) = f combformula
  21.204 -
  21.205 -val type_instance = Sign.typ_instance o Proof_Context.theory_of
  21.206 -
  21.207 -fun insert_type ctxt get_T x xs =
  21.208 -  let val T = get_T x in
  21.209 -    if exists (curry (type_instance ctxt) T o get_T) xs then xs
  21.210 -    else x :: filter_out (curry (type_instance ctxt o swap) T o get_T) xs
  21.211 -  end
  21.212 -
  21.213 -(* The Booleans indicate whether all type arguments should be kept. *)
  21.214 -datatype type_arg_policy =
  21.215 -  Explicit_Type_Args of bool |
  21.216 -  Mangled_Type_Args of bool |
  21.217 -  No_Type_Args
  21.218 -
  21.219 -fun should_drop_arg_type_args (Simple_Types _) =
  21.220 -    false (* since TFF doesn't support overloading *)
  21.221 -  | should_drop_arg_type_args type_sys =
  21.222 -    level_of_type_sys type_sys = All_Types andalso
  21.223 -    heaviness_of_type_sys type_sys = Heavy
  21.224 -
  21.225 -fun general_type_arg_policy type_sys =
  21.226 -  if level_of_type_sys type_sys = No_Types then
  21.227 -    No_Type_Args
  21.228 -  else if polymorphism_of_type_sys type_sys = Mangled_Monomorphic then
  21.229 -    Mangled_Type_Args (should_drop_arg_type_args type_sys)
  21.230 -  else
  21.231 -    Explicit_Type_Args (should_drop_arg_type_args type_sys)
  21.232 -
  21.233 -fun type_arg_policy type_sys s =
  21.234 -  if s = @{const_name HOL.eq} orelse
  21.235 -     (s = app_op_name andalso level_of_type_sys type_sys = Const_Arg_Types) then
  21.236 -    No_Type_Args
  21.237 -  else
  21.238 -    general_type_arg_policy type_sys
  21.239 -
  21.240 -fun atp_type_literals_for_types format type_sys kind Ts =
  21.241 -  if level_of_type_sys type_sys = No_Types orelse format = CNF_UEQ then
  21.242 -    []
  21.243 -  else
  21.244 -    Ts |> type_literals_for_types
  21.245 -       |> filter (fn TyLitVar _ => kind <> Conjecture
  21.246 -                   | TyLitFree _ => kind = Conjecture)
  21.247 -
  21.248 -fun mk_aconns c phis =
  21.249 -  let val (phis', phi') = split_last phis in
  21.250 -    fold_rev (mk_aconn c) phis' phi'
  21.251 -  end
  21.252 -fun mk_ahorn [] phi = phi
  21.253 -  | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi])
  21.254 -fun mk_aquant _ [] phi = phi
  21.255 -  | mk_aquant q xs (phi as AQuant (q', xs', phi')) =
  21.256 -    if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi)
  21.257 -  | mk_aquant q xs phi = AQuant (q, xs, phi)
  21.258 -
  21.259 -fun close_universally atom_vars phi =
  21.260 -  let
  21.261 -    fun formula_vars bounds (AQuant (_, xs, phi)) =
  21.262 -        formula_vars (map fst xs @ bounds) phi
  21.263 -      | formula_vars bounds (AConn (_, phis)) = fold (formula_vars bounds) phis
  21.264 -      | formula_vars bounds (AAtom tm) =
  21.265 -        union (op =) (atom_vars tm []
  21.266 -                      |> filter_out (member (op =) bounds o fst))
  21.267 -  in mk_aquant AForall (formula_vars [] phi []) phi end
  21.268 -
  21.269 -fun combterm_vars (CombApp (tm1, tm2)) = fold combterm_vars [tm1, tm2]
  21.270 -  | combterm_vars (CombConst _) = I
  21.271 -  | combterm_vars (CombVar (name, T)) = insert (op =) (name, SOME T)
  21.272 -fun close_combformula_universally phi = close_universally combterm_vars phi
  21.273 -
  21.274 -fun term_vars (ATerm (name as (s, _), tms)) =
  21.275 -  is_tptp_variable s ? insert (op =) (name, NONE) #> fold term_vars tms
  21.276 -fun close_formula_universally phi = close_universally term_vars phi
  21.277 -
  21.278 -val homo_infinite_type_name = @{type_name ind} (* any infinite type *)
  21.279 -val homo_infinite_type = Type (homo_infinite_type_name, [])
  21.280 -
  21.281 -fun fo_term_from_typ higher_order =
  21.282 -  let
  21.283 -    fun term (Type (s, Ts)) =
  21.284 -      ATerm (case (higher_order, s) of
  21.285 -               (true, @{type_name bool}) => `I tptp_bool_type
  21.286 -             | (true, @{type_name fun}) => `I tptp_fun_type
  21.287 -             | _ => if s = homo_infinite_type_name then `I tptp_individual_type
  21.288 -                    else `make_fixed_type_const s,
  21.289 -             map term Ts)
  21.290 -    | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, [])
  21.291 -    | term (TVar ((x as (s, _)), _)) =
  21.292 -      ATerm ((make_schematic_type_var x, s), [])
  21.293 -  in term end
  21.294 -
  21.295 -(* This shouldn't clash with anything else. *)
  21.296 -val mangled_type_sep = "\000"
  21.297 -
  21.298 -fun generic_mangled_type_name f (ATerm (name, [])) = f name
  21.299 -  | generic_mangled_type_name f (ATerm (name, tys)) =
  21.300 -    f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys)
  21.301 -    ^ ")"
  21.302 -
  21.303 -val bool_atype = AType (`I tptp_bool_type)
  21.304 -
  21.305 -fun ho_type_from_fo_term higher_order pred_sym ary =
  21.306 -  let
  21.307 -    fun to_atype ty =
  21.308 -      AType ((make_simple_type (generic_mangled_type_name fst ty),
  21.309 -              generic_mangled_type_name snd ty))
  21.310 -    fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1))
  21.311 -    fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty
  21.312 -      | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys
  21.313 -    fun to_ho (ty as ATerm ((s, _), tys)) =
  21.314 -      if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty
  21.315 -  in if higher_order then to_ho else to_fo ary end
  21.316 -
  21.317 -fun mangled_type higher_order pred_sym ary =
  21.318 -  ho_type_from_fo_term higher_order pred_sym ary o fo_term_from_typ higher_order
  21.319 -
  21.320 -fun mangled_const_name T_args (s, s') =
  21.321 -  let
  21.322 -    val ty_args = map (fo_term_from_typ false) T_args
  21.323 -    fun type_suffix f g =
  21.324 -      fold_rev (curry (op ^) o g o prefix mangled_type_sep
  21.325 -                o generic_mangled_type_name f) ty_args ""
  21.326 -  in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end
  21.327 -
  21.328 -val parse_mangled_ident =
  21.329 -  Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode
  21.330 -
  21.331 -fun parse_mangled_type x =
  21.332 -  (parse_mangled_ident
  21.333 -   -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")")
  21.334 -                    [] >> ATerm) x
  21.335 -and parse_mangled_types x =
  21.336 -  (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x
  21.337 -
  21.338 -fun unmangled_type s =
  21.339 -  s |> suffix ")" |> raw_explode
  21.340 -    |> Scan.finite Symbol.stopper
  21.341 -           (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^
  21.342 -                                                quote s)) parse_mangled_type))
  21.343 -    |> fst
  21.344 -
  21.345 -val unmangled_const_name = space_explode mangled_type_sep #> hd
  21.346 -fun unmangled_const s =
  21.347 -  let val ss = space_explode mangled_type_sep s in
  21.348 -    (hd ss, map unmangled_type (tl ss))
  21.349 -  end
  21.350 -
  21.351 -fun introduce_proxies format type_sys =
  21.352 -  let
  21.353 -    fun intro top_level (CombApp (tm1, tm2)) =
  21.354 -        CombApp (intro top_level tm1, intro false tm2)
  21.355 -      | intro top_level (CombConst (name as (s, _), T, T_args)) =
  21.356 -        (case proxify_const s of
  21.357 -           SOME (_, proxy_base) =>
  21.358 -           if top_level orelse is_setting_higher_order format type_sys then
  21.359 -             case (top_level, s) of
  21.360 -               (_, "c_False") => (`I tptp_false, [])
  21.361 -             | (_, "c_True") => (`I tptp_true, [])
  21.362 -             | (false, "c_Not") => (`I tptp_not, [])
  21.363 -             | (false, "c_conj") => (`I tptp_and, [])
  21.364 -             | (false, "c_disj") => (`I tptp_or, [])
  21.365 -             | (false, "c_implies") => (`I tptp_implies, [])
  21.366 -             | (false, s) =>
  21.367 -               if is_tptp_equal s then (`I tptp_equal, [])
  21.368 -               else (proxy_base |>> prefix const_prefix, T_args)
  21.369 -             | _ => (name, [])
  21.370 -           else
  21.371 -             (proxy_base |>> prefix const_prefix, T_args)
  21.372 -          | NONE => (name, T_args))
  21.373 -        |> (fn (name, T_args) => CombConst (name, T, T_args))
  21.374 -      | intro _ tm = tm
  21.375 -  in intro true end
  21.376 -
  21.377 -fun combformula_from_prop thy format type_sys eq_as_iff =
  21.378 -  let
  21.379 -    fun do_term bs t atomic_types =
  21.380 -      combterm_from_term thy bs (Envir.eta_contract t)
  21.381 -      |>> (introduce_proxies format type_sys #> AAtom)
  21.382 -      ||> union (op =) atomic_types
  21.383 -    fun do_quant bs q s T t' =
  21.384 -      let val s = Name.variant (map fst bs) s in
  21.385 -        do_formula ((s, T) :: bs) t'
  21.386 -        #>> mk_aquant q [(`make_bound_var s, SOME T)]
  21.387 -      end
  21.388 -    and do_conn bs c t1 t2 =
  21.389 -      do_formula bs t1 ##>> do_formula bs t2
  21.390 -      #>> uncurry (mk_aconn c)
  21.391 -    and do_formula bs t =
  21.392 -      case t of
  21.393 -        @{const Not} $ t1 => do_formula bs t1 #>> mk_anot
  21.394 -      | Const (@{const_name All}, _) $ Abs (s, T, t') =>
  21.395 -        do_quant bs AForall s T t'
  21.396 -      | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
  21.397 -        do_quant bs AExists s T t'
  21.398 -      | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd t1 t2
  21.399 -      | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr t1 t2
  21.400 -      | @{const HOL.implies} $ t1 $ t2 => do_conn bs AImplies t1 t2
  21.401 -      | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 =>
  21.402 -        if eq_as_iff then do_conn bs AIff t1 t2 else do_term bs t
  21.403 -      | _ => do_term bs t
  21.404 -  in do_formula [] end
  21.405 -
  21.406 -fun presimplify_term ctxt =
  21.407 -  Skip_Proof.make_thm (Proof_Context.theory_of ctxt)
  21.408 -  #> Meson.presimplify ctxt
  21.409 -  #> prop_of
  21.410 -
  21.411 -fun concealed_bound_name j = sledgehammer_weak_prefix ^ string_of_int j
  21.412 -fun conceal_bounds Ts t =
  21.413 -  subst_bounds (map (Free o apfst concealed_bound_name)
  21.414 -                    (0 upto length Ts - 1 ~~ Ts), t)
  21.415 -fun reveal_bounds Ts =
  21.416 -  subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j))
  21.417 -                    (0 upto length Ts - 1 ~~ Ts))
  21.418 -
  21.419 -fun extensionalize_term ctxt t =
  21.420 -  let val thy = Proof_Context.theory_of ctxt in
  21.421 -    t |> cterm_of thy |> Meson.extensionalize_conv ctxt
  21.422 -      |> prop_of |> Logic.dest_equals |> snd
  21.423 -  end
  21.424 -
  21.425 -fun introduce_combinators_in_term ctxt kind t =
  21.426 -  let val thy = Proof_Context.theory_of ctxt in
  21.427 -    if Meson.is_fol_term thy t then
  21.428 -      t
  21.429 -    else
  21.430 -      let
  21.431 -        fun aux Ts t =
  21.432 -          case t of
  21.433 -            @{const Not} $ t1 => @{const Not} $ aux Ts t1
  21.434 -          | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') =>
  21.435 -            t0 $ Abs (s, T, aux (T :: Ts) t')
  21.436 -          | (t0 as Const (@{const_name All}, _)) $ t1 =>
  21.437 -            aux Ts (t0 $ eta_expand Ts t1 1)
  21.438 -          | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') =>
  21.439 -            t0 $ Abs (s, T, aux (T :: Ts) t')
  21.440 -          | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
  21.441 -            aux Ts (t0 $ eta_expand Ts t1 1)
  21.442 -          | (t0 as @{const HOL.conj}) $ t1 $ t2 => t0 $ aux Ts t1 $ aux Ts t2
  21.443 -          | (t0 as @{const HOL.disj}) $ t1 $ t2 => t0 $ aux Ts t1 $ aux Ts t2
  21.444 -          | (t0 as @{const HOL.implies}) $ t1 $ t2 => t0 $ aux Ts t1 $ aux Ts t2
  21.445 -          | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])))
  21.446 -              $ t1 $ t2 =>
  21.447 -            t0 $ aux Ts t1 $ aux Ts t2
  21.448 -          | _ => if not (exists_subterm (fn Abs _ => true | _ => false) t) then
  21.449 -                   t
  21.450 -                 else
  21.451 -                   t |> conceal_bounds Ts
  21.452 -                     |> Envir.eta_contract
  21.453 -                     |> cterm_of thy
  21.454 -                     |> Meson_Clausify.introduce_combinators_in_cterm
  21.455 -                     |> prop_of |> Logic.dest_equals |> snd
  21.456 -                     |> reveal_bounds Ts
  21.457 -        val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single
  21.458 -      in t |> aux [] |> singleton (Variable.export_terms ctxt' ctxt) end
  21.459 -      handle THM _ =>
  21.460 -             (* A type variable of sort "{}" will make abstraction fail. *)
  21.461 -             if kind = Conjecture then HOLogic.false_const
  21.462 -             else HOLogic.true_const
  21.463 -  end
  21.464 -
  21.465 -(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the
  21.466 -   same in Sledgehammer to prevent the discovery of unreplayable proofs. *)
  21.467 -fun freeze_term t =
  21.468 -  let
  21.469 -    fun aux (t $ u) = aux t $ aux u
  21.470 -      | aux (Abs (s, T, t)) = Abs (s, T, aux t)
  21.471 -      | aux (Var ((s, i), T)) =
  21.472 -        Free (sledgehammer_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
  21.473 -      | aux t = t
  21.474 -  in t |> exists_subterm is_Var t ? aux end
  21.475 -
  21.476 -(* making fact and conjecture formulas *)
  21.477 -fun make_formula ctxt format type_sys eq_as_iff presimp name loc kind t =
  21.478 -  let
  21.479 -    val thy = Proof_Context.theory_of ctxt
  21.480 -    val t = t |> Envir.beta_eta_contract
  21.481 -              |> transform_elim_prop
  21.482 -              |> Object_Logic.atomize_term thy
  21.483 -    val need_trueprop = (fastype_of t = @{typ bool})
  21.484 -    val t = t |> need_trueprop ? HOLogic.mk_Trueprop
  21.485 -              |> Raw_Simplifier.rewrite_term thy
  21.486 -                     (Meson.unfold_set_const_simps ctxt) []
  21.487 -              |> extensionalize_term ctxt
  21.488 -              |> presimp ? presimplify_term ctxt
  21.489 -              |> perhaps (try (HOLogic.dest_Trueprop))
  21.490 -              |> introduce_combinators_in_term ctxt kind
  21.491 -              |> kind <> Axiom ? freeze_term
  21.492 -    val (combformula, atomic_types) =
  21.493 -      combformula_from_prop thy format type_sys eq_as_iff t []
  21.494 -  in
  21.495 -    {name = name, locality = loc, kind = kind, combformula = combformula,
  21.496 -     atomic_types = atomic_types}
  21.497 -  end
  21.498 -
  21.499 -fun make_fact ctxt format type_sys keep_trivial eq_as_iff presimp
  21.500 -              ((name, loc), t) =
  21.501 -  case (keep_trivial,
  21.502 -        make_formula ctxt format type_sys eq_as_iff presimp name loc Axiom t) of
  21.503 -    (false, formula as {combformula = AAtom (CombConst ((s, _), _, _)), ...}) =>
  21.504 -    if s = tptp_true then NONE else SOME formula
  21.505 -  | (_, formula) => SOME formula
  21.506 -
  21.507 -fun make_conjecture ctxt format prem_kind type_sys ts =
  21.508 -  let val last = length ts - 1 in
  21.509 -    map2 (fn j => fn t =>
  21.510 -             let
  21.511 -               val (kind, maybe_negate) =
  21.512 -                 if j = last then
  21.513 -                   (Conjecture, I)
  21.514 -                 else
  21.515 -                   (prem_kind,
  21.516 -                    if prem_kind = Conjecture then update_combformula mk_anot
  21.517 -                    else I)
  21.518 -              in
  21.519 -                t |> make_formula ctxt format type_sys true true
  21.520 -                                  (string_of_int j) General kind
  21.521 -                  |> maybe_negate
  21.522 -              end)
  21.523 -         (0 upto last) ts
  21.524 -  end
  21.525 -
  21.526 -(** Finite and infinite type inference **)
  21.527 -
  21.528 -fun deep_freeze_atyp (TVar (_, S)) = TFree ("v", S)
  21.529 -  | deep_freeze_atyp T = T
  21.530 -val deep_freeze_type = map_atyps deep_freeze_atyp
  21.531 -
  21.532 -(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are
  21.533 -   dangerous because their "exhaust" properties can easily lead to unsound ATP
  21.534 -   proofs. On the other hand, all HOL infinite types can be given the same
  21.535 -   models in first-order logic (via Löwenheim-Skolem). *)
  21.536 -
  21.537 -fun should_encode_type ctxt (nonmono_Ts as _ :: _) _ T =
  21.538 -    exists (curry (type_instance ctxt) (deep_freeze_type T)) nonmono_Ts
  21.539 -  | should_encode_type _ _ All_Types _ = true
  21.540 -  | should_encode_type ctxt _ Finite_Types T = is_type_surely_finite ctxt T
  21.541 -  | should_encode_type _ _ _ _ = false
  21.542 -
  21.543 -fun should_predicate_on_type ctxt nonmono_Ts (Preds (_, level, heaviness))
  21.544 -                             should_predicate_on_var T =
  21.545 -    (heaviness = Heavy orelse should_predicate_on_var ()) andalso
  21.546 -    should_encode_type ctxt nonmono_Ts level T
  21.547 -  | should_predicate_on_type _ _ _ _ _ = false
  21.548 -
  21.549 -fun is_var_or_bound_var (CombConst ((s, _), _, _)) =
  21.550 -    String.isPrefix bound_var_prefix s
  21.551 -  | is_var_or_bound_var (CombVar _) = true
  21.552 -  | is_var_or_bound_var _ = false
  21.553 -
  21.554 -datatype tag_site = Top_Level | Eq_Arg | Elsewhere
  21.555 -
  21.556 -fun should_tag_with_type _ _ _ Top_Level _ _ = false
  21.557 -  | should_tag_with_type ctxt nonmono_Ts (Tags (_, level, heaviness)) site u T =
  21.558 -    (case heaviness of
  21.559 -       Heavy => should_encode_type ctxt nonmono_Ts level T
  21.560 -     | Light =>
  21.561 -       case (site, is_var_or_bound_var u) of
  21.562 -         (Eq_Arg, true) => should_encode_type ctxt nonmono_Ts level T
  21.563 -       | _ => false)
  21.564 -  | should_tag_with_type _ _ _ _ _ _ = false
  21.565 -
  21.566 -fun homogenized_type ctxt nonmono_Ts level =
  21.567 -  let
  21.568 -    val should_encode = should_encode_type ctxt nonmono_Ts level
  21.569 -    fun homo 0 T = if should_encode T then T else homo_infinite_type
  21.570 -      | homo ary (Type (@{type_name fun}, [T1, T2])) =
  21.571 -        homo 0 T1 --> homo (ary - 1) T2
  21.572 -      | homo _ _ = raise Fail "expected function type"
  21.573 -  in homo end
  21.574 -
  21.575 -(** "hBOOL" and "hAPP" **)
  21.576 -
  21.577 -type sym_info =
  21.578 -  {pred_sym : bool, min_ary : int, max_ary : int, types : typ list}
  21.579 -
  21.580 -fun add_combterm_syms_to_table ctxt explicit_apply =
  21.581 -  let
  21.582 -    fun consider_var_arity const_T var_T max_ary =
  21.583 -      let
  21.584 -        fun iter ary T =
  21.585 -          if ary = max_ary orelse type_instance ctxt (var_T, T) then ary
  21.586 -          else iter (ary + 1) (range_type T)
  21.587 -      in iter 0 const_T end
  21.588 -    fun add top_level tm (accum as (ho_var_Ts, sym_tab)) =
  21.589 -      let val (head, args) = strip_combterm_comb tm in
  21.590 -        (case head of
  21.591 -           CombConst ((s, _), T, _) =>
  21.592 -           if String.isPrefix bound_var_prefix s then
  21.593 -             if explicit_apply = NONE andalso can dest_funT T then
  21.594 -               let
  21.595 -                 fun repair_min_arity {pred_sym, min_ary, max_ary, types} =
  21.596 -                   {pred_sym = pred_sym,
  21.597 -                    min_ary =
  21.598 -                      fold (fn T' => consider_var_arity T' T) types min_ary,
  21.599 -                    max_ary = max_ary, types = types}
  21.600 -                 val ho_var_Ts' = ho_var_Ts |> insert_type ctxt I T
  21.601 -               in
  21.602 -                 if pointer_eq (ho_var_Ts', ho_var_Ts) then accum
  21.603 -                 else (ho_var_Ts', Symtab.map (K repair_min_arity) sym_tab)
  21.604 -               end
  21.605 -             else
  21.606 -               accum
  21.607 -           else
  21.608 -             let
  21.609 -               val ary = length args
  21.610 -             in
  21.611 -               (ho_var_Ts,
  21.612 -                case Symtab.lookup sym_tab s of
  21.613 -                  SOME {pred_sym, min_ary, max_ary, types} =>
  21.614 -                  let
  21.615 -                    val types' = types |> insert_type ctxt I T
  21.616 -                    val min_ary =
  21.617 -                      if is_some explicit_apply orelse
  21.618 -                         pointer_eq (types', types) then
  21.619 -                        min_ary
  21.620 -                      else
  21.621 -                        fold (consider_var_arity T) ho_var_Ts min_ary
  21.622 -                  in
  21.623 -                    Symtab.update (s, {pred_sym = pred_sym andalso top_level,
  21.624 -                                       min_ary = Int.min (ary, min_ary),
  21.625 -                                       max_ary = Int.max (ary, max_ary),
  21.626 -                                       types = types'})
  21.627 -                                  sym_tab
  21.628 -                  end
  21.629 -                | NONE =>
  21.630 -                  let
  21.631 -                    val min_ary =
  21.632 -                      case explicit_apply of
  21.633 -                        SOME true => 0
  21.634 -                      | SOME false => ary
  21.635 -                      | NONE => fold (consider_var_arity T) ho_var_Ts ary
  21.636 -                  in
  21.637 -                    Symtab.update_new (s, {pred_sym = top_level,
  21.638 -                                           min_ary = min_ary, max_ary = ary,
  21.639 -                                           types = [T]})
  21.640 -                                      sym_tab
  21.641 -                  end)
  21.642 -             end
  21.643 -         | _ => accum)
  21.644 -        |> fold (add false) args
  21.645 -      end
  21.646 -  in add true end
  21.647 -fun add_fact_syms_to_table ctxt explicit_apply =
  21.648 -  fact_lift (formula_fold NONE
  21.649 -                          (K (add_combterm_syms_to_table ctxt explicit_apply)))
  21.650 -
  21.651 -val default_sym_table_entries : (string * sym_info) list =
  21.652 -  [(tptp_equal, {pred_sym = true, min_ary = 2, max_ary = 2, types = []}),
  21.653 -   (tptp_old_equal, {pred_sym = true, min_ary = 2, max_ary = 2, types = []}),
  21.654 -   (make_fixed_const predicator_name,
  21.655 -    {pred_sym = true, min_ary = 1, max_ary = 1, types = []})] @
  21.656 -  ([tptp_false, tptp_true]
  21.657 -   |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = []}))
  21.658 -
  21.659 -fun sym_table_for_facts ctxt explicit_apply facts =
  21.660 -  Symtab.empty
  21.661 -  |> fold Symtab.default default_sym_table_entries
  21.662 -  |> pair [] |> fold (add_fact_syms_to_table ctxt explicit_apply) facts |> snd
  21.663 -
  21.664 -fun min_arity_of sym_tab s =
  21.665 -  case Symtab.lookup sym_tab s of
  21.666 -    SOME ({min_ary, ...} : sym_info) => min_ary
  21.667 -  | NONE =>
  21.668 -    case strip_prefix_and_unascii const_prefix s of
  21.669 -      SOME s =>
  21.670 -      let val s = s |> unmangled_const_name |> invert_const in
  21.671 -        if s = predicator_name then 1
  21.672 -        else if s = app_op_name then 2
  21.673 -        else if s = type_pred_name then 1
  21.674 -        else 0
  21.675 -      end
  21.676 -    | NONE => 0
  21.677 -
  21.678 -(* True if the constant ever appears outside of the top-level position in
  21.679 -   literals, or if it appears with different arities (e.g., because of different
  21.680 -   type instantiations). If false, the constant always receives all of its
  21.681 -   arguments and is used as a predicate. *)
  21.682 -fun is_pred_sym sym_tab s =
  21.683 -  case Symtab.lookup sym_tab s of
  21.684 -    SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) =>
  21.685 -    pred_sym andalso min_ary = max_ary
  21.686 -  | NONE => false
  21.687 -
  21.688 -val predicator_combconst =
  21.689 -  CombConst (`make_fixed_const predicator_name, @{typ "bool => bool"}, [])
  21.690 -fun predicator tm = CombApp (predicator_combconst, tm)
  21.691 -
  21.692 -fun introduce_predicators_in_combterm sym_tab tm =
  21.693 -  case strip_combterm_comb tm of
  21.694 -    (CombConst ((s, _), _, _), _) =>
  21.695 -    if is_pred_sym sym_tab s then tm else predicator tm
  21.696 -  | _ => predicator tm
  21.697 -
  21.698 -fun list_app head args = fold (curry (CombApp o swap)) args head
  21.699 -
  21.700 -fun explicit_app arg head =
  21.701 -  let
  21.702 -    val head_T = combtyp_of head
  21.703 -    val (arg_T, res_T) = dest_funT head_T
  21.704 -    val explicit_app =
  21.705 -      CombConst (`make_fixed_const app_op_name, head_T --> head_T,
  21.706 -                 [arg_T, res_T])
  21.707 -  in list_app explicit_app [head, arg] end
  21.708 -fun list_explicit_app head args = fold explicit_app args head
  21.709 -
  21.710 -fun introduce_explicit_apps_in_combterm sym_tab =
  21.711 -  let
  21.712 -    fun aux tm =
  21.713 -      case strip_combterm_comb tm of
  21.714 -        (head as CombConst ((s, _), _, _), args) =>
  21.715 -        args |> map aux
  21.716 -             |> chop (min_arity_of sym_tab s)
  21.717 -             |>> list_app head
  21.718 -             |-> list_explicit_app
  21.719 -      | (head, args) => list_explicit_app head (map aux args)
  21.720 -  in aux end
  21.721 -
  21.722 -fun chop_fun 0 T = ([], T)
  21.723 -  | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) =
  21.724 -    chop_fun (n - 1) ran_T |>> cons dom_T
  21.725 -  | chop_fun _ _ = raise Fail "unexpected non-function"
  21.726 -
  21.727 -fun filter_type_args _ _ _ [] = []
  21.728 -  | filter_type_args thy s arity T_args =
  21.729 -    let
  21.730 -      (* will throw "TYPE" for pseudo-constants *)
  21.731 -      val U = if s = app_op_name then
  21.732 -                @{typ "('a => 'b) => 'a => 'b"} |> Logic.varifyT_global
  21.733 -              else
  21.734 -                s |> Sign.the_const_type thy
  21.735 -    in
  21.736 -      case Term.add_tvarsT (U |> chop_fun arity |> snd) [] of
  21.737 -        [] => []
  21.738 -      | res_U_vars =>
  21.739 -        let val U_args = (s, U) |> Sign.const_typargs thy in
  21.740 -          U_args ~~ T_args
  21.741 -          |> map_filter (fn (U, T) =>
  21.742 -                            if member (op =) res_U_vars (dest_TVar U) then
  21.743 -                              SOME T
  21.744 -                            else
  21.745 -                              NONE)
  21.746 -        end
  21.747 -    end
  21.748 -    handle TYPE _ => T_args
  21.749 -
  21.750 -fun enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys =
  21.751 -  let
  21.752 -    val thy = Proof_Context.theory_of ctxt
  21.753 -    fun aux arity (CombApp (tm1, tm2)) =
  21.754 -        CombApp (aux (arity + 1) tm1, aux 0 tm2)
  21.755 -      | aux arity (CombConst (name as (s, _), T, T_args)) =
  21.756 -        let
  21.757 -          val level = level_of_type_sys type_sys
  21.758 -          val (T, T_args) =
  21.759 -            (* Aggressively merge most "hAPPs" if the type system is unsound
  21.760 -               anyway, by distinguishing overloads only on the homogenized
  21.761 -               result type. Don't do it for lightweight type systems, though,
  21.762 -               since it leads to too many unsound proofs. *)
  21.763 -            if s = const_prefix ^ app_op_name andalso
  21.764 -               length T_args = 2 andalso
  21.765 -               not (is_type_sys_virtually_sound type_sys) andalso
  21.766 -               heaviness_of_type_sys type_sys = Heavy then
  21.767 -              T_args |> map (homogenized_type ctxt nonmono_Ts level 0)
  21.768 -                     |> (fn Ts => let val T = hd Ts --> nth Ts 1 in
  21.769 -                                    (T --> T, tl Ts)
  21.770 -                                  end)
  21.771 -            else
  21.772 -              (T, T_args)
  21.773 -        in
  21.774 -          (case strip_prefix_and_unascii const_prefix s of
  21.775 -             NONE => (name, T_args)
  21.776 -           | SOME s'' =>
  21.777 -             let
  21.778 -               val s'' = invert_const s''
  21.779 -               fun filtered_T_args false = T_args
  21.780 -                 | filtered_T_args true = filter_type_args thy s'' arity T_args
  21.781 -             in
  21.782 -               case type_arg_policy type_sys s'' of
  21.783 -                 Explicit_Type_Args drop_args =>
  21.784 -                 (name, filtered_T_args drop_args)
  21.785 -               | Mangled_Type_Args drop_args =>
  21.786 -                 (mangled_const_name (filtered_T_args drop_args) name, [])
  21.787 -               | No_Type_Args => (name, [])
  21.788 -             end)
  21.789 -          |> (fn (name, T_args) => CombConst (name, T, T_args))
  21.790 -        end
  21.791 -      | aux _ tm = tm
  21.792 -  in aux 0 end
  21.793 -
  21.794 -fun repair_combterm ctxt format nonmono_Ts type_sys sym_tab =
  21.795 -  not (is_setting_higher_order format type_sys)
  21.796 -  ? (introduce_explicit_apps_in_combterm sym_tab
  21.797 -     #> introduce_predicators_in_combterm sym_tab)
  21.798 -  #> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys
  21.799 -fun repair_fact ctxt format nonmono_Ts type_sys sym_tab =
  21.800 -  update_combformula (formula_map
  21.801 -      (repair_combterm ctxt format nonmono_Ts type_sys sym_tab))
  21.802 -
  21.803 -(** Helper facts **)
  21.804 -
  21.805 -fun ti_ti_helper_fact () =
  21.806 -  let
  21.807 -    fun var s = ATerm (`I s, [])
  21.808 -    fun tag tm = ATerm (`make_fixed_const type_tag_name, [var "X", tm])
  21.809 -  in
  21.810 -    Formula (helper_prefix ^ "ti_ti", Axiom,
  21.811 -             AAtom (ATerm (`I tptp_equal, [tag (tag (var "Y")), tag (var "Y")]))
  21.812 -             |> close_formula_universally, simp_info, NONE)
  21.813 -  end
  21.814 -
  21.815 -fun helper_facts_for_sym ctxt format type_sys (s, {types, ...} : sym_info) =
  21.816 -  case strip_prefix_and_unascii const_prefix s of
  21.817 -    SOME mangled_s =>
  21.818 -    let
  21.819 -      val thy = Proof_Context.theory_of ctxt
  21.820 -      val unmangled_s = mangled_s |> unmangled_const_name
  21.821 -      fun dub_and_inst c needs_fairly_sound (th, j) =
  21.822 -        ((c ^ "_" ^ string_of_int j ^
  21.823 -          (if needs_fairly_sound then typed_helper_suffix
  21.824 -           else untyped_helper_suffix),
  21.825 -          General),
  21.826 -         let val t = th |> prop_of in
  21.827 -           t |> ((case general_type_arg_policy type_sys of
  21.828 -                    Mangled_Type_Args _ => true
  21.829 -                  | _ => false) andalso
  21.830 -                 not (null (Term.hidden_polymorphism t)))
  21.831 -                ? (case types of
  21.832 -                     [T] => specialize_type thy (invert_const unmangled_s, T)
  21.833 -                   | _ => I)
  21.834 -         end)
  21.835 -      fun make_facts eq_as_iff =
  21.836 -        map_filter (make_fact ctxt format type_sys false eq_as_iff false)
  21.837 -      val fairly_sound = is_type_sys_fairly_sound type_sys
  21.838 -    in
  21.839 -      metis_helpers
  21.840 -      |> maps (fn (metis_s, (needs_fairly_sound, ths)) =>
  21.841 -                  if metis_s <> unmangled_s orelse
  21.842 -                     (needs_fairly_sound andalso not fairly_sound) then
  21.843 -                    []
  21.844 -                  else
  21.845 -                    ths ~~ (1 upto length ths)
  21.846 -                    |> map (dub_and_inst mangled_s needs_fairly_sound)
  21.847 -                    |> make_facts (not needs_fairly_sound))
  21.848 -    end
  21.849 -  | NONE => []
  21.850 -fun helper_facts_for_sym_table ctxt format type_sys sym_tab =
  21.851 -  Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_sys) sym_tab
  21.852 -                  []
  21.853 -
  21.854 -fun translate_atp_fact ctxt format type_sys keep_trivial =
  21.855 -  `(make_fact ctxt format type_sys keep_trivial true true o apsnd prop_of)
  21.856 -
  21.857 -fun translate_formulas ctxt format prem_kind type_sys hyp_ts concl_t
  21.858 -                       rich_facts =
  21.859 -  let
  21.860 -    val thy = Proof_Context.theory_of ctxt
  21.861 -    val fact_ts = map (prop_of o snd o snd) rich_facts
  21.862 -    val (facts, fact_names) =
  21.863 -      rich_facts
  21.864 -      |> map_filter (fn (NONE, _) => NONE
  21.865 -                      | (SOME fact, (name, _)) => SOME (fact, name))
  21.866 -      |> ListPair.unzip
  21.867 -    (* Remove existing facts from the conjecture, as this can dramatically
  21.868 -       boost an ATP's performance (for some reason). *)
  21.869 -    val hyp_ts = hyp_ts |> filter_out (member (op aconv) fact_ts)
  21.870 -    val goal_t = Logic.list_implies (hyp_ts, concl_t)
  21.871 -    val all_ts = goal_t :: fact_ts
  21.872 -    val subs = tfree_classes_of_terms all_ts
  21.873 -    val supers = tvar_classes_of_terms all_ts
  21.874 -    val tycons = type_consts_of_terms thy all_ts
  21.875 -    val conjs =
  21.876 -      hyp_ts @ [concl_t] |> make_conjecture ctxt format prem_kind type_sys
  21.877 -    val (supers', arity_clauses) =
  21.878 -      if level_of_type_sys type_sys = No_Types then ([], [])
  21.879 -      else make_arity_clauses thy tycons supers
  21.880 -    val class_rel_clauses = make_class_rel_clauses thy subs supers'
  21.881 -  in
  21.882 -    (fact_names |> map single, (conjs, facts, class_rel_clauses, arity_clauses))
  21.883 -  end
  21.884 -
  21.885 -fun fo_literal_from_type_literal (TyLitVar (class, name)) =
  21.886 -    (true, ATerm (class, [ATerm (name, [])]))
  21.887 -  | fo_literal_from_type_literal (TyLitFree (class, name)) =
  21.888 -    (true, ATerm (class, [ATerm (name, [])]))
  21.889 -
  21.890 -fun formula_from_fo_literal (pos, t) = AAtom t |> not pos ? mk_anot
  21.891 -
  21.892 -fun type_pred_combterm ctxt nonmono_Ts type_sys T tm =
  21.893 -  CombApp (CombConst (`make_fixed_const type_pred_name, T --> @{typ bool}, [T])
  21.894 -           |> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys,
  21.895 -           tm)
  21.896 -
  21.897 -fun var_occurs_positively_naked_in_term _ (SOME false) _ accum = accum
  21.898 -  | var_occurs_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum =
  21.899 -    accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, [])))
  21.900 -fun is_var_nonmonotonic_in_formula _ _ (SOME false) _ = false
  21.901 -  | is_var_nonmonotonic_in_formula pos phi _ name =
  21.902 -    formula_fold pos (var_occurs_positively_naked_in_term name) phi false
  21.903 -
  21.904 -fun mk_const_aterm x T_args args =
  21.905 -  ATerm (x, map (fo_term_from_typ false) T_args @ args)
  21.906 -
  21.907 -fun tag_with_type ctxt format nonmono_Ts type_sys T tm =
  21.908 -  CombConst (`make_fixed_const type_tag_name, T --> T, [T])
  21.909 -  |> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys
  21.910 -  |> term_from_combterm ctxt format nonmono_Ts type_sys Top_Level
  21.911 -  |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm]))
  21.912 -and term_from_combterm ctxt format nonmono_Ts type_sys =
  21.913 -  let
  21.914 -    fun aux site u =
  21.915 -      let
  21.916 -        val (head, args) = strip_combterm_comb u
  21.917 -        val (x as (s, _), T_args) =
  21.918 -          case head of
  21.919 -            CombConst (name, _, T_args) => (name, T_args)
  21.920 -          | CombVar (name, _) => (name, [])
  21.921 -          | CombApp _ => raise Fail "impossible \"CombApp\""
  21.922 -        val arg_site = if site = Top_Level andalso is_tptp_equal s then Eq_Arg
  21.923 -                       else Elsewhere
  21.924 -        val t = mk_const_aterm x T_args (map (aux arg_site) args)
  21.925 -        val T = combtyp_of u
  21.926 -      in
  21.927 -        t |> (if should_tag_with_type ctxt nonmono_Ts type_sys site u T then
  21.928 -                tag_with_type ctxt format nonmono_Ts type_sys T
  21.929 -              else
  21.930 -                I)
  21.931 -      end
  21.932 -  in aux end
  21.933 -and formula_from_combformula ctxt format nonmono_Ts type_sys
  21.934 -                             should_predicate_on_var =
  21.935 -  let
  21.936 -    val higher_order = is_setting_higher_order format type_sys
  21.937 -    val do_term = term_from_combterm ctxt format nonmono_Ts type_sys Top_Level
  21.938 -    val do_bound_type =
  21.939 -      case type_sys of
  21.940 -        Simple_Types level =>
  21.941 -        homogenized_type ctxt nonmono_Ts level 0
  21.942 -        #> mangled_type higher_order false 0 #> SOME
  21.943 -      | _ => K NONE
  21.944 -    fun do_out_of_bound_type pos phi universal (name, T) =
  21.945 -      if should_predicate_on_type ctxt nonmono_Ts type_sys
  21.946 -             (fn () => should_predicate_on_var pos phi universal name) T then
  21.947 -        CombVar (name, T)
  21.948 -        |> type_pred_combterm ctxt nonmono_Ts type_sys T
  21.949 -        |> do_term |> AAtom |> SOME
  21.950 -      else
  21.951 -        NONE
  21.952 -    fun do_formula pos (AQuant (q, xs, phi)) =
  21.953 -        let
  21.954 -          val phi = phi |> do_formula pos
  21.955 -          val universal = Option.map (q = AExists ? not) pos
  21.956 -        in
  21.957 -          AQuant (q, xs |> map (apsnd (fn NONE => NONE
  21.958 -                                        | SOME T => do_bound_type T)),
  21.959 -                  (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd))
  21.960 -                      (map_filter
  21.961 -                           (fn (_, NONE) => NONE
  21.962 -                             | (s, SOME T) =>
  21.963 -                               do_out_of_bound_type pos phi universal (s, T))
  21.964 -                           xs)
  21.965 -                      phi)
  21.966 -        end
  21.967 -      | do_formula pos (AConn conn) = aconn_map pos do_formula conn
  21.968 -      | do_formula _ (AAtom tm) = AAtom (do_term tm)
  21.969 -  in do_formula o SOME end
  21.970 -
  21.971 -fun bound_atomic_types format type_sys Ts =
  21.972 -  mk_ahorn (map (formula_from_fo_literal o fo_literal_from_type_literal)
  21.973 -                (atp_type_literals_for_types format type_sys Axiom Ts))
  21.974 -
  21.975 -fun formula_for_fact ctxt format nonmono_Ts type_sys
  21.976 -                     ({combformula, atomic_types, ...} : translated_formula) =
  21.977 -  combformula
  21.978 -  |> close_combformula_universally
  21.979 -  |> formula_from_combformula ctxt format nonmono_Ts type_sys
  21.980 -                              is_var_nonmonotonic_in_formula true
  21.981 -  |> bound_atomic_types format type_sys atomic_types
  21.982 -  |> close_formula_universally
  21.983 -
  21.984 -(* Each fact is given a unique fact number to avoid name clashes (e.g., because
  21.985 -   of monomorphization). The TPTP explicitly forbids name clashes, and some of
  21.986 -   the remote provers might care. *)
  21.987 -fun formula_line_for_fact ctxt format prefix nonmono_Ts type_sys
  21.988 -                          (j, formula as {name, locality, kind, ...}) =
  21.989 -  Formula (prefix ^ (if polymorphism_of_type_sys type_sys = Polymorphic then ""
  21.990 -                     else string_of_int j ^ "_") ^
  21.991 -           ascii_of name,
  21.992 -           kind, formula_for_fact ctxt format nonmono_Ts type_sys formula, NONE,
  21.993 -           case locality of
  21.994 -             Intro => intro_info
  21.995 -           | Elim => elim_info
  21.996 -           | Simp => simp_info
  21.997 -           | _ => NONE)
  21.998 -
  21.999 -fun formula_line_for_class_rel_clause
 21.1000 -        (ClassRelClause {name, subclass, superclass, ...}) =
 21.1001 -  let val ty_arg = ATerm (`I "T", []) in
 21.1002 -    Formula (class_rel_clause_prefix ^ ascii_of name, Axiom,
 21.1003 -             AConn (AImplies, [AAtom (ATerm (subclass, [ty_arg])),
 21.1004 -                               AAtom (ATerm (superclass, [ty_arg]))])
 21.1005 -             |> close_formula_universally, intro_info, NONE)
 21.1006 -  end
 21.1007 -
 21.1008 -fun fo_literal_from_arity_literal (TConsLit (c, t, args)) =
 21.1009 -    (true, ATerm (c, [ATerm (t, map (fn arg => ATerm (arg, [])) args)]))
 21.1010 -  | fo_literal_from_arity_literal (TVarLit (c, sort)) =
 21.1011 -    (false, ATerm (c, [ATerm (sort, [])]))
 21.1012 -
 21.1013 -fun formula_line_for_arity_clause
 21.1014 -        (ArityClause {name, prem_lits, concl_lits, ...}) =
 21.1015 -  Formula (arity_clause_prefix ^ ascii_of name, Axiom,
 21.1016 -           mk_ahorn (map (formula_from_fo_literal o apfst not
 21.1017 -                          o fo_literal_from_arity_literal) prem_lits)
 21.1018 -                    (formula_from_fo_literal
 21.1019 -                         (fo_literal_from_arity_literal concl_lits))
 21.1020 -           |> close_formula_universally, intro_info, NONE)
 21.1021 -
 21.1022 -fun formula_line_for_conjecture ctxt format nonmono_Ts type_sys
 21.1023 -        ({name, kind, combformula, ...} : translated_formula) =
 21.1024 -  Formula (conjecture_prefix ^ name, kind,
 21.1025 -           formula_from_combformula ctxt format nonmono_Ts type_sys
 21.1026 -               is_var_nonmonotonic_in_formula false
 21.1027 -               (close_combformula_universally combformula)
 21.1028 -           |> close_formula_universally, NONE, NONE)
 21.1029 -
 21.1030 -fun free_type_literals format type_sys
 21.1031 -                       ({atomic_types, ...} : translated_formula) =
 21.1032 -  atomic_types |> atp_type_literals_for_types format type_sys Conjecture
 21.1033 -               |> map fo_literal_from_type_literal
 21.1034 -
 21.1035 -fun formula_line_for_free_type j lit =
 21.1036 -  Formula (tfree_prefix ^ string_of_int j, Hypothesis,
 21.1037 -           formula_from_fo_literal lit, NONE, NONE)
 21.1038 -fun formula_lines_for_free_types format type_sys facts =
 21.1039 -  let
 21.1040 -    val litss = map (free_type_literals format type_sys) facts
 21.1041 -    val lits = fold (union (op =)) litss []
 21.1042 -  in map2 formula_line_for_free_type (0 upto length lits - 1) lits end
 21.1043 -
 21.1044 -(** Symbol declarations **)
 21.1045 -
 21.1046 -fun should_declare_sym type_sys pred_sym s =
 21.1047 -  is_tptp_user_symbol s andalso not (String.isPrefix bound_var_prefix s) andalso
 21.1048 -  (case type_sys of
 21.1049 -     Simple_Types _ => true
 21.1050 -   | Tags (_, _, Light) => true
 21.1051 -   | _ => not pred_sym)
 21.1052 -
 21.1053 -fun sym_decl_table_for_facts ctxt type_sys repaired_sym_tab (conjs, facts) =
 21.1054 -  let
 21.1055 -    fun add_combterm in_conj tm =
 21.1056 -      let val (head, args) = strip_combterm_comb tm in
 21.1057 -        (case head of
 21.1058 -           CombConst ((s, s'), T, T_args) =>
 21.1059 -           let val pred_sym = is_pred_sym repaired_sym_tab s in
 21.1060 -             if should_declare_sym type_sys pred_sym s then
 21.1061 -               Symtab.map_default (s, [])
 21.1062 -                   (insert_type ctxt #3 (s', T_args, T, pred_sym, length args,
 21.1063 -                                         in_conj))
 21.1064 -             else
 21.1065 -               I
 21.1066 -           end
 21.1067 -         | _ => I)
 21.1068 -        #> fold (add_combterm in_conj) args
 21.1069 -      end
 21.1070 -    fun add_fact in_conj =
 21.1071 -      fact_lift (formula_fold NONE (K (add_combterm in_conj)))
 21.1072 -  in
 21.1073 -    Symtab.empty
 21.1074 -    |> is_type_sys_fairly_sound type_sys
 21.1075 -       ? (fold (add_fact true) conjs #> fold (add_fact false) facts)
 21.1076 -  end
 21.1077 -
 21.1078 -(* These types witness that the type classes they belong to allow infinite
 21.1079 -   models and hence that any types with these type classes is monotonic. *)
 21.1080 -val known_infinite_types = [@{typ nat}, @{typ int}, @{typ "nat => bool"}]
 21.1081 -
 21.1082 -(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it
 21.1083 -   out with monotonicity" paper presented at CADE 2011. *)
 21.1084 -fun add_combterm_nonmonotonic_types _ _ (SOME false) _ = I
 21.1085 -  | add_combterm_nonmonotonic_types ctxt level _
 21.1086 -        (CombApp (CombApp (CombConst ((s, _), Type (_, [T, _]), _), tm1), tm2)) =
 21.1087 -    (is_tptp_equal s andalso exists is_var_or_bound_var [tm1, tm2] andalso
 21.1088 -     (case level of
 21.1089 -        Nonmonotonic_Types =>
 21.1090 -        not (is_type_surely_infinite ctxt known_infinite_types T)
 21.1091 -      | Finite_Types => is_type_surely_finite ctxt T
 21.1092 -      | _ => true)) ? insert_type ctxt I (deep_freeze_type T)
 21.1093 -  | add_combterm_nonmonotonic_types _ _ _ _ = I
 21.1094 -fun add_fact_nonmonotonic_types ctxt level ({kind, combformula, ...}
 21.1095 -                                            : translated_formula) =
 21.1096 -  formula_fold (SOME (kind <> Conjecture))
 21.1097 -               (add_combterm_nonmonotonic_types ctxt level) combformula
 21.1098 -fun nonmonotonic_types_for_facts ctxt type_sys facts =
 21.1099 -  let val level = level_of_type_sys type_sys in
 21.1100 -    if level = Nonmonotonic_Types orelse level = Finite_Types then
 21.1101 -      [] |> fold (add_fact_nonmonotonic_types ctxt level) facts
 21.1102 -         (* We must add "bool" in case the helper "True_or_False" is added
 21.1103 -            later. In addition, several places in the code rely on the list of
 21.1104 -            nonmonotonic types not being empty. *)
 21.1105 -         |> insert_type ctxt I @{typ bool}
 21.1106 -    else
 21.1107 -      []
 21.1108 -  end
 21.1109 -
 21.1110 -fun decl_line_for_sym ctxt format nonmono_Ts type_sys s
 21.1111 -                      (s', T_args, T, pred_sym, ary, _) =
 21.1112 -  let
 21.1113 -    val (higher_order, T_arg_Ts, level) =
 21.1114 -      case type_sys of
 21.1115 -        Simple_Types level => (format = THF, [], level)
 21.1116 -      | _ => (false, replicate (length T_args) homo_infinite_type, No_Types)
 21.1117 -  in
 21.1118 -    Decl (sym_decl_prefix ^ s, (s, s'),
 21.1119 -          (T_arg_Ts ---> (T |> homogenized_type ctxt nonmono_Ts level ary))
 21.1120 -          |> mangled_type higher_order pred_sym (length T_arg_Ts + ary))
 21.1121 -  end
 21.1122 -
 21.1123 -fun is_polymorphic_type T = fold_atyps (fn TVar _ => K true | _ => I) T false
 21.1124 -
 21.1125 -fun formula_line_for_pred_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys
 21.1126 -                                   n s j (s', T_args, T, _, ary, in_conj) =
 21.1127 -  let
 21.1128 -    val (kind, maybe_negate) =
 21.1129 -      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 21.1130 -      else (Axiom, I)
 21.1131 -    val (arg_Ts, res_T) = chop_fun ary T
 21.1132 -    val bound_names =
 21.1133 -      1 upto length arg_Ts |> map (`I o make_bound_var o string_of_int)
 21.1134 -    val bounds =
 21.1135 -      bound_names ~~ arg_Ts |> map (fn (name, T) => CombConst (name, T, []))
 21.1136 -    val bound_Ts =
 21.1137 -      arg_Ts |> map (fn T => if n > 1 orelse is_polymorphic_type T then SOME T
 21.1138 -                             else NONE)
 21.1139 -  in
 21.1140 -    Formula (sym_formula_prefix ^ s ^
 21.1141 -             (if n > 1 then "_" ^ string_of_int j else ""), kind,
 21.1142 -             CombConst ((s, s'), T, T_args)
 21.1143 -             |> fold (curry (CombApp o swap)) bounds
 21.1144 -             |> type_pred_combterm ctxt nonmono_Ts type_sys res_T
 21.1145 -             |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts)
 21.1146 -             |> formula_from_combformula ctxt format nonmono_Ts type_sys
 21.1147 -                                         (K (K (K (K true)))) true
 21.1148 -             |> n > 1 ? bound_atomic_types format type_sys (atyps_of T)
 21.1149 -             |> close_formula_universally
 21.1150 -             |> maybe_negate,
 21.1151 -             intro_info, NONE)
 21.1152 -  end
 21.1153 -
 21.1154 -fun formula_lines_for_tag_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys
 21.1155 -        n s (j, (s', T_args, T, pred_sym, ary, in_conj)) =
 21.1156 -  let
 21.1157 -    val ident_base =
 21.1158 -      sym_formula_prefix ^ s ^ (if n > 1 then "_" ^ string_of_int j else "")
 21.1159 -    val (kind, maybe_negate) =
 21.1160 -      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 21.1161 -      else (Axiom, I)
 21.1162 -    val (arg_Ts, res_T) = chop_fun ary T
 21.1163 -    val bound_names =
 21.1164 -      1 upto length arg_Ts |> map (`I o make_bound_var o string_of_int)
 21.1165 -    val bounds = bound_names |> map (fn name => ATerm (name, []))
 21.1166 -    val cst = mk_const_aterm (s, s') T_args
 21.1167 -    val atomic_Ts = atyps_of T
 21.1168 -    fun eq tms =
 21.1169 -      (if pred_sym then AConn (AIff, map AAtom tms)
 21.1170 -       else AAtom (ATerm (`I tptp_equal, tms)))
 21.1171 -      |> bound_atomic_types format type_sys atomic_Ts
 21.1172 -      |> close_formula_universally
 21.1173 -      |> maybe_negate
 21.1174 -    val should_encode = should_encode_type ctxt nonmono_Ts All_Types
 21.1175 -    val tag_with = tag_with_type ctxt format nonmono_Ts type_sys
 21.1176 -    val add_formula_for_res =
 21.1177 -      if should_encode res_T then
 21.1178 -        cons (Formula (ident_base ^ "_res", kind,
 21.1179 -                       eq [tag_with res_T (cst bounds), cst bounds],
 21.1180 -                       simp_info, NONE))
 21.1181 -      else
 21.1182 -        I
 21.1183 -    fun add_formula_for_arg k =
 21.1184 -      let val arg_T = nth arg_Ts k in
 21.1185 -        if should_encode arg_T then
 21.1186 -          case chop k bounds of
 21.1187 -            (bounds1, bound :: bounds2) =>
 21.1188 -            cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind,
 21.1189 -                           eq [cst (bounds1 @ tag_with arg_T bound :: bounds2),
 21.1190 -                               cst bounds],
 21.1191 -                           simp_info, NONE))
 21.1192 -          | _ => raise Fail "expected nonempty tail"
 21.1193 -        else
 21.1194 -          I
 21.1195 -      end
 21.1196 -  in
 21.1197 -    [] |> not pred_sym ? add_formula_for_res
 21.1198 -       |> fold add_formula_for_arg (ary - 1 downto 0)
 21.1199 -  end
 21.1200 -
 21.1201 -fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
 21.1202 -
 21.1203 -fun problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts type_sys
 21.1204 -                                (s, decls) =
 21.1205 -  case type_sys of
 21.1206 -    Simple_Types _ =>
 21.1207 -    decls |> map (decl_line_for_sym ctxt format nonmono_Ts type_sys s)
 21.1208 -  | Preds _ =>
 21.1209 -    let
 21.1210 -      val decls =
 21.1211 -        case decls of
 21.1212 -          decl :: (decls' as _ :: _) =>
 21.1213 -          let val T = result_type_of_decl decl in
 21.1214 -            if forall (curry (type_instance ctxt o swap) T
 21.1215 -                       o result_type_of_decl) decls' then
 21.1216 -              [decl]
 21.1217 -            else
 21.1218 -              decls
 21.1219 -          end
 21.1220 -        | _ => decls
 21.1221 -      val n = length decls
 21.1222 -      val decls =
 21.1223 -        decls
 21.1224 -        |> filter (should_predicate_on_type ctxt nonmono_Ts type_sys (K true)
 21.1225 -                   o result_type_of_decl)
 21.1226 -    in
 21.1227 -      (0 upto length decls - 1, decls)
 21.1228 -      |-> map2 (formula_line_for_pred_sym_decl ctxt format conj_sym_kind
 21.1229 -                                               nonmono_Ts type_sys n s)
 21.1230 -    end
 21.1231 -  | Tags (_, _, heaviness) =>
 21.1232 -    (case heaviness of
 21.1233 -       Heavy => []
 21.1234 -     | Light =>
 21.1235 -       let val n = length decls in
 21.1236 -         (0 upto n - 1 ~~ decls)
 21.1237 -         |> maps (formula_lines_for_tag_sym_decl ctxt format conj_sym_kind
 21.1238 -                                                 nonmono_Ts type_sys n s)
 21.1239 -       end)
 21.1240 -
 21.1241 -fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind nonmono_Ts
 21.1242 -                                     type_sys sym_decl_tab =
 21.1243 -  sym_decl_tab
 21.1244 -  |> Symtab.dest
 21.1245 -  |> sort_wrt fst
 21.1246 -  |> rpair []
 21.1247 -  |-> fold_rev (append o problem_lines_for_sym_decls ctxt format conj_sym_kind
 21.1248 -                                                     nonmono_Ts type_sys)
 21.1249 -
 21.1250 -fun should_add_ti_ti_helper (Tags (Polymorphic, level, Heavy)) =
 21.1251 -    level = Nonmonotonic_Types orelse level = Finite_Types
 21.1252 -  | should_add_ti_ti_helper _ = false
 21.1253 -
 21.1254 -fun offset_of_heading_in_problem _ [] j = j
 21.1255 -  | offset_of_heading_in_problem needle ((heading, lines) :: problem) j =
 21.1256 -    if heading = needle then j
 21.1257 -    else offset_of_heading_in_problem needle problem (j + length lines)
 21.1258 -
 21.1259 -val implicit_declsN = "Should-be-implicit typings"
 21.1260 -val explicit_declsN = "Explicit typings"
 21.1261 -val factsN = "Relevant facts"
 21.1262 -val class_relsN = "Class relationships"
 21.1263 -val aritiesN = "Arities"
 21.1264 -val helpersN = "Helper facts"
 21.1265 -val conjsN = "Conjectures"
 21.1266 -val free_typesN = "Type variables"
 21.1267 -
 21.1268 -fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_sys
 21.1269 -                        explicit_apply hyp_ts concl_t facts =
 21.1270 -  let
 21.1271 -    val (fact_names, (co