author bulwahn Tue May 31 18:13:00 2011 +0200 (2011-05-31) changeset 43115 6773d8a9e351 parent 43114 b9fca691addd parent 43111 61faa204c810 child 43116 e0add071fa10
merged
 src/HOL/Tools/Sledgehammer/sledgehammer_atp_reconstruct.ML file | annotate | diff | revisions src/HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML file | annotate | diff | revisions
```     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```