renamed two files to make room for a new file
authorblanchet
Mon Jan 23 17:40:32 2012 +0100 (2012-01-23)
changeset 463200b8b73b49848
parent 46319 c248e4f1be74
child 46321 484dc68c8c89
renamed two files to make room for a new file
src/HOL/ATP.thy
src/HOL/IsaMakefile
src/HOL/Metis.thy
src/HOL/Mirabelle/Tools/mirabelle_metis.ML
src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML
src/HOL/TPTP/CASC_Setup.thy
src/HOL/TPTP/atp_export.ML
src/HOL/TPTP/lib/Tools/tptp_translate
src/HOL/Tools/ATP/atp_problem.ML
src/HOL/Tools/ATP/atp_problem_generate.ML
src/HOL/Tools/ATP/atp_proof_reconstruct.ML
src/HOL/Tools/ATP/atp_proof_redirect.ML
src/HOL/Tools/ATP/atp_reconstruct.ML
src/HOL/Tools/ATP/atp_redirect.ML
src/HOL/Tools/ATP/atp_systems.ML
src/HOL/Tools/ATP/atp_translate.ML
src/HOL/Tools/Metis/metis_generate.ML
src/HOL/Tools/Metis/metis_reconstruct.ML
src/HOL/Tools/Metis/metis_tactic.ML
src/HOL/Tools/Metis/metis_translate.ML
src/HOL/Tools/Nitpick/nitpick_hol.ML
src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML
src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML
src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML
src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML
src/HOL/Tools/Sledgehammer/sledgehammer_run.ML
src/HOL/ex/sledgehammer_tactics.ML
     1.1 --- a/src/HOL/ATP.thy	Mon Jan 23 17:40:31 2012 +0100
     1.2 +++ b/src/HOL/ATP.thy	Mon Jan 23 17:40:32 2012 +0100
     1.3 @@ -12,9 +12,9 @@
     1.4       "Tools/ATP/atp_util.ML"
     1.5       "Tools/ATP/atp_problem.ML"
     1.6       "Tools/ATP/atp_proof.ML"
     1.7 -     "Tools/ATP/atp_redirect.ML"
     1.8 -     ("Tools/ATP/atp_translate.ML")
     1.9 -     ("Tools/ATP/atp_reconstruct.ML")
    1.10 +     "Tools/ATP/atp_proof_redirect.ML"
    1.11 +     ("Tools/ATP/atp_problem_generate.ML")
    1.12 +     ("Tools/ATP/atp_proof_reconstruct.ML")
    1.13       ("Tools/ATP/atp_systems.ML")
    1.14  begin
    1.15  
    1.16 @@ -49,8 +49,8 @@
    1.17  
    1.18  subsection {* Setup *}
    1.19  
    1.20 -use "Tools/ATP/atp_translate.ML"
    1.21 -use "Tools/ATP/atp_reconstruct.ML"
    1.22 +use "Tools/ATP/atp_problem_generate.ML"
    1.23 +use "Tools/ATP/atp_proof_reconstruct.ML"
    1.24  use "Tools/ATP/atp_systems.ML"
    1.25  
    1.26  setup ATP_Systems.setup
     2.1 --- a/src/HOL/IsaMakefile	Mon Jan 23 17:40:31 2012 +0100
     2.2 +++ b/src/HOL/IsaMakefile	Mon Jan 23 17:40:32 2012 +0100
     2.3 @@ -204,11 +204,11 @@
     2.4    Set.thy \
     2.5    Sum_Type.thy \
     2.6    Tools/ATP/atp_problem.ML \
     2.7 +  Tools/ATP/atp_problem_generate.ML \
     2.8    Tools/ATP/atp_proof.ML \
     2.9 -  Tools/ATP/atp_reconstruct.ML \
    2.10 -  Tools/ATP/atp_redirect.ML \
    2.11 +  Tools/ATP/atp_proof_reconstruct.ML \
    2.12 +  Tools/ATP/atp_proof_redirect.ML \
    2.13    Tools/ATP/atp_systems.ML \
    2.14 -  Tools/ATP/atp_translate.ML \
    2.15    Tools/ATP/atp_util.ML \
    2.16    Tools/Datatype/datatype.ML \
    2.17    Tools/Datatype/datatype_aux.ML \
    2.18 @@ -241,9 +241,9 @@
    2.19    Tools/Meson/meson.ML \
    2.20    Tools/Meson/meson_clausify.ML \
    2.21    Tools/Meson/meson_tactic.ML \
    2.22 +  Tools/Metis/metis_generate.ML \
    2.23    Tools/Metis/metis_reconstruct.ML \
    2.24    Tools/Metis/metis_tactic.ML \
    2.25 -  Tools/Metis/metis_translate.ML \
    2.26    Tools/abel_cancel.ML \
    2.27    Tools/arith_data.ML \
    2.28    Tools/cnf_funcs.ML \
     3.1 --- a/src/HOL/Metis.thy	Mon Jan 23 17:40:31 2012 +0100
     3.2 +++ b/src/HOL/Metis.thy	Mon Jan 23 17:40:32 2012 +0100
     3.3 @@ -9,7 +9,7 @@
     3.4  theory Metis
     3.5  imports ATP
     3.6  uses "~~/src/Tools/Metis/metis.ML"
     3.7 -     ("Tools/Metis/metis_translate.ML")
     3.8 +     ("Tools/Metis/metis_generate.ML")
     3.9       ("Tools/Metis/metis_reconstruct.ML")
    3.10       ("Tools/Metis/metis_tactic.ML")
    3.11       ("Tools/try_methods.ML")
    3.12 @@ -40,7 +40,7 @@
    3.13  
    3.14  subsection {* Metis package *}
    3.15  
    3.16 -use "Tools/Metis/metis_translate.ML"
    3.17 +use "Tools/Metis/metis_generate.ML"
    3.18  use "Tools/Metis/metis_reconstruct.ML"
    3.19  use "Tools/Metis/metis_tactic.ML"
    3.20  
     4.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_metis.ML	Mon Jan 23 17:40:31 2012 +0100
     4.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_metis.ML	Mon Jan 23 17:40:32 2012 +0100
     4.3 @@ -19,7 +19,8 @@
     4.4      val facts = Facts.props (Proof_Context.facts_of (Proof.context_of pre))
     4.5  
     4.6      fun metis ctxt =
     4.7 -      Metis_Tactic.metis_tac [] ATP_Translate.lam_liftingN ctxt (thms @ facts)
     4.8 +      Metis_Tactic.metis_tac [] ATP_Problem_Generate.lam_liftingN ctxt
     4.9 +                             (thms @ facts)
    4.10    in
    4.11      (if Mirabelle.can_apply timeout metis pre then "succeeded" else "failed")
    4.12      |> prefix (metis_tag id)
     5.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Mon Jan 23 17:40:31 2012 +0100
     5.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Mon Jan 23 17:40:32 2012 +0100
     5.3 @@ -336,7 +336,7 @@
     5.4      | NONE => get_prover (default_prover_name ()))
     5.5    end
     5.6  
     5.7 -type locality = ATP_Translate.locality
     5.8 +type locality = ATP_Problem_Generate.locality
     5.9  
    5.10  (* hack *)
    5.11  fun reconstructor_from_msg args msg =
    5.12 @@ -410,7 +410,7 @@
    5.13      fun failed failure =
    5.14        ({outcome = SOME failure, used_facts = [], run_time = Time.zeroTime,
    5.15          preplay =
    5.16 -          K (ATP_Reconstruct.Failed_to_Play Sledgehammer_Provers.plain_metis),
    5.17 +          K (ATP_Proof_Reconstruct.Failed_to_Play Sledgehammer_Provers.plain_metis),
    5.18          message = K "", message_tail = ""}, ~1)
    5.19      val ({outcome, used_facts, run_time, preplay, message, message_tail}
    5.20           : Sledgehammer_Provers.prover_result,
    5.21 @@ -581,12 +581,13 @@
    5.22            ORELSE' sledge_tac 0.2 ATP_Systems.eN "mono_guards??"
    5.23            ORELSE' sledge_tac 0.2 ATP_Systems.vampireN "mono_guards??"
    5.24            ORELSE' sledge_tac 0.2 ATP_Systems.spassN "poly_tags"
    5.25 -          ORELSE' Metis_Tactic.metis_tac [] ATP_Translate.combinatorsN ctxt thms
    5.26 +          ORELSE' Metis_Tactic.metis_tac [] ATP_Problem_Generate.combinatorsN
    5.27 +            ctxt thms
    5.28          else if !reconstructor = "smt" then
    5.29            SMT_Solver.smt_tac ctxt thms
    5.30          else if full then
    5.31 -          Metis_Tactic.metis_tac [ATP_Reconstruct.full_typesN]
    5.32 -            ATP_Reconstruct.metis_default_lam_trans ctxt thms
    5.33 +          Metis_Tactic.metis_tac [ATP_Proof_Reconstruct.full_typesN]
    5.34 +            ATP_Proof_Reconstruct.metis_default_lam_trans ctxt thms
    5.35          else if String.isPrefix "metis (" (!reconstructor) then
    5.36            let
    5.37              val (type_encs, lam_trans) =
    5.38 @@ -594,11 +595,11 @@
    5.39                |> Outer_Syntax.scan Position.start
    5.40                |> filter Token.is_proper |> tl
    5.41                |> Metis_Tactic.parse_metis_options |> fst
    5.42 -              |>> the_default [ATP_Reconstruct.partial_typesN]
    5.43 -              ||> the_default ATP_Reconstruct.metis_default_lam_trans
    5.44 +              |>> the_default [ATP_Proof_Reconstruct.partial_typesN]
    5.45 +              ||> the_default ATP_Proof_Reconstruct.metis_default_lam_trans
    5.46            in Metis_Tactic.metis_tac type_encs lam_trans ctxt thms end
    5.47          else if !reconstructor = "metis" then
    5.48 -          Metis_Tactic.metis_tac [] ATP_Reconstruct.metis_default_lam_trans ctxt
    5.49 +          Metis_Tactic.metis_tac [] ATP_Proof_Reconstruct.metis_default_lam_trans ctxt
    5.50              thms
    5.51          else
    5.52            K all_tac
     6.1 --- a/src/HOL/TPTP/CASC_Setup.thy	Mon Jan 23 17:40:31 2012 +0100
     6.2 +++ b/src/HOL/TPTP/CASC_Setup.thy	Mon Jan 23 17:40:32 2012 +0100
     6.3 @@ -129,7 +129,7 @@
     6.4                            Sledgehammer_Filter.no_relevance_override))
     6.5     ORELSE
     6.6     SOLVE_TIMEOUT (max_secs div 10) "metis"
     6.7 -       (ALLGOALS (Metis_Tactic.metis_tac [] ATP_Translate.lam_liftingN ctxt []))
     6.8 +       (ALLGOALS (Metis_Tactic.metis_tac [] ATP_Problem_Generate.lam_liftingN ctxt []))
     6.9     ORELSE
    6.10     SOLVE_TIMEOUT (max_secs div 10) "fast" (ALLGOALS (fast_tac ctxt))
    6.11     ORELSE
     7.1 --- a/src/HOL/TPTP/atp_export.ML	Mon Jan 23 17:40:31 2012 +0100
     7.2 +++ b/src/HOL/TPTP/atp_export.ML	Mon Jan 23 17:40:32 2012 +0100
     7.3 @@ -22,8 +22,8 @@
     7.4  struct
     7.5  
     7.6  open ATP_Problem
     7.7 -open ATP_Translate
     7.8  open ATP_Proof
     7.9 +open ATP_Problem_Generate
    7.10  open ATP_Systems
    7.11  
    7.12  val fact_name_of = prefix fact_prefix o ascii_of
     8.1 --- a/src/HOL/TPTP/lib/Tools/tptp_translate	Mon Jan 23 17:40:31 2012 +0100
     8.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_translate	Mon Jan 23 17:40:32 2012 +0100
     8.3 @@ -22,7 +22,7 @@
     8.4  
     8.5  for FILE in "$@"
     8.6  do
     8.7 -  echo "theory $SCRATCH imports \"Main\" begin ML {* ATP_Translate.translate_tptp_file \"$FILE\" *} end;" \
     8.8 +  echo "theory $SCRATCH imports \"Main\" begin ML {* ATP_Problem_Generate.translate_tptp_file \"$FILE\" *} end;" \
     8.9      > /tmp/$SCRATCH.thy
    8.10    "$ISABELLE_PROCESS" -e "use_thy \"/tmp/$SCRATCH\"; exit 1;"
    8.11  done
     9.1 --- a/src/HOL/Tools/ATP/atp_problem.ML	Mon Jan 23 17:40:31 2012 +0100
     9.2 +++ b/src/HOL/Tools/ATP/atp_problem.ML	Mon Jan 23 17:40:32 2012 +0100
     9.3 @@ -349,7 +349,7 @@
     9.4             (AQuant (if s = tptp_ho_forall then AForall else AExists,
     9.5                      [(s', SOME ty)], AAtom tm))
     9.6       | (_, true, [AAbs ((s', ty), tm)]) =>
     9.7 -       (* There is code in "ATP_Translate" to ensure that "Eps" is always
     9.8 +       (* There is code in "ATP_Problem_Generate" to ensure that "Eps" is always
     9.9            applied to an abstraction. *)
    9.10         tptp_choice ^ "[" ^ s' ^ " : " ^ string_for_type format ty ^ "]: " ^
    9.11         tptp_string_for_term format tm ^ ""
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Tools/ATP/atp_problem_generate.ML	Mon Jan 23 17:40:32 2012 +0100
    10.3 @@ -0,0 +1,2557 @@
    10.4 +(*  Title:      HOL/Tools/ATP/atp_problem_generate.ML
    10.5 +    Author:     Fabian Immler, TU Muenchen
    10.6 +    Author:     Makarius
    10.7 +    Author:     Jasmin Blanchette, TU Muenchen
    10.8 +
    10.9 +Translation of HOL to FOL for Metis and Sledgehammer.
   10.10 +*)
   10.11 +
   10.12 +signature ATP_PROBLEM_GENERATE =
   10.13 +sig
   10.14 +  type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term
   10.15 +  type connective = ATP_Problem.connective
   10.16 +  type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula
   10.17 +  type atp_format = ATP_Problem.atp_format
   10.18 +  type formula_kind = ATP_Problem.formula_kind
   10.19 +  type 'a problem = 'a ATP_Problem.problem
   10.20 +
   10.21 +  datatype locality =
   10.22 +    General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained
   10.23 +
   10.24 +  datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic
   10.25 +  datatype strictness = Strict | Non_Strict
   10.26 +  datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars
   10.27 +  datatype type_level =
   10.28 +    All_Types |
   10.29 +    Noninf_Nonmono_Types of strictness * granularity |
   10.30 +    Fin_Nonmono_Types of granularity |
   10.31 +    Const_Arg_Types |
   10.32 +    No_Types
   10.33 +  type type_enc
   10.34 +
   10.35 +  val type_tag_idempotence : bool Config.T
   10.36 +  val type_tag_arguments : bool Config.T
   10.37 +  val no_lamsN : string
   10.38 +  val hide_lamsN : string
   10.39 +  val lam_liftingN : string
   10.40 +  val combinatorsN : string
   10.41 +  val hybrid_lamsN : string
   10.42 +  val keep_lamsN : string
   10.43 +  val schematic_var_prefix : string
   10.44 +  val fixed_var_prefix : string
   10.45 +  val tvar_prefix : string
   10.46 +  val tfree_prefix : string
   10.47 +  val const_prefix : string
   10.48 +  val type_const_prefix : string
   10.49 +  val class_prefix : string
   10.50 +  val lam_lifted_prefix : string
   10.51 +  val lam_lifted_mono_prefix : string
   10.52 +  val lam_lifted_poly_prefix : string
   10.53 +  val skolem_const_prefix : string
   10.54 +  val old_skolem_const_prefix : string
   10.55 +  val new_skolem_const_prefix : string
   10.56 +  val combinator_prefix : string
   10.57 +  val type_decl_prefix : string
   10.58 +  val sym_decl_prefix : string
   10.59 +  val guards_sym_formula_prefix : string
   10.60 +  val tags_sym_formula_prefix : string
   10.61 +  val fact_prefix : string
   10.62 +  val conjecture_prefix : string
   10.63 +  val helper_prefix : string
   10.64 +  val class_rel_clause_prefix : string
   10.65 +  val arity_clause_prefix : string
   10.66 +  val tfree_clause_prefix : string
   10.67 +  val lam_fact_prefix : string
   10.68 +  val typed_helper_suffix : string
   10.69 +  val untyped_helper_suffix : string
   10.70 +  val type_tag_idempotence_helper_name : string
   10.71 +  val predicator_name : string
   10.72 +  val app_op_name : string
   10.73 +  val type_guard_name : string
   10.74 +  val type_tag_name : string
   10.75 +  val simple_type_prefix : string
   10.76 +  val prefixed_predicator_name : string
   10.77 +  val prefixed_app_op_name : string
   10.78 +  val prefixed_type_tag_name : string
   10.79 +  val ascii_of : string -> string
   10.80 +  val unascii_of : string -> string
   10.81 +  val unprefix_and_unascii : string -> string -> string option
   10.82 +  val proxy_table : (string * (string * (thm * (string * string)))) list
   10.83 +  val proxify_const : string -> (string * string) option
   10.84 +  val invert_const : string -> string
   10.85 +  val unproxify_const : string -> string
   10.86 +  val new_skolem_var_name_from_const : string -> string
   10.87 +  val atp_irrelevant_consts : string list
   10.88 +  val atp_schematic_consts_of : term -> typ list Symtab.table
   10.89 +  val is_type_enc_higher_order : type_enc -> bool
   10.90 +  val polymorphism_of_type_enc : type_enc -> polymorphism
   10.91 +  val level_of_type_enc : type_enc -> type_level
   10.92 +  val is_type_enc_quasi_sound : type_enc -> bool
   10.93 +  val is_type_enc_fairly_sound : type_enc -> bool
   10.94 +  val type_enc_from_string : strictness -> string -> type_enc
   10.95 +  val adjust_type_enc : atp_format -> type_enc -> type_enc
   10.96 +  val mk_aconns :
   10.97 +    connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula
   10.98 +  val unmangled_const : string -> string * (string, 'b) ho_term list
   10.99 +  val unmangled_const_name : string -> string
  10.100 +  val helper_table : ((string * bool) * thm list) list
  10.101 +  val trans_lams_from_string :
  10.102 +    Proof.context -> type_enc -> string -> term list -> term list * term list
  10.103 +  val factsN : string
  10.104 +  val prepare_atp_problem :
  10.105 +    Proof.context -> atp_format -> formula_kind -> formula_kind -> type_enc
  10.106 +    -> bool -> string -> bool -> bool -> term list -> term
  10.107 +    -> ((string * locality) * term) list
  10.108 +    -> string problem * string Symtab.table * (string * locality) list vector
  10.109 +       * (string * term) list * int Symtab.table
  10.110 +  val atp_problem_weights : string problem -> (string * real) list
  10.111 +end;
  10.112 +
  10.113 +structure ATP_Problem_Generate : ATP_PROBLEM_GENERATE =
  10.114 +struct
  10.115 +
  10.116 +open ATP_Util
  10.117 +open ATP_Problem
  10.118 +
  10.119 +type name = string * string
  10.120 +
  10.121 +val type_tag_idempotence =
  10.122 +  Attrib.setup_config_bool @{binding atp_type_tag_idempotence} (K false)
  10.123 +val type_tag_arguments =
  10.124 +  Attrib.setup_config_bool @{binding atp_type_tag_arguments} (K false)
  10.125 +
  10.126 +val no_lamsN = "no_lams" (* used internally; undocumented *)
  10.127 +val hide_lamsN = "hide_lams"
  10.128 +val lam_liftingN = "lam_lifting"
  10.129 +val combinatorsN = "combinators"
  10.130 +val hybrid_lamsN = "hybrid_lams"
  10.131 +val keep_lamsN = "keep_lams"
  10.132 +
  10.133 +(* It's still unclear whether all TFF1 implementations will support type
  10.134 +   signatures such as "!>[A : $tType] : $o", with ghost type variables. *)
  10.135 +val avoid_first_order_ghost_type_vars = false
  10.136 +
  10.137 +val bound_var_prefix = "B_"
  10.138 +val all_bound_var_prefix = "BA_"
  10.139 +val exist_bound_var_prefix = "BE_"
  10.140 +val schematic_var_prefix = "V_"
  10.141 +val fixed_var_prefix = "v_"
  10.142 +val tvar_prefix = "T_"
  10.143 +val tfree_prefix = "t_"
  10.144 +val const_prefix = "c_"
  10.145 +val type_const_prefix = "tc_"
  10.146 +val simple_type_prefix = "s_"
  10.147 +val class_prefix = "cl_"
  10.148 +
  10.149 +(* Freshness almost guaranteed! *)
  10.150 +val atp_weak_prefix = "ATP:"
  10.151 +
  10.152 +val lam_lifted_prefix = atp_weak_prefix ^ "Lam"
  10.153 +val lam_lifted_mono_prefix = lam_lifted_prefix ^ "m"
  10.154 +val lam_lifted_poly_prefix = lam_lifted_prefix ^ "p"
  10.155 +
  10.156 +val skolem_const_prefix = "ATP" ^ Long_Name.separator ^ "Sko"
  10.157 +val old_skolem_const_prefix = skolem_const_prefix ^ "o"
  10.158 +val new_skolem_const_prefix = skolem_const_prefix ^ "n"
  10.159 +
  10.160 +val combinator_prefix = "COMB"
  10.161 +
  10.162 +val type_decl_prefix = "ty_"
  10.163 +val sym_decl_prefix = "sy_"
  10.164 +val guards_sym_formula_prefix = "gsy_"
  10.165 +val tags_sym_formula_prefix = "tsy_"
  10.166 +val fact_prefix = "fact_"
  10.167 +val conjecture_prefix = "conj_"
  10.168 +val helper_prefix = "help_"
  10.169 +val class_rel_clause_prefix = "clar_"
  10.170 +val arity_clause_prefix = "arity_"
  10.171 +val tfree_clause_prefix = "tfree_"
  10.172 +
  10.173 +val lam_fact_prefix = "ATP.lambda_"
  10.174 +val typed_helper_suffix = "_T"
  10.175 +val untyped_helper_suffix = "_U"
  10.176 +val type_tag_idempotence_helper_name = helper_prefix ^ "ti_idem"
  10.177 +
  10.178 +val predicator_name = "pp"
  10.179 +val app_op_name = "aa"
  10.180 +val type_guard_name = "gg"
  10.181 +val type_tag_name = "tt"
  10.182 +
  10.183 +val prefixed_predicator_name = const_prefix ^ predicator_name
  10.184 +val prefixed_app_op_name = const_prefix ^ app_op_name
  10.185 +val prefixed_type_tag_name = const_prefix ^ type_tag_name
  10.186 +
  10.187 +(*Escaping of special characters.
  10.188 +  Alphanumeric characters are left unchanged.
  10.189 +  The character _ goes to __
  10.190 +  Characters in the range ASCII space to / go to _A to _P, respectively.
  10.191 +  Other characters go to _nnn where nnn is the decimal ASCII code.*)
  10.192 +val upper_a_minus_space = Char.ord #"A" - Char.ord #" "
  10.193 +
  10.194 +fun stringN_of_int 0 _ = ""
  10.195 +  | stringN_of_int k n =
  10.196 +    stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10)
  10.197 +
  10.198 +fun ascii_of_char c =
  10.199 +  if Char.isAlphaNum c then
  10.200 +    String.str c
  10.201 +  else if c = #"_" then
  10.202 +    "__"
  10.203 +  else if #" " <= c andalso c <= #"/" then
  10.204 +    "_" ^ String.str (Char.chr (Char.ord c + upper_a_minus_space))
  10.205 +  else
  10.206 +    (* fixed width, in case more digits follow *)
  10.207 +    "_" ^ stringN_of_int 3 (Char.ord c)
  10.208 +
  10.209 +val ascii_of = String.translate ascii_of_char
  10.210 +
  10.211 +(** Remove ASCII armoring from names in proof files **)
  10.212 +
  10.213 +(* We don't raise error exceptions because this code can run inside a worker
  10.214 +   thread. Also, the errors are impossible. *)
  10.215 +val unascii_of =
  10.216 +  let
  10.217 +    fun un rcs [] = String.implode(rev rcs)
  10.218 +      | un rcs [#"_"] = un (#"_" :: rcs) [] (* ERROR *)
  10.219 +        (* Three types of _ escapes: __, _A to _P, _nnn *)
  10.220 +      | un rcs (#"_" :: #"_" :: cs) = un (#"_" :: rcs) cs
  10.221 +      | un rcs (#"_" :: c :: cs) =
  10.222 +        if #"A" <= c andalso c<= #"P" then
  10.223 +          (* translation of #" " to #"/" *)
  10.224 +          un (Char.chr (Char.ord c - upper_a_minus_space) :: rcs) cs
  10.225 +        else
  10.226 +          let val digits = List.take (c :: cs, 3) handle General.Subscript => [] in
  10.227 +            case Int.fromString (String.implode digits) of
  10.228 +              SOME n => un (Char.chr n :: rcs) (List.drop (cs, 2))
  10.229 +            | NONE => un (c :: #"_" :: rcs) cs (* ERROR *)
  10.230 +          end
  10.231 +      | un rcs (c :: cs) = un (c :: rcs) cs
  10.232 +  in un [] o String.explode end
  10.233 +
  10.234 +(* If string s has the prefix s1, return the result of deleting it,
  10.235 +   un-ASCII'd. *)
  10.236 +fun unprefix_and_unascii s1 s =
  10.237 +  if String.isPrefix s1 s then
  10.238 +    SOME (unascii_of (String.extract (s, size s1, NONE)))
  10.239 +  else
  10.240 +    NONE
  10.241 +
  10.242 +val proxy_table =
  10.243 +  [("c_False", (@{const_name False}, (@{thm fFalse_def},
  10.244 +       ("fFalse", @{const_name ATP.fFalse})))),
  10.245 +   ("c_True", (@{const_name True}, (@{thm fTrue_def},
  10.246 +       ("fTrue", @{const_name ATP.fTrue})))),
  10.247 +   ("c_Not", (@{const_name Not}, (@{thm fNot_def},
  10.248 +       ("fNot", @{const_name ATP.fNot})))),
  10.249 +   ("c_conj", (@{const_name conj}, (@{thm fconj_def},
  10.250 +       ("fconj", @{const_name ATP.fconj})))),
  10.251 +   ("c_disj", (@{const_name disj}, (@{thm fdisj_def},
  10.252 +       ("fdisj", @{const_name ATP.fdisj})))),
  10.253 +   ("c_implies", (@{const_name implies}, (@{thm fimplies_def},
  10.254 +       ("fimplies", @{const_name ATP.fimplies})))),
  10.255 +   ("equal", (@{const_name HOL.eq}, (@{thm fequal_def},
  10.256 +       ("fequal", @{const_name ATP.fequal})))),
  10.257 +   ("c_All", (@{const_name All}, (@{thm fAll_def},
  10.258 +       ("fAll", @{const_name ATP.fAll})))),
  10.259 +   ("c_Ex", (@{const_name Ex}, (@{thm fEx_def},
  10.260 +       ("fEx", @{const_name ATP.fEx}))))]
  10.261 +
  10.262 +val proxify_const = AList.lookup (op =) proxy_table #> Option.map (snd o snd)
  10.263 +
  10.264 +(* Readable names for the more common symbolic functions. Do not mess with the
  10.265 +   table unless you know what you are doing. *)
  10.266 +val const_trans_table =
  10.267 +  [(@{type_name Product_Type.prod}, "prod"),
  10.268 +   (@{type_name Sum_Type.sum}, "sum"),
  10.269 +   (@{const_name False}, "False"),
  10.270 +   (@{const_name True}, "True"),
  10.271 +   (@{const_name Not}, "Not"),
  10.272 +   (@{const_name conj}, "conj"),
  10.273 +   (@{const_name disj}, "disj"),
  10.274 +   (@{const_name implies}, "implies"),
  10.275 +   (@{const_name HOL.eq}, "equal"),
  10.276 +   (@{const_name All}, "All"),
  10.277 +   (@{const_name Ex}, "Ex"),
  10.278 +   (@{const_name If}, "If"),
  10.279 +   (@{const_name Set.member}, "member"),
  10.280 +   (@{const_name Meson.COMBI}, combinator_prefix ^ "I"),
  10.281 +   (@{const_name Meson.COMBK}, combinator_prefix ^ "K"),
  10.282 +   (@{const_name Meson.COMBB}, combinator_prefix ^ "B"),
  10.283 +   (@{const_name Meson.COMBC}, combinator_prefix ^ "C"),
  10.284 +   (@{const_name Meson.COMBS}, combinator_prefix ^ "S")]
  10.285 +  |> Symtab.make
  10.286 +  |> fold (Symtab.update o swap o snd o snd o snd) proxy_table
  10.287 +
  10.288 +(* Invert the table of translations between Isabelle and ATPs. *)
  10.289 +val const_trans_table_inv =
  10.290 +  const_trans_table |> Symtab.dest |> map swap |> Symtab.make
  10.291 +val const_trans_table_unprox =
  10.292 +  Symtab.empty
  10.293 +  |> fold (fn (_, (isa, (_, (_, atp)))) => Symtab.update (atp, isa)) proxy_table
  10.294 +
  10.295 +val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
  10.296 +val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox)
  10.297 +
  10.298 +fun lookup_const c =
  10.299 +  case Symtab.lookup const_trans_table c of
  10.300 +    SOME c' => c'
  10.301 +  | NONE => ascii_of c
  10.302 +
  10.303 +fun ascii_of_indexname (v, 0) = ascii_of v
  10.304 +  | ascii_of_indexname (v, i) = ascii_of v ^ "_" ^ string_of_int i
  10.305 +
  10.306 +fun make_bound_var x = bound_var_prefix ^ ascii_of x
  10.307 +fun make_all_bound_var x = all_bound_var_prefix ^ ascii_of x
  10.308 +fun make_exist_bound_var x = exist_bound_var_prefix ^ ascii_of x
  10.309 +fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
  10.310 +fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
  10.311 +
  10.312 +fun make_schematic_type_var (x, i) =
  10.313 +  tvar_prefix ^ (ascii_of_indexname (unprefix "'" x, i))
  10.314 +fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (unprefix "'" x))
  10.315 +
  10.316 +(* "HOL.eq" and choice are mapped to the ATP's equivalents *)
  10.317 +local
  10.318 +  val choice_const = (fst o dest_Const o HOLogic.choice_const) Term.dummyT
  10.319 +  fun default c = const_prefix ^ lookup_const c
  10.320 +in
  10.321 +  fun make_fixed_const _ @{const_name HOL.eq} = tptp_old_equal
  10.322 +    | make_fixed_const (SOME (THF (_, _, THF_With_Choice))) c =
  10.323 +      if c = choice_const then tptp_choice else default c
  10.324 +    | make_fixed_const _ c = default c
  10.325 +end
  10.326 +
  10.327 +fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
  10.328 +
  10.329 +fun make_type_class clas = class_prefix ^ ascii_of clas
  10.330 +
  10.331 +fun new_skolem_var_name_from_const s =
  10.332 +  let val ss = s |> space_explode Long_Name.separator in
  10.333 +    nth ss (length ss - 2)
  10.334 +  end
  10.335 +
  10.336 +(* These are either simplified away by "Meson.presimplify" (most of the time) or
  10.337 +   handled specially via "fFalse", "fTrue", ..., "fequal". *)
  10.338 +val atp_irrelevant_consts =
  10.339 +  [@{const_name False}, @{const_name True}, @{const_name Not},
  10.340 +   @{const_name conj}, @{const_name disj}, @{const_name implies},
  10.341 +   @{const_name HOL.eq}, @{const_name If}, @{const_name Let}]
  10.342 +
  10.343 +val atp_monomorph_bad_consts =
  10.344 +  atp_irrelevant_consts @
  10.345 +  (* These are ignored anyway by the relevance filter (unless they appear in
  10.346 +     higher-order places) but not by the monomorphizer. *)
  10.347 +  [@{const_name all}, @{const_name "==>"}, @{const_name "=="},
  10.348 +   @{const_name Trueprop}, @{const_name All}, @{const_name Ex},
  10.349 +   @{const_name Ex1}, @{const_name Ball}, @{const_name Bex}]
  10.350 +
  10.351 +fun add_schematic_const (x as (_, T)) =
  10.352 +  Monomorph.typ_has_tvars T ? Symtab.insert_list (op =) x
  10.353 +val add_schematic_consts_of =
  10.354 +  Term.fold_aterms (fn Const (x as (s, _)) =>
  10.355 +                       not (member (op =) atp_monomorph_bad_consts s)
  10.356 +                       ? add_schematic_const x
  10.357 +                      | _ => I)
  10.358 +fun atp_schematic_consts_of t = add_schematic_consts_of t Symtab.empty
  10.359 +
  10.360 +(** Definitions and functions for FOL clauses and formulas for TPTP **)
  10.361 +
  10.362 +(** Isabelle arities **)
  10.363 +
  10.364 +type arity_atom = name * name * name list
  10.365 +
  10.366 +val type_class = the_single @{sort type}
  10.367 +
  10.368 +type arity_clause =
  10.369 +  {name : string,
  10.370 +   prem_atoms : arity_atom list,
  10.371 +   concl_atom : arity_atom}
  10.372 +
  10.373 +fun add_prem_atom tvar =
  10.374 +  fold (fn s => s <> type_class ? cons (`make_type_class s, `I tvar, []))
  10.375 +
  10.376 +(* Arity of type constructor "tcon :: (arg1, ..., argN) res" *)
  10.377 +fun make_axiom_arity_clause (tcons, name, (cls, args)) =
  10.378 +  let
  10.379 +    val tvars = map (prefix tvar_prefix o string_of_int) (1 upto length args)
  10.380 +    val tvars_srts = ListPair.zip (tvars, args)
  10.381 +  in
  10.382 +    {name = name,
  10.383 +     prem_atoms = [] |> fold (uncurry add_prem_atom) tvars_srts,
  10.384 +     concl_atom = (`make_type_class cls, `make_fixed_type_const tcons,
  10.385 +                   tvars ~~ tvars)}
  10.386 +  end
  10.387 +
  10.388 +fun arity_clause _ _ (_, []) = []
  10.389 +  | arity_clause seen n (tcons, ("HOL.type", _) :: ars) =  (* ignore *)
  10.390 +    arity_clause seen n (tcons, ars)
  10.391 +  | arity_clause seen n (tcons, (ar as (class, _)) :: ars) =
  10.392 +    if member (op =) seen class then
  10.393 +      (* multiple arities for the same (tycon, class) pair *)
  10.394 +      make_axiom_arity_clause (tcons,
  10.395 +          lookup_const tcons ^ "___" ^ ascii_of class ^ "_" ^ string_of_int n,
  10.396 +          ar) ::
  10.397 +      arity_clause seen (n + 1) (tcons, ars)
  10.398 +    else
  10.399 +      make_axiom_arity_clause (tcons, lookup_const tcons ^ "___" ^
  10.400 +                               ascii_of class, ar) ::
  10.401 +      arity_clause (class :: seen) n (tcons, ars)
  10.402 +
  10.403 +fun multi_arity_clause [] = []
  10.404 +  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
  10.405 +    arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
  10.406 +
  10.407 +(* Generate all pairs (tycon, class, sorts) such that tycon belongs to class in
  10.408 +   theory thy provided its arguments have the corresponding sorts. *)
  10.409 +fun type_class_pairs thy tycons classes =
  10.410 +  let
  10.411 +    val alg = Sign.classes_of thy
  10.412 +    fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
  10.413 +    fun add_class tycon class =
  10.414 +      cons (class, domain_sorts tycon class)
  10.415 +      handle Sorts.CLASS_ERROR _ => I
  10.416 +    fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
  10.417 +  in map try_classes tycons end
  10.418 +
  10.419 +(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  10.420 +fun iter_type_class_pairs _ _ [] = ([], [])
  10.421 +  | iter_type_class_pairs thy tycons classes =
  10.422 +      let
  10.423 +        fun maybe_insert_class s =
  10.424 +          (s <> type_class andalso not (member (op =) classes s))
  10.425 +          ? insert (op =) s
  10.426 +        val cpairs = type_class_pairs thy tycons classes
  10.427 +        val newclasses =
  10.428 +          [] |> fold (fold (fold (fold maybe_insert_class) o snd) o snd) cpairs
  10.429 +        val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  10.430 +      in (classes' @ classes, union (op =) cpairs' cpairs) end
  10.431 +
  10.432 +fun make_arity_clauses thy tycons =
  10.433 +  iter_type_class_pairs thy tycons ##> multi_arity_clause
  10.434 +
  10.435 +
  10.436 +(** Isabelle class relations **)
  10.437 +
  10.438 +type class_rel_clause =
  10.439 +  {name : string,
  10.440 +   subclass : name,
  10.441 +   superclass : name}
  10.442 +
  10.443 +(* Generate all pairs (sub, super) such that sub is a proper subclass of super
  10.444 +   in theory "thy". *)
  10.445 +fun class_pairs _ [] _ = []
  10.446 +  | class_pairs thy subs supers =
  10.447 +      let
  10.448 +        val class_less = Sorts.class_less (Sign.classes_of thy)
  10.449 +        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
  10.450 +        fun add_supers sub = fold (add_super sub) supers
  10.451 +      in fold add_supers subs [] end
  10.452 +
  10.453 +fun make_class_rel_clause (sub, super) =
  10.454 +  {name = sub ^ "_" ^ super, subclass = `make_type_class sub,
  10.455 +   superclass = `make_type_class super}
  10.456 +
  10.457 +fun make_class_rel_clauses thy subs supers =
  10.458 +  map make_class_rel_clause (class_pairs thy subs supers)
  10.459 +
  10.460 +(* intermediate terms *)
  10.461 +datatype iterm =
  10.462 +  IConst of name * typ * typ list |
  10.463 +  IVar of name * typ |
  10.464 +  IApp of iterm * iterm |
  10.465 +  IAbs of (name * typ) * iterm
  10.466 +
  10.467 +fun ityp_of (IConst (_, T, _)) = T
  10.468 +  | ityp_of (IVar (_, T)) = T
  10.469 +  | ityp_of (IApp (t1, _)) = snd (dest_funT (ityp_of t1))
  10.470 +  | ityp_of (IAbs ((_, T), tm)) = T --> ityp_of tm
  10.471 +
  10.472 +(*gets the head of a combinator application, along with the list of arguments*)
  10.473 +fun strip_iterm_comb u =
  10.474 +  let
  10.475 +    fun stripc (IApp (t, u), ts) = stripc (t, u :: ts)
  10.476 +      | stripc x = x
  10.477 +  in stripc (u, []) end
  10.478 +
  10.479 +fun atomic_types_of T = fold_atyps (insert (op =)) T []
  10.480 +
  10.481 +val tvar_a_str = "'a"
  10.482 +val tvar_a = TVar ((tvar_a_str, 0), HOLogic.typeS)
  10.483 +val tvar_a_name = (make_schematic_type_var (tvar_a_str, 0), tvar_a_str)
  10.484 +val itself_name = `make_fixed_type_const @{type_name itself}
  10.485 +val TYPE_name = `(make_fixed_const NONE) @{const_name TYPE}
  10.486 +val tvar_a_atype = AType (tvar_a_name, [])
  10.487 +val a_itself_atype = AType (itself_name, [tvar_a_atype])
  10.488 +
  10.489 +fun new_skolem_const_name s num_T_args =
  10.490 +  [new_skolem_const_prefix, s, string_of_int num_T_args]
  10.491 +  |> space_implode Long_Name.separator
  10.492 +
  10.493 +fun robust_const_type thy s =
  10.494 +  if s = app_op_name then
  10.495 +    Logic.varifyT_global @{typ "('a => 'b) => 'a => 'b"}
  10.496 +  else if String.isPrefix lam_lifted_prefix s then
  10.497 +    Logic.varifyT_global @{typ "'a => 'b"}
  10.498 +  else
  10.499 +    (* Old Skolems throw a "TYPE" exception here, which will be caught. *)
  10.500 +    s |> Sign.the_const_type thy
  10.501 +
  10.502 +(* This function only makes sense if "T" is as general as possible. *)
  10.503 +fun robust_const_typargs thy (s, T) =
  10.504 +  if s = app_op_name then
  10.505 +    let val (T1, T2) = T |> domain_type |> dest_funT in [T1, T2] end
  10.506 +  else if String.isPrefix old_skolem_const_prefix s then
  10.507 +    [] |> Term.add_tvarsT T |> rev |> map TVar
  10.508 +  else if String.isPrefix lam_lifted_prefix s then
  10.509 +    if String.isPrefix lam_lifted_poly_prefix s then
  10.510 +      let val (T1, T2) = T |> dest_funT in [T1, T2] end
  10.511 +    else
  10.512 +      []
  10.513 +  else
  10.514 +    (s, T) |> Sign.const_typargs thy
  10.515 +
  10.516 +(* Converts an Isabelle/HOL term (with combinators) into an intermediate term.
  10.517 +   Also accumulates sort infomation. *)
  10.518 +fun iterm_from_term thy format bs (P $ Q) =
  10.519 +    let
  10.520 +      val (P', P_atomics_Ts) = iterm_from_term thy format bs P
  10.521 +      val (Q', Q_atomics_Ts) = iterm_from_term thy format bs Q
  10.522 +    in (IApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end
  10.523 +  | iterm_from_term thy format _ (Const (c, T)) =
  10.524 +    (IConst (`(make_fixed_const (SOME format)) c, T,
  10.525 +             robust_const_typargs thy (c, T)),
  10.526 +     atomic_types_of T)
  10.527 +  | iterm_from_term _ _ _ (Free (s, T)) =
  10.528 +    (IConst (`make_fixed_var s, T, []), atomic_types_of T)
  10.529 +  | iterm_from_term _ format _ (Var (v as (s, _), T)) =
  10.530 +    (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
  10.531 +       let
  10.532 +         val Ts = T |> strip_type |> swap |> op ::
  10.533 +         val s' = new_skolem_const_name s (length Ts)
  10.534 +       in IConst (`(make_fixed_const (SOME format)) s', T, Ts) end
  10.535 +     else
  10.536 +       IVar ((make_schematic_var v, s), T), atomic_types_of T)
  10.537 +  | iterm_from_term _ _ bs (Bound j) =
  10.538 +    nth bs j |> (fn (_, (name, T)) => (IConst (name, T, []), atomic_types_of T))
  10.539 +  | iterm_from_term thy format bs (Abs (s, T, t)) =
  10.540 +    let
  10.541 +      fun vary s = s |> AList.defined (op =) bs s ? vary o Symbol.bump_string
  10.542 +      val s = vary s
  10.543 +      val name = `make_bound_var s
  10.544 +      val (tm, atomic_Ts) = iterm_from_term thy format ((s, (name, T)) :: bs) t
  10.545 +    in (IAbs ((name, T), tm), union (op =) atomic_Ts (atomic_types_of T)) end
  10.546 +
  10.547 +datatype locality =
  10.548 +  General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained
  10.549 +
  10.550 +datatype order = First_Order | Higher_Order
  10.551 +datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic
  10.552 +datatype strictness = Strict | Non_Strict
  10.553 +datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars
  10.554 +datatype type_level =
  10.555 +  All_Types |
  10.556 +  Noninf_Nonmono_Types of strictness * granularity |
  10.557 +  Fin_Nonmono_Types of granularity |
  10.558 +  Const_Arg_Types |
  10.559 +  No_Types
  10.560 +
  10.561 +datatype type_enc =
  10.562 +  Simple_Types of order * polymorphism * type_level |
  10.563 +  Guards of polymorphism * type_level |
  10.564 +  Tags of polymorphism * type_level
  10.565 +
  10.566 +fun is_type_enc_higher_order (Simple_Types (Higher_Order, _, _)) = true
  10.567 +  | is_type_enc_higher_order _ = false
  10.568 +
  10.569 +fun polymorphism_of_type_enc (Simple_Types (_, poly, _)) = poly
  10.570 +  | polymorphism_of_type_enc (Guards (poly, _)) = poly
  10.571 +  | polymorphism_of_type_enc (Tags (poly, _)) = poly
  10.572 +
  10.573 +fun level_of_type_enc (Simple_Types (_, _, level)) = level
  10.574 +  | level_of_type_enc (Guards (_, level)) = level
  10.575 +  | level_of_type_enc (Tags (_, level)) = level
  10.576 +
  10.577 +fun granularity_of_type_level (Noninf_Nonmono_Types (_, grain)) = grain
  10.578 +  | granularity_of_type_level (Fin_Nonmono_Types grain) = grain
  10.579 +  | granularity_of_type_level _ = All_Vars
  10.580 +
  10.581 +fun is_type_level_quasi_sound All_Types = true
  10.582 +  | is_type_level_quasi_sound (Noninf_Nonmono_Types _) = true
  10.583 +  | is_type_level_quasi_sound _ = false
  10.584 +val is_type_enc_quasi_sound = is_type_level_quasi_sound o level_of_type_enc
  10.585 +
  10.586 +fun is_type_level_fairly_sound (Fin_Nonmono_Types _) = true
  10.587 +  | is_type_level_fairly_sound level = is_type_level_quasi_sound level
  10.588 +val is_type_enc_fairly_sound = is_type_level_fairly_sound o level_of_type_enc
  10.589 +
  10.590 +fun is_type_level_monotonicity_based (Noninf_Nonmono_Types _) = true
  10.591 +  | is_type_level_monotonicity_based (Fin_Nonmono_Types _) = true
  10.592 +  | is_type_level_monotonicity_based _ = false
  10.593 +
  10.594 +(* "_query", "_bang", and "_at" are for the ASCII-challenged Metis and
  10.595 +   Mirabelle. *)
  10.596 +val queries = ["?", "_query"]
  10.597 +val bangs = ["!", "_bang"]
  10.598 +val ats = ["@", "_at"]
  10.599 +
  10.600 +fun try_unsuffixes ss s =
  10.601 +  fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE
  10.602 +
  10.603 +fun try_nonmono constr suffixes fallback s =
  10.604 +  case try_unsuffixes suffixes s of
  10.605 +    SOME s =>
  10.606 +    (case try_unsuffixes suffixes s of
  10.607 +       SOME s => (constr Positively_Naked_Vars, s)
  10.608 +     | NONE =>
  10.609 +       case try_unsuffixes ats s of
  10.610 +         SOME s => (constr Ghost_Type_Arg_Vars, s)
  10.611 +       | NONE => (constr All_Vars, s))
  10.612 +  | NONE => fallback s
  10.613 +
  10.614 +fun type_enc_from_string strictness s =
  10.615 +  (case try (unprefix "poly_") s of
  10.616 +     SOME s => (SOME Polymorphic, s)
  10.617 +   | NONE =>
  10.618 +     case try (unprefix "raw_mono_") s of
  10.619 +       SOME s => (SOME Raw_Monomorphic, s)
  10.620 +     | NONE =>
  10.621 +       case try (unprefix "mono_") s of
  10.622 +         SOME s => (SOME Mangled_Monomorphic, s)
  10.623 +       | NONE => (NONE, s))
  10.624 +  ||> (pair All_Types
  10.625 +       |> try_nonmono Fin_Nonmono_Types bangs
  10.626 +       |> try_nonmono (curry Noninf_Nonmono_Types strictness) queries)
  10.627 +  |> (fn (poly, (level, core)) =>
  10.628 +         case (core, (poly, level)) of
  10.629 +           ("simple", (SOME poly, _)) =>
  10.630 +           (case (poly, level) of
  10.631 +              (Polymorphic, All_Types) =>
  10.632 +              Simple_Types (First_Order, Polymorphic, All_Types)
  10.633 +            | (Mangled_Monomorphic, _) =>
  10.634 +              if granularity_of_type_level level = All_Vars then
  10.635 +                Simple_Types (First_Order, Mangled_Monomorphic, level)
  10.636 +              else
  10.637 +                raise Same.SAME
  10.638 +            | _ => raise Same.SAME)
  10.639 +         | ("simple_higher", (SOME poly, _)) =>
  10.640 +           (case (poly, level) of
  10.641 +              (Polymorphic, All_Types) =>
  10.642 +              Simple_Types (Higher_Order, Polymorphic, All_Types)
  10.643 +            | (_, Noninf_Nonmono_Types _) => raise Same.SAME
  10.644 +            | (Mangled_Monomorphic, _) =>
  10.645 +              if granularity_of_type_level level = All_Vars then
  10.646 +                Simple_Types (Higher_Order, Mangled_Monomorphic, level)
  10.647 +              else
  10.648 +                raise Same.SAME
  10.649 +            | _ => raise Same.SAME)
  10.650 +         | ("guards", (SOME poly, _)) =>
  10.651 +           if poly = Mangled_Monomorphic andalso
  10.652 +              granularity_of_type_level level = Ghost_Type_Arg_Vars then
  10.653 +             raise Same.SAME
  10.654 +           else
  10.655 +             Guards (poly, level)
  10.656 +         | ("tags", (SOME poly, _)) =>
  10.657 +           if granularity_of_type_level level = Ghost_Type_Arg_Vars then
  10.658 +             raise Same.SAME
  10.659 +           else
  10.660 +             Tags (poly, level)
  10.661 +         | ("args", (SOME poly, All_Types (* naja *))) =>
  10.662 +           Guards (poly, Const_Arg_Types)
  10.663 +         | ("erased", (NONE, All_Types (* naja *))) =>
  10.664 +           Guards (Polymorphic, No_Types)
  10.665 +         | _ => raise Same.SAME)
  10.666 +  handle Same.SAME => error ("Unknown type encoding: " ^ quote s ^ ".")
  10.667 +
  10.668 +fun adjust_type_enc (THF (TPTP_Monomorphic, _, _))
  10.669 +                    (Simple_Types (order, _, level)) =
  10.670 +    Simple_Types (order, Mangled_Monomorphic, level)
  10.671 +  | adjust_type_enc (THF _) type_enc = type_enc
  10.672 +  | adjust_type_enc (TFF (TPTP_Monomorphic, _)) (Simple_Types (_, _, level)) =
  10.673 +    Simple_Types (First_Order, Mangled_Monomorphic, level)
  10.674 +  | adjust_type_enc (DFG DFG_Sorted) (Simple_Types (_, _, level)) =
  10.675 +    Simple_Types (First_Order, Mangled_Monomorphic, level)
  10.676 +  | adjust_type_enc (TFF _) (Simple_Types (_, poly, level)) =
  10.677 +    Simple_Types (First_Order, poly, level)
  10.678 +  | adjust_type_enc format (Simple_Types (_, poly, level)) =
  10.679 +    adjust_type_enc format (Guards (poly, level))
  10.680 +  | adjust_type_enc CNF_UEQ (type_enc as Guards stuff) =
  10.681 +    (if is_type_enc_fairly_sound type_enc then Tags else Guards) stuff
  10.682 +  | adjust_type_enc _ type_enc = type_enc
  10.683 +
  10.684 +fun constify_lifted (t $ u) = constify_lifted t $ constify_lifted u
  10.685 +  | constify_lifted (Abs (s, T, t)) = Abs (s, T, constify_lifted t)
  10.686 +  | constify_lifted (Free (x as (s, _))) =
  10.687 +    (if String.isPrefix lam_lifted_prefix s then Const else Free) x
  10.688 +  | constify_lifted t = t
  10.689 +
  10.690 +(* Requires bound variables not to clash with any schematic variables (as should
  10.691 +   be the case right after lambda-lifting). *)
  10.692 +fun open_form (Const (@{const_name All}, _) $ Abs (s, T, t)) =
  10.693 +    let
  10.694 +      val names = Name.make_context (map fst (Term.add_var_names t []))
  10.695 +      val (s, _) = Name.variant s names
  10.696 +    in open_form (subst_bound (Var ((s, 0), T), t)) end
  10.697 +  | open_form t = t
  10.698 +
  10.699 +fun lift_lams_part_1 ctxt type_enc =
  10.700 +  map close_form #> rpair ctxt
  10.701 +  #-> Lambda_Lifting.lift_lambdas
  10.702 +          (SOME ((if polymorphism_of_type_enc type_enc = Polymorphic then
  10.703 +                    lam_lifted_poly_prefix
  10.704 +                  else
  10.705 +                    lam_lifted_mono_prefix) ^ "_a"))
  10.706 +          Lambda_Lifting.is_quantifier
  10.707 +  #> fst
  10.708 +val lift_lams_part_2 = pairself (map (open_form o constify_lifted))
  10.709 +val lift_lams = lift_lams_part_2 ooo lift_lams_part_1
  10.710 +
  10.711 +fun intentionalize_def (Const (@{const_name All}, _) $ Abs (_, _, t)) =
  10.712 +    intentionalize_def t
  10.713 +  | intentionalize_def (Const (@{const_name HOL.eq}, _) $ t $ u) =
  10.714 +    let
  10.715 +      fun lam T t = Abs (Name.uu, T, t)
  10.716 +      val (head, args) = strip_comb t ||> rev
  10.717 +      val head_T = fastype_of head
  10.718 +      val n = length args
  10.719 +      val arg_Ts = head_T |> binder_types |> take n |> rev
  10.720 +      val u = u |> subst_atomic (args ~~ map Bound (0 upto n - 1))
  10.721 +    in HOLogic.eq_const head_T $ head $ fold lam arg_Ts u end
  10.722 +  | intentionalize_def t = t
  10.723 +
  10.724 +type translated_formula =
  10.725 +  {name : string,
  10.726 +   locality : locality,
  10.727 +   kind : formula_kind,
  10.728 +   iformula : (name, typ, iterm) formula,
  10.729 +   atomic_types : typ list}
  10.730 +
  10.731 +fun update_iformula f ({name, locality, kind, iformula, atomic_types}
  10.732 +                       : translated_formula) =
  10.733 +  {name = name, locality = locality, kind = kind, iformula = f iformula,
  10.734 +   atomic_types = atomic_types} : translated_formula
  10.735 +
  10.736 +fun fact_lift f ({iformula, ...} : translated_formula) = f iformula
  10.737 +
  10.738 +fun insert_type ctxt get_T x xs =
  10.739 +  let val T = get_T x in
  10.740 +    if exists (type_instance ctxt T o get_T) xs then xs
  10.741 +    else x :: filter_out (type_generalization ctxt T o get_T) xs
  10.742 +  end
  10.743 +
  10.744 +(* The Booleans indicate whether all type arguments should be kept. *)
  10.745 +datatype type_arg_policy =
  10.746 +  Explicit_Type_Args of bool (* infer_from_term_args *) |
  10.747 +  Mangled_Type_Args |
  10.748 +  No_Type_Args
  10.749 +
  10.750 +fun type_arg_policy monom_constrs type_enc s =
  10.751 +  let val poly = polymorphism_of_type_enc type_enc in
  10.752 +    if s = type_tag_name then
  10.753 +      if poly = Mangled_Monomorphic then Mangled_Type_Args
  10.754 +      else Explicit_Type_Args false
  10.755 +    else case type_enc of
  10.756 +      Simple_Types (_, Polymorphic, _) => Explicit_Type_Args false
  10.757 +    | Tags (_, All_Types) => No_Type_Args
  10.758 +    | _ =>
  10.759 +      let val level = level_of_type_enc type_enc in
  10.760 +        if level = No_Types orelse s = @{const_name HOL.eq} orelse
  10.761 +           (s = app_op_name andalso level = Const_Arg_Types) then
  10.762 +          No_Type_Args
  10.763 +        else if poly = Mangled_Monomorphic then
  10.764 +          Mangled_Type_Args
  10.765 +        else if member (op =) monom_constrs s andalso
  10.766 +                granularity_of_type_level level = Positively_Naked_Vars then
  10.767 +          No_Type_Args
  10.768 +        else
  10.769 +          Explicit_Type_Args
  10.770 +              (level = All_Types orelse
  10.771 +               granularity_of_type_level level = Ghost_Type_Arg_Vars)
  10.772 +      end
  10.773 +  end
  10.774 +
  10.775 +(* Make atoms for sorted type variables. *)
  10.776 +fun generic_add_sorts_on_type (_, []) = I
  10.777 +  | generic_add_sorts_on_type ((x, i), s :: ss) =
  10.778 +    generic_add_sorts_on_type ((x, i), ss)
  10.779 +    #> (if s = the_single @{sort HOL.type} then
  10.780 +          I
  10.781 +        else if i = ~1 then
  10.782 +          insert (op =) (`make_type_class s, `make_fixed_type_var x)
  10.783 +        else
  10.784 +          insert (op =) (`make_type_class s,
  10.785 +                         (make_schematic_type_var (x, i), x)))
  10.786 +fun add_sorts_on_tfree (TFree (s, S)) = generic_add_sorts_on_type ((s, ~1), S)
  10.787 +  | add_sorts_on_tfree _ = I
  10.788 +fun add_sorts_on_tvar (TVar z) = generic_add_sorts_on_type z
  10.789 +  | add_sorts_on_tvar _ = I
  10.790 +
  10.791 +fun type_class_formula type_enc class arg =
  10.792 +  AAtom (ATerm (class, arg ::
  10.793 +      (case type_enc of
  10.794 +         Simple_Types (First_Order, Polymorphic, _) =>
  10.795 +         if avoid_first_order_ghost_type_vars then [ATerm (TYPE_name, [arg])]
  10.796 +         else []
  10.797 +       | _ => [])))
  10.798 +fun formulas_for_types type_enc add_sorts_on_typ Ts =
  10.799 +  [] |> level_of_type_enc type_enc <> No_Types ? fold add_sorts_on_typ Ts
  10.800 +     |> map (fn (class, name) =>
  10.801 +                type_class_formula type_enc class (ATerm (name, [])))
  10.802 +
  10.803 +fun mk_aconns c phis =
  10.804 +  let val (phis', phi') = split_last phis in
  10.805 +    fold_rev (mk_aconn c) phis' phi'
  10.806 +  end
  10.807 +fun mk_ahorn [] phi = phi
  10.808 +  | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi])
  10.809 +fun mk_aquant _ [] phi = phi
  10.810 +  | mk_aquant q xs (phi as AQuant (q', xs', phi')) =
  10.811 +    if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi)
  10.812 +  | mk_aquant q xs phi = AQuant (q, xs, phi)
  10.813 +
  10.814 +fun close_universally add_term_vars phi =
  10.815 +  let
  10.816 +    fun add_formula_vars bounds (AQuant (_, xs, phi)) =
  10.817 +        add_formula_vars (map fst xs @ bounds) phi
  10.818 +      | add_formula_vars bounds (AConn (_, phis)) =
  10.819 +        fold (add_formula_vars bounds) phis
  10.820 +      | add_formula_vars bounds (AAtom tm) = add_term_vars bounds tm
  10.821 +  in mk_aquant AForall (add_formula_vars [] phi []) phi end
  10.822 +
  10.823 +fun add_term_vars bounds (ATerm (name as (s, _), tms)) =
  10.824 +    (if is_tptp_variable s andalso
  10.825 +        not (String.isPrefix tvar_prefix s) andalso
  10.826 +        not (member (op =) bounds name) then
  10.827 +       insert (op =) (name, NONE)
  10.828 +     else
  10.829 +       I)
  10.830 +    #> fold (add_term_vars bounds) tms
  10.831 +  | add_term_vars bounds (AAbs ((name, _), tm)) =
  10.832 +    add_term_vars (name :: bounds) tm
  10.833 +fun close_formula_universally phi = close_universally add_term_vars phi
  10.834 +
  10.835 +fun add_iterm_vars bounds (IApp (tm1, tm2)) =
  10.836 +    fold (add_iterm_vars bounds) [tm1, tm2]
  10.837 +  | add_iterm_vars _ (IConst _) = I
  10.838 +  | add_iterm_vars bounds (IVar (name, T)) =
  10.839 +    not (member (op =) bounds name) ? insert (op =) (name, SOME T)
  10.840 +  | add_iterm_vars bounds (IAbs (_, tm)) = add_iterm_vars bounds tm
  10.841 +fun close_iformula_universally phi = close_universally add_iterm_vars phi
  10.842 +
  10.843 +val fused_infinite_type_name = @{type_name ind} (* any infinite type *)
  10.844 +val fused_infinite_type = Type (fused_infinite_type_name, [])
  10.845 +
  10.846 +fun tvar_name (x as (s, _)) = (make_schematic_type_var x, s)
  10.847 +
  10.848 +fun ho_term_from_typ format type_enc =
  10.849 +  let
  10.850 +    fun term (Type (s, Ts)) =
  10.851 +      ATerm (case (is_type_enc_higher_order type_enc, s) of
  10.852 +               (true, @{type_name bool}) => `I tptp_bool_type
  10.853 +             | (true, @{type_name fun}) => `I tptp_fun_type
  10.854 +             | _ => if s = fused_infinite_type_name andalso
  10.855 +                       is_format_typed format then
  10.856 +                      `I tptp_individual_type
  10.857 +                    else
  10.858 +                      `make_fixed_type_const s,
  10.859 +             map term Ts)
  10.860 +    | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, [])
  10.861 +    | term (TVar (x, _)) = ATerm (tvar_name x, [])
  10.862 +  in term end
  10.863 +
  10.864 +fun ho_term_for_type_arg format type_enc T =
  10.865 +  if T = dummyT then NONE else SOME (ho_term_from_typ format type_enc T)
  10.866 +
  10.867 +(* This shouldn't clash with anything else. *)
  10.868 +val mangled_type_sep = "\000"
  10.869 +
  10.870 +fun generic_mangled_type_name f (ATerm (name, [])) = f name
  10.871 +  | generic_mangled_type_name f (ATerm (name, tys)) =
  10.872 +    f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys)
  10.873 +    ^ ")"
  10.874 +  | generic_mangled_type_name _ _ = raise Fail "unexpected type abstraction"
  10.875 +
  10.876 +fun mangled_type format type_enc =
  10.877 +  generic_mangled_type_name fst o ho_term_from_typ format type_enc
  10.878 +
  10.879 +fun make_simple_type s =
  10.880 +  if s = tptp_bool_type orelse s = tptp_fun_type orelse
  10.881 +     s = tptp_individual_type then
  10.882 +    s
  10.883 +  else
  10.884 +    simple_type_prefix ^ ascii_of s
  10.885 +
  10.886 +fun ho_type_from_ho_term type_enc pred_sym ary =
  10.887 +  let
  10.888 +    fun to_mangled_atype ty =
  10.889 +      AType ((make_simple_type (generic_mangled_type_name fst ty),
  10.890 +              generic_mangled_type_name snd ty), [])
  10.891 +    fun to_poly_atype (ATerm (name, tys)) = AType (name, map to_poly_atype tys)
  10.892 +      | to_poly_atype _ = raise Fail "unexpected type abstraction"
  10.893 +    val to_atype =
  10.894 +      if polymorphism_of_type_enc type_enc = Polymorphic then to_poly_atype
  10.895 +      else to_mangled_atype
  10.896 +    fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1))
  10.897 +    fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty
  10.898 +      | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys
  10.899 +      | to_fo _ _ = raise Fail "unexpected type abstraction"
  10.900 +    fun to_ho (ty as ATerm ((s, _), tys)) =
  10.901 +        if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty
  10.902 +      | to_ho _ = raise Fail "unexpected type abstraction"
  10.903 +  in if is_type_enc_higher_order type_enc then to_ho else to_fo ary end
  10.904 +
  10.905 +fun ho_type_from_typ format type_enc pred_sym ary =
  10.906 +  ho_type_from_ho_term type_enc pred_sym ary
  10.907 +  o ho_term_from_typ format type_enc
  10.908 +
  10.909 +fun mangled_const_name format type_enc T_args (s, s') =
  10.910 +  let
  10.911 +    val ty_args = T_args |> map_filter (ho_term_for_type_arg format type_enc)
  10.912 +    fun type_suffix f g =
  10.913 +      fold_rev (curry (op ^) o g o prefix mangled_type_sep
  10.914 +                o generic_mangled_type_name f) ty_args ""
  10.915 +  in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end
  10.916 +
  10.917 +val parse_mangled_ident =
  10.918 +  Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode
  10.919 +
  10.920 +fun parse_mangled_type x =
  10.921 +  (parse_mangled_ident
  10.922 +   -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")")
  10.923 +                    [] >> ATerm) x
  10.924 +and parse_mangled_types x =
  10.925 +  (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x
  10.926 +
  10.927 +fun unmangled_type s =
  10.928 +  s |> suffix ")" |> raw_explode
  10.929 +    |> Scan.finite Symbol.stopper
  10.930 +           (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^
  10.931 +                                                quote s)) parse_mangled_type))
  10.932 +    |> fst
  10.933 +
  10.934 +val unmangled_const_name = space_explode mangled_type_sep #> hd
  10.935 +fun unmangled_const s =
  10.936 +  let val ss = space_explode mangled_type_sep s in
  10.937 +    (hd ss, map unmangled_type (tl ss))
  10.938 +  end
  10.939 +
  10.940 +fun introduce_proxies_in_iterm type_enc =
  10.941 +  let
  10.942 +    fun tweak_ho_quant ho_quant T [IAbs _] = IConst (`I ho_quant, T, [])
  10.943 +      | tweak_ho_quant ho_quant (T as Type (_, [p_T as Type (_, [x_T, _]), _]))
  10.944 +                       _ =
  10.945 +        (* Eta-expand "!!" and "??", to work around LEO-II 1.2.8 parser
  10.946 +           limitation. This works in conjuction with special code in
  10.947 +           "ATP_Problem" that uses the syntactic sugar "!" and "?" whenever
  10.948 +           possible. *)
  10.949 +        IAbs ((`I "P", p_T),
  10.950 +              IApp (IConst (`I ho_quant, T, []),
  10.951 +                    IAbs ((`I "X", x_T),
  10.952 +                          IApp (IConst (`I "P", p_T, []),
  10.953 +                                IConst (`I "X", x_T, [])))))
  10.954 +      | tweak_ho_quant _ _ _ = raise Fail "unexpected type for quantifier"
  10.955 +    fun intro top_level args (IApp (tm1, tm2)) =
  10.956 +        IApp (intro top_level (tm2 :: args) tm1, intro false [] tm2)
  10.957 +      | intro top_level args (IConst (name as (s, _), T, T_args)) =
  10.958 +        (case proxify_const s of
  10.959 +           SOME proxy_base =>
  10.960 +           if top_level orelse is_type_enc_higher_order type_enc then
  10.961 +             case (top_level, s) of
  10.962 +               (_, "c_False") => IConst (`I tptp_false, T, [])
  10.963 +             | (_, "c_True") => IConst (`I tptp_true, T, [])
  10.964 +             | (false, "c_Not") => IConst (`I tptp_not, T, [])
  10.965 +             | (false, "c_conj") => IConst (`I tptp_and, T, [])
  10.966 +             | (false, "c_disj") => IConst (`I tptp_or, T, [])
  10.967 +             | (false, "c_implies") => IConst (`I tptp_implies, T, [])
  10.968 +             | (false, "c_All") => tweak_ho_quant tptp_ho_forall T args
  10.969 +             | (false, "c_Ex") => tweak_ho_quant tptp_ho_exists T args
  10.970 +             | (false, s) =>
  10.971 +               if is_tptp_equal s andalso length args = 2 then
  10.972 +                 IConst (`I tptp_equal, T, [])
  10.973 +               else
  10.974 +                 (* Use a proxy even for partially applied THF0 equality,
  10.975 +                    because the LEO-II and Satallax parsers complain about not
  10.976 +                    being able to infer the type of "=". *)
  10.977 +                 IConst (proxy_base |>> prefix const_prefix, T, T_args)
  10.978 +             | _ => IConst (name, T, [])
  10.979 +           else
  10.980 +             IConst (proxy_base |>> prefix const_prefix, T, T_args)
  10.981 +          | NONE => if s = tptp_choice then tweak_ho_quant tptp_choice T args
  10.982 +                    else IConst (name, T, T_args))
  10.983 +      | intro _ _ (IAbs (bound, tm)) = IAbs (bound, intro false [] tm)
  10.984 +      | intro _ _ tm = tm
  10.985 +  in intro true [] end
  10.986 +
  10.987 +fun mangle_type_args_in_iterm format type_enc =
  10.988 +  if polymorphism_of_type_enc type_enc = Mangled_Monomorphic then
  10.989 +    let
  10.990 +      fun mangle (IApp (tm1, tm2)) = IApp (mangle tm1, mangle tm2)
  10.991 +        | mangle (tm as IConst (_, _, [])) = tm
  10.992 +        | mangle (tm as IConst (name as (s, _), T, T_args)) =
  10.993 +          (case unprefix_and_unascii const_prefix s of
  10.994 +             NONE => tm
  10.995 +           | SOME s'' =>
  10.996 +             case type_arg_policy [] type_enc (invert_const s'') of
  10.997 +               Mangled_Type_Args =>
  10.998 +               IConst (mangled_const_name format type_enc T_args name, T, [])
  10.999 +             | _ => tm)
 10.1000 +        | mangle (IAbs (bound, tm)) = IAbs (bound, mangle tm)
 10.1001 +        | mangle tm = tm
 10.1002 +    in mangle end
 10.1003 +  else
 10.1004 +    I
 10.1005 +
 10.1006 +fun chop_fun 0 T = ([], T)
 10.1007 +  | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) =
 10.1008 +    chop_fun (n - 1) ran_T |>> cons dom_T
 10.1009 +  | chop_fun _ T = ([], T)
 10.1010 +
 10.1011 +fun filter_const_type_args _ _ _ [] = []
 10.1012 +  | filter_const_type_args thy s ary T_args =
 10.1013 +    let
 10.1014 +      val U = robust_const_type thy s
 10.1015 +      val arg_U_vars = fold Term.add_tvarsT (U |> chop_fun ary |> fst) []
 10.1016 +      val U_args = (s, U) |> robust_const_typargs thy
 10.1017 +    in
 10.1018 +      U_args ~~ T_args
 10.1019 +      |> map (fn (U, T) =>
 10.1020 +                 if member (op =) arg_U_vars (dest_TVar U) then dummyT else T)
 10.1021 +    end
 10.1022 +    handle TYPE _ => T_args
 10.1023 +
 10.1024 +fun filter_type_args_in_iterm thy monom_constrs type_enc =
 10.1025 +  let
 10.1026 +    fun filt ary (IApp (tm1, tm2)) = IApp (filt (ary + 1) tm1, filt 0 tm2)
 10.1027 +      | filt _ (tm as IConst (_, _, [])) = tm
 10.1028 +      | filt ary (IConst (name as (s, _), T, T_args)) =
 10.1029 +        (case unprefix_and_unascii const_prefix s of
 10.1030 +           NONE =>
 10.1031 +           (name,
 10.1032 +            if level_of_type_enc type_enc = No_Types orelse s = tptp_choice then
 10.1033 +              []
 10.1034 +            else
 10.1035 +              T_args)
 10.1036 +         | SOME s'' =>
 10.1037 +           let
 10.1038 +             val s'' = invert_const s''
 10.1039 +             fun filter_T_args false = T_args
 10.1040 +               | filter_T_args true = filter_const_type_args thy s'' ary T_args
 10.1041 +           in
 10.1042 +             case type_arg_policy monom_constrs type_enc s'' of
 10.1043 +               Explicit_Type_Args infer_from_term_args =>
 10.1044 +               (name, filter_T_args infer_from_term_args)
 10.1045 +             | No_Type_Args => (name, [])
 10.1046 +             | Mangled_Type_Args => raise Fail "unexpected (un)mangled symbol"
 10.1047 +           end)
 10.1048 +        |> (fn (name, T_args) => IConst (name, T, T_args))
 10.1049 +      | filt _ (IAbs (bound, tm)) = IAbs (bound, filt 0 tm)
 10.1050 +      | filt _ tm = tm
 10.1051 +  in filt 0 end
 10.1052 +
 10.1053 +fun iformula_from_prop ctxt format type_enc eq_as_iff =
 10.1054 +  let
 10.1055 +    val thy = Proof_Context.theory_of ctxt
 10.1056 +    fun do_term bs t atomic_Ts =
 10.1057 +      iterm_from_term thy format bs (Envir.eta_contract t)
 10.1058 +      |>> (introduce_proxies_in_iterm type_enc
 10.1059 +           #> mangle_type_args_in_iterm format type_enc
 10.1060 +           #> AAtom)
 10.1061 +      ||> union (op =) atomic_Ts
 10.1062 +    fun do_quant bs q pos s T t' =
 10.1063 +      let
 10.1064 +        val s = singleton (Name.variant_list (map fst bs)) s
 10.1065 +        val universal = Option.map (q = AExists ? not) pos
 10.1066 +        val name =
 10.1067 +          s |> `(case universal of
 10.1068 +                   SOME true => make_all_bound_var
 10.1069 +                 | SOME false => make_exist_bound_var
 10.1070 +                 | NONE => make_bound_var)
 10.1071 +      in
 10.1072 +        do_formula ((s, (name, T)) :: bs) pos t'
 10.1073 +        #>> mk_aquant q [(name, SOME T)]
 10.1074 +        ##> union (op =) (atomic_types_of T)
 10.1075 +      end
 10.1076 +    and do_conn bs c pos1 t1 pos2 t2 =
 10.1077 +      do_formula bs pos1 t1 ##>> do_formula bs pos2 t2 #>> uncurry (mk_aconn c)
 10.1078 +    and do_formula bs pos t =
 10.1079 +      case t of
 10.1080 +        @{const Trueprop} $ t1 => do_formula bs pos t1
 10.1081 +      | @{const Not} $ t1 => do_formula bs (Option.map not pos) t1 #>> mk_anot
 10.1082 +      | Const (@{const_name All}, _) $ Abs (s, T, t') =>
 10.1083 +        do_quant bs AForall pos s T t'
 10.1084 +      | (t0 as Const (@{const_name All}, _)) $ t1 =>
 10.1085 +        do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1)
 10.1086 +      | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
 10.1087 +        do_quant bs AExists pos s T t'
 10.1088 +      | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
 10.1089 +        do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1)
 10.1090 +      | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd pos t1 pos t2
 10.1091 +      | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr pos t1 pos t2
 10.1092 +      | @{const HOL.implies} $ t1 $ t2 =>
 10.1093 +        do_conn bs AImplies (Option.map not pos) t1 pos t2
 10.1094 +      | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 =>
 10.1095 +        if eq_as_iff then do_conn bs AIff NONE t1 NONE t2 else do_term bs t
 10.1096 +      | _ => do_term bs t
 10.1097 +  in do_formula [] end
 10.1098 +
 10.1099 +fun presimplify_term ctxt t =
 10.1100 +  t |> exists_Const (member (op =) Meson.presimplified_consts o fst) t
 10.1101 +       ? (Skip_Proof.make_thm (Proof_Context.theory_of ctxt)
 10.1102 +          #> Meson.presimplify
 10.1103 +          #> prop_of)
 10.1104 +
 10.1105 +fun concealed_bound_name j = atp_weak_prefix ^ string_of_int j
 10.1106 +fun conceal_bounds Ts t =
 10.1107 +  subst_bounds (map (Free o apfst concealed_bound_name)
 10.1108 +                    (0 upto length Ts - 1 ~~ Ts), t)
 10.1109 +fun reveal_bounds Ts =
 10.1110 +  subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j))
 10.1111 +                    (0 upto length Ts - 1 ~~ Ts))
 10.1112 +
 10.1113 +fun is_fun_equality (@{const_name HOL.eq},
 10.1114 +                     Type (_, [Type (@{type_name fun}, _), _])) = true
 10.1115 +  | is_fun_equality _ = false
 10.1116 +
 10.1117 +fun extensionalize_term ctxt t =
 10.1118 +  if exists_Const is_fun_equality t then
 10.1119 +    let val thy = Proof_Context.theory_of ctxt in
 10.1120 +      t |> cterm_of thy |> Meson.extensionalize_conv ctxt
 10.1121 +        |> prop_of |> Logic.dest_equals |> snd
 10.1122 +    end
 10.1123 +  else
 10.1124 +    t
 10.1125 +
 10.1126 +fun simple_translate_lambdas do_lambdas ctxt t =
 10.1127 +  let val thy = Proof_Context.theory_of ctxt in
 10.1128 +    if Meson.is_fol_term thy t then
 10.1129 +      t
 10.1130 +    else
 10.1131 +      let
 10.1132 +        fun trans Ts t =
 10.1133 +          case t of
 10.1134 +            @{const Not} $ t1 => @{const Not} $ trans Ts t1
 10.1135 +          | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') =>
 10.1136 +            t0 $ Abs (s, T, trans (T :: Ts) t')
 10.1137 +          | (t0 as Const (@{const_name All}, _)) $ t1 =>
 10.1138 +            trans Ts (t0 $ eta_expand Ts t1 1)
 10.1139 +          | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') =>
 10.1140 +            t0 $ Abs (s, T, trans (T :: Ts) t')
 10.1141 +          | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
 10.1142 +            trans Ts (t0 $ eta_expand Ts t1 1)
 10.1143 +          | (t0 as @{const HOL.conj}) $ t1 $ t2 =>
 10.1144 +            t0 $ trans Ts t1 $ trans Ts t2
 10.1145 +          | (t0 as @{const HOL.disj}) $ t1 $ t2 =>
 10.1146 +            t0 $ trans Ts t1 $ trans Ts t2
 10.1147 +          | (t0 as @{const HOL.implies}) $ t1 $ t2 =>
 10.1148 +            t0 $ trans Ts t1 $ trans Ts t2
 10.1149 +          | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])))
 10.1150 +              $ t1 $ t2 =>
 10.1151 +            t0 $ trans Ts t1 $ trans Ts t2
 10.1152 +          | _ =>
 10.1153 +            if not (exists_subterm (fn Abs _ => true | _ => false) t) then t
 10.1154 +            else t |> Envir.eta_contract |> do_lambdas ctxt Ts
 10.1155 +        val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single
 10.1156 +      in t |> trans [] |> singleton (Variable.export_terms ctxt' ctxt) end
 10.1157 +  end
 10.1158 +
 10.1159 +fun do_cheaply_conceal_lambdas Ts (t1 $ t2) =
 10.1160 +    do_cheaply_conceal_lambdas Ts t1
 10.1161 +    $ do_cheaply_conceal_lambdas Ts t2
 10.1162 +  | do_cheaply_conceal_lambdas Ts (Abs (_, T, t)) =
 10.1163 +    Const (lam_lifted_poly_prefix ^ serial_string (),
 10.1164 +           T --> fastype_of1 (T :: Ts, t))
 10.1165 +  | do_cheaply_conceal_lambdas _ t = t
 10.1166 +
 10.1167 +fun do_introduce_combinators ctxt Ts t =
 10.1168 +  let val thy = Proof_Context.theory_of ctxt in
 10.1169 +    t |> conceal_bounds Ts
 10.1170 +      |> cterm_of thy
 10.1171 +      |> Meson_Clausify.introduce_combinators_in_cterm
 10.1172 +      |> prop_of |> Logic.dest_equals |> snd
 10.1173 +      |> reveal_bounds Ts
 10.1174 +  end
 10.1175 +  (* A type variable of sort "{}" will make abstraction fail. *)
 10.1176 +  handle THM _ => t |> do_cheaply_conceal_lambdas Ts
 10.1177 +val introduce_combinators = simple_translate_lambdas do_introduce_combinators
 10.1178 +
 10.1179 +fun preprocess_abstractions_in_terms trans_lams facts =
 10.1180 +  let
 10.1181 +    val (facts, lambda_ts) =
 10.1182 +      facts |> map (snd o snd) |> trans_lams
 10.1183 +            |>> map2 (fn (name, (kind, _)) => fn t => (name, (kind, t))) facts
 10.1184 +    val lam_facts =
 10.1185 +      map2 (fn t => fn j =>
 10.1186 +               ((lam_fact_prefix ^ Int.toString j, Helper), (Axiom, t)))
 10.1187 +           lambda_ts (1 upto length lambda_ts)
 10.1188 +  in (facts, lam_facts) end
 10.1189 +
 10.1190 +(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the
 10.1191 +   same in Sledgehammer to prevent the discovery of unreplayable proofs. *)
 10.1192 +fun freeze_term t =
 10.1193 +  let
 10.1194 +    fun freeze (t $ u) = freeze t $ freeze u
 10.1195 +      | freeze (Abs (s, T, t)) = Abs (s, T, freeze t)
 10.1196 +      | freeze (Var ((s, i), T)) =
 10.1197 +        Free (atp_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
 10.1198 +      | freeze t = t
 10.1199 +  in t |> exists_subterm is_Var t ? freeze end
 10.1200 +
 10.1201 +fun presimp_prop ctxt role t =
 10.1202 +  (let
 10.1203 +     val thy = Proof_Context.theory_of ctxt
 10.1204 +     val t = t |> Envir.beta_eta_contract
 10.1205 +               |> transform_elim_prop
 10.1206 +               |> Object_Logic.atomize_term thy
 10.1207 +     val need_trueprop = (fastype_of t = @{typ bool})
 10.1208 +   in
 10.1209 +     t |> need_trueprop ? HOLogic.mk_Trueprop
 10.1210 +       |> extensionalize_term ctxt
 10.1211 +       |> presimplify_term ctxt
 10.1212 +       |> HOLogic.dest_Trueprop
 10.1213 +   end
 10.1214 +   handle TERM _ => if role = Conjecture then @{term False} else @{term True})
 10.1215 +  |> pair role
 10.1216 +
 10.1217 +fun make_formula ctxt format type_enc eq_as_iff name loc kind t =
 10.1218 +  let
 10.1219 +    val (iformula, atomic_Ts) =
 10.1220 +      iformula_from_prop ctxt format type_enc eq_as_iff
 10.1221 +                         (SOME (kind <> Conjecture)) t []
 10.1222 +      |>> close_iformula_universally
 10.1223 +  in
 10.1224 +    {name = name, locality = loc, kind = kind, iformula = iformula,
 10.1225 +     atomic_types = atomic_Ts}
 10.1226 +  end
 10.1227 +
 10.1228 +fun make_fact ctxt format type_enc eq_as_iff ((name, loc), t) =
 10.1229 +  case t |> make_formula ctxt format type_enc (eq_as_iff andalso format <> CNF)
 10.1230 +                         name loc Axiom of
 10.1231 +    formula as {iformula = AAtom (IConst ((s, _), _, _)), ...} =>
 10.1232 +    if s = tptp_true then NONE else SOME formula
 10.1233 +  | formula => SOME formula
 10.1234 +
 10.1235 +fun s_not_trueprop (@{const Trueprop} $ t) = @{const Trueprop} $ s_not t
 10.1236 +  | s_not_trueprop t =
 10.1237 +    if fastype_of t = @{typ bool} then s_not t else @{prop False} (* too meta *)
 10.1238 +
 10.1239 +fun make_conjecture ctxt format type_enc =
 10.1240 +  map (fn ((name, loc), (kind, t)) =>
 10.1241 +          t |> kind = Conjecture ? s_not_trueprop
 10.1242 +            |> make_formula ctxt format type_enc (format <> CNF) name loc kind)
 10.1243 +
 10.1244 +(** Finite and infinite type inference **)
 10.1245 +
 10.1246 +fun tvar_footprint thy s ary =
 10.1247 +  (case unprefix_and_unascii const_prefix s of
 10.1248 +     SOME s =>
 10.1249 +     s |> invert_const |> robust_const_type thy |> chop_fun ary |> fst
 10.1250 +       |> map (fn T => Term.add_tvarsT T [] |> map fst)
 10.1251 +   | NONE => [])
 10.1252 +  handle TYPE _ => []
 10.1253 +
 10.1254 +fun ghost_type_args thy s ary =
 10.1255 +  if is_tptp_equal s then
 10.1256 +    0 upto ary - 1
 10.1257 +  else
 10.1258 +    let
 10.1259 +      val footprint = tvar_footprint thy s ary
 10.1260 +      val eq = (s = @{const_name HOL.eq})
 10.1261 +      fun ghosts _ [] = []
 10.1262 +        | ghosts seen ((i, tvars) :: args) =
 10.1263 +          ghosts (union (op =) seen tvars) args
 10.1264 +          |> (eq orelse exists (fn tvar => not (member (op =) seen tvar)) tvars)
 10.1265 +             ? cons i
 10.1266 +    in
 10.1267 +      if forall null footprint then
 10.1268 +        []
 10.1269 +      else
 10.1270 +        0 upto length footprint - 1 ~~ footprint
 10.1271 +        |> sort (rev_order o list_ord Term_Ord.indexname_ord o pairself snd)
 10.1272 +        |> ghosts []
 10.1273 +    end
 10.1274 +
 10.1275 +type monotonicity_info =
 10.1276 +  {maybe_finite_Ts : typ list,
 10.1277 +   surely_finite_Ts : typ list,
 10.1278 +   maybe_infinite_Ts : typ list,
 10.1279 +   surely_infinite_Ts : typ list,
 10.1280 +   maybe_nonmono_Ts : typ list}
 10.1281 +
 10.1282 +(* These types witness that the type classes they belong to allow infinite
 10.1283 +   models and hence that any types with these type classes is monotonic. *)
 10.1284 +val known_infinite_types =
 10.1285 +  [@{typ nat}, HOLogic.intT, HOLogic.realT, @{typ "nat => bool"}]
 10.1286 +
 10.1287 +fun is_type_kind_of_surely_infinite ctxt strictness cached_Ts T =
 10.1288 +  strictness <> Strict andalso is_type_surely_infinite ctxt true cached_Ts T
 10.1289 +
 10.1290 +(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are
 10.1291 +   dangerous because their "exhaust" properties can easily lead to unsound ATP
 10.1292 +   proofs. On the other hand, all HOL infinite types can be given the same
 10.1293 +   models in first-order logic (via Löwenheim-Skolem). *)
 10.1294 +
 10.1295 +fun should_encode_type _ (_ : monotonicity_info) All_Types _ = true
 10.1296 +  | should_encode_type ctxt {maybe_finite_Ts, surely_infinite_Ts,
 10.1297 +                             maybe_nonmono_Ts, ...}
 10.1298 +                       (Noninf_Nonmono_Types (strictness, grain)) T =
 10.1299 +    grain = Ghost_Type_Arg_Vars orelse
 10.1300 +    (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso
 10.1301 +     not (exists (type_instance ctxt T) surely_infinite_Ts orelse
 10.1302 +          (not (member (type_equiv ctxt) maybe_finite_Ts T) andalso
 10.1303 +           is_type_kind_of_surely_infinite ctxt strictness surely_infinite_Ts
 10.1304 +                                           T)))
 10.1305 +  | should_encode_type ctxt {surely_finite_Ts, maybe_infinite_Ts,
 10.1306 +                             maybe_nonmono_Ts, ...}
 10.1307 +                       (Fin_Nonmono_Types grain) T =
 10.1308 +    grain = Ghost_Type_Arg_Vars orelse
 10.1309 +    (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso
 10.1310 +     (exists (type_generalization ctxt T) surely_finite_Ts orelse
 10.1311 +      (not (member (type_equiv ctxt) maybe_infinite_Ts T) andalso
 10.1312 +       is_type_surely_finite ctxt T)))
 10.1313 +  | should_encode_type _ _ _ _ = false
 10.1314 +
 10.1315 +fun should_guard_type ctxt mono (Guards (_, level)) should_guard_var T =
 10.1316 +    should_guard_var () andalso should_encode_type ctxt mono level T
 10.1317 +  | should_guard_type _ _ _ _ _ = false
 10.1318 +
 10.1319 +fun is_maybe_universal_var (IConst ((s, _), _, _)) =
 10.1320 +    String.isPrefix bound_var_prefix s orelse
 10.1321 +    String.isPrefix all_bound_var_prefix s
 10.1322 +  | is_maybe_universal_var (IVar _) = true
 10.1323 +  | is_maybe_universal_var _ = false
 10.1324 +
 10.1325 +datatype site =
 10.1326 +  Top_Level of bool option |
 10.1327 +  Eq_Arg of bool option |
 10.1328 +  Elsewhere
 10.1329 +
 10.1330 +fun should_tag_with_type _ _ _ (Top_Level _) _ _ = false
 10.1331 +  | should_tag_with_type ctxt mono (Tags (_, level)) site u T =
 10.1332 +    if granularity_of_type_level level = All_Vars then
 10.1333 +      should_encode_type ctxt mono level T
 10.1334 +    else
 10.1335 +      (case (site, is_maybe_universal_var u) of
 10.1336 +         (Eq_Arg _, true) => should_encode_type ctxt mono level T
 10.1337 +       | _ => false)
 10.1338 +  | should_tag_with_type _ _ _ _ _ _ = false
 10.1339 +
 10.1340 +fun fused_type ctxt mono level =
 10.1341 +  let
 10.1342 +    val should_encode = should_encode_type ctxt mono level
 10.1343 +    fun fuse 0 T = if should_encode T then T else fused_infinite_type
 10.1344 +      | fuse ary (Type (@{type_name fun}, [T1, T2])) =
 10.1345 +        fuse 0 T1 --> fuse (ary - 1) T2
 10.1346 +      | fuse _ _ = raise Fail "expected function type"
 10.1347 +  in fuse end
 10.1348 +
 10.1349 +(** predicators and application operators **)
 10.1350 +
 10.1351 +type sym_info =
 10.1352 +  {pred_sym : bool, min_ary : int, max_ary : int, types : typ list,
 10.1353 +   in_conj : bool}
 10.1354 +
 10.1355 +fun default_sym_tab_entries type_enc =
 10.1356 +  (make_fixed_const NONE @{const_name undefined},
 10.1357 +       {pred_sym = false, min_ary = 0, max_ary = 0, types = [],
 10.1358 +        in_conj = false}) ::
 10.1359 +  ([tptp_false, tptp_true]
 10.1360 +   |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = [],
 10.1361 +                  in_conj = false})) @
 10.1362 +  ([tptp_equal, tptp_old_equal]
 10.1363 +   |> map (rpair {pred_sym = true, min_ary = 2, max_ary = 2, types = [],
 10.1364 +                  in_conj = false}))
 10.1365 +  |> not (is_type_enc_higher_order type_enc)
 10.1366 +     ? cons (prefixed_predicator_name,
 10.1367 +             {pred_sym = true, min_ary = 1, max_ary = 1, types = [],
 10.1368 +              in_conj = false})
 10.1369 +
 10.1370 +fun sym_table_for_facts ctxt type_enc explicit_apply conjs facts =
 10.1371 +  let
 10.1372 +    fun consider_var_ary const_T var_T max_ary =
 10.1373 +      let
 10.1374 +        fun iter ary T =
 10.1375 +          if ary = max_ary orelse type_instance ctxt var_T T orelse
 10.1376 +             type_instance ctxt T var_T then
 10.1377 +            ary
 10.1378 +          else
 10.1379 +            iter (ary + 1) (range_type T)
 10.1380 +      in iter 0 const_T end
 10.1381 +    fun add_universal_var T (accum as ((bool_vars, fun_var_Ts), sym_tab)) =
 10.1382 +      if explicit_apply = NONE andalso
 10.1383 +         (can dest_funT T orelse T = @{typ bool}) then
 10.1384 +        let
 10.1385 +          val bool_vars' = bool_vars orelse body_type T = @{typ bool}
 10.1386 +          fun repair_min_ary {pred_sym, min_ary, max_ary, types, in_conj} =
 10.1387 +            {pred_sym = pred_sym andalso not bool_vars',
 10.1388 +             min_ary = fold (fn T' => consider_var_ary T' T) types min_ary,
 10.1389 +             max_ary = max_ary, types = types, in_conj = in_conj}
 10.1390 +          val fun_var_Ts' =
 10.1391 +            fun_var_Ts |> can dest_funT T ? insert_type ctxt I T
 10.1392 +        in
 10.1393 +          if bool_vars' = bool_vars andalso
 10.1394 +             pointer_eq (fun_var_Ts', fun_var_Ts) then
 10.1395 +            accum
 10.1396 +          else
 10.1397 +            ((bool_vars', fun_var_Ts'), Symtab.map (K repair_min_ary) sym_tab)
 10.1398 +        end
 10.1399 +      else
 10.1400 +        accum
 10.1401 +    fun add_fact_syms conj_fact =
 10.1402 +      let
 10.1403 +        fun add_iterm_syms top_level tm
 10.1404 +                           (accum as ((bool_vars, fun_var_Ts), sym_tab)) =
 10.1405 +          let val (head, args) = strip_iterm_comb tm in
 10.1406 +            (case head of
 10.1407 +               IConst ((s, _), T, _) =>
 10.1408 +               if String.isPrefix bound_var_prefix s orelse
 10.1409 +                  String.isPrefix all_bound_var_prefix s then
 10.1410 +                 add_universal_var T accum
 10.1411 +               else if String.isPrefix exist_bound_var_prefix s then
 10.1412 +                 accum
 10.1413 +               else
 10.1414 +                 let val ary = length args in
 10.1415 +                   ((bool_vars, fun_var_Ts),
 10.1416 +                    case Symtab.lookup sym_tab s of
 10.1417 +                      SOME {pred_sym, min_ary, max_ary, types, in_conj} =>
 10.1418 +                      let
 10.1419 +                        val pred_sym =
 10.1420 +                          pred_sym andalso top_level andalso not bool_vars
 10.1421 +                        val types' = types |> insert_type ctxt I T
 10.1422 +                        val in_conj = in_conj orelse conj_fact
 10.1423 +                        val min_ary =
 10.1424 +                          if is_some explicit_apply orelse
 10.1425 +                             pointer_eq (types', types) then
 10.1426 +                            min_ary
 10.1427 +                          else
 10.1428 +                            fold (consider_var_ary T) fun_var_Ts min_ary
 10.1429 +                      in
 10.1430 +                        Symtab.update (s, {pred_sym = pred_sym,
 10.1431 +                                           min_ary = Int.min (ary, min_ary),
 10.1432 +                                           max_ary = Int.max (ary, max_ary),
 10.1433 +                                           types = types', in_conj = in_conj})
 10.1434 +                                      sym_tab
 10.1435 +                      end
 10.1436 +                    | NONE =>
 10.1437 +                      let
 10.1438 +                        val pred_sym = top_level andalso not bool_vars
 10.1439 +                        val min_ary =
 10.1440 +                          case explicit_apply of
 10.1441 +                            SOME true => 0
 10.1442 +                          | SOME false => ary
 10.1443 +                          | NONE => fold (consider_var_ary T) fun_var_Ts ary
 10.1444 +                      in
 10.1445 +                        Symtab.update_new (s,
 10.1446 +                            {pred_sym = pred_sym, min_ary = min_ary,
 10.1447 +                             max_ary = ary, types = [T], in_conj = conj_fact})
 10.1448 +                            sym_tab
 10.1449 +                      end)
 10.1450 +                 end
 10.1451 +             | IVar (_, T) => add_universal_var T accum
 10.1452 +             | IAbs ((_, T), tm) =>
 10.1453 +               accum |> add_universal_var T |> add_iterm_syms false tm
 10.1454 +             | _ => accum)
 10.1455 +            |> fold (add_iterm_syms false) args
 10.1456 +          end
 10.1457 +      in K (add_iterm_syms true) |> formula_fold NONE |> fact_lift end
 10.1458 +  in
 10.1459 +    ((false, []), Symtab.empty)
 10.1460 +    |> fold (add_fact_syms true) conjs
 10.1461 +    |> fold (add_fact_syms false) facts
 10.1462 +    |> snd
 10.1463 +    |> fold Symtab.update (default_sym_tab_entries type_enc)
 10.1464 +  end
 10.1465 +
 10.1466 +fun min_ary_of sym_tab s =
 10.1467 +  case Symtab.lookup sym_tab s of
 10.1468 +    SOME ({min_ary, ...} : sym_info) => min_ary
 10.1469 +  | NONE =>
 10.1470 +    case unprefix_and_unascii const_prefix s of
 10.1471 +      SOME s =>
 10.1472 +      let val s = s |> unmangled_const_name |> invert_const in
 10.1473 +        if s = predicator_name then 1
 10.1474 +        else if s = app_op_name then 2
 10.1475 +        else if s = type_guard_name then 1
 10.1476 +        else 0
 10.1477 +      end
 10.1478 +    | NONE => 0
 10.1479 +
 10.1480 +(* True if the constant ever appears outside of the top-level position in
 10.1481 +   literals, or if it appears with different arities (e.g., because of different
 10.1482 +   type instantiations). If false, the constant always receives all of its
 10.1483 +   arguments and is used as a predicate. *)
 10.1484 +fun is_pred_sym sym_tab s =
 10.1485 +  case Symtab.lookup sym_tab s of
 10.1486 +    SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) =>
 10.1487 +    pred_sym andalso min_ary = max_ary
 10.1488 +  | NONE => false
 10.1489 +
 10.1490 +val app_op = `(make_fixed_const NONE) app_op_name
 10.1491 +val predicator_combconst =
 10.1492 +  IConst (`(make_fixed_const NONE) predicator_name, @{typ "bool => bool"}, [])
 10.1493 +
 10.1494 +fun list_app head args = fold (curry (IApp o swap)) args head
 10.1495 +fun predicator tm = IApp (predicator_combconst, tm)
 10.1496 +
 10.1497 +fun firstorderize_fact thy monom_constrs format type_enc sym_tab =
 10.1498 +  let
 10.1499 +    fun do_app arg head =
 10.1500 +      let
 10.1501 +        val head_T = ityp_of head
 10.1502 +        val (arg_T, res_T) = dest_funT head_T
 10.1503 +        val app =
 10.1504 +          IConst (app_op, head_T --> head_T, [arg_T, res_T])
 10.1505 +          |> mangle_type_args_in_iterm format type_enc
 10.1506 +      in list_app app [head, arg] end
 10.1507 +    fun list_app_ops head args = fold do_app args head
 10.1508 +    fun introduce_app_ops tm =
 10.1509 +      case strip_iterm_comb tm of
 10.1510 +        (head as IConst ((s, _), _, _), args) =>
 10.1511 +        args |> map introduce_app_ops
 10.1512 +             |> chop (min_ary_of sym_tab s)
 10.1513 +             |>> list_app head
 10.1514 +             |-> list_app_ops
 10.1515 +      | (head, args) => list_app_ops head (map introduce_app_ops args)
 10.1516 +    fun introduce_predicators tm =
 10.1517 +      case strip_iterm_comb tm of
 10.1518 +        (IConst ((s, _), _, _), _) =>
 10.1519 +        if is_pred_sym sym_tab s then tm else predicator tm
 10.1520 +      | _ => predicator tm
 10.1521 +    val do_iterm =
 10.1522 +      not (is_type_enc_higher_order type_enc)
 10.1523 +      ? (introduce_app_ops #> introduce_predicators)
 10.1524 +      #> filter_type_args_in_iterm thy monom_constrs type_enc
 10.1525 +  in update_iformula (formula_map do_iterm) end
 10.1526 +
 10.1527 +(** Helper facts **)
 10.1528 +
 10.1529 +val not_ffalse = @{lemma "~ fFalse" by (unfold fFalse_def) fast}
 10.1530 +val ftrue = @{lemma "fTrue" by (unfold fTrue_def) fast}
 10.1531 +
 10.1532 +(* The Boolean indicates that a fairly sound type encoding is needed. *)
 10.1533 +val helper_table =
 10.1534 +  [(("COMBI", false), @{thms Meson.COMBI_def}),
 10.1535 +   (("COMBK", false), @{thms Meson.COMBK_def}),
 10.1536 +   (("COMBB", false), @{thms Meson.COMBB_def}),
 10.1537 +   (("COMBC", false), @{thms Meson.COMBC_def}),
 10.1538 +   (("COMBS", false), @{thms Meson.COMBS_def}),
 10.1539 +   ((predicator_name, false), [not_ffalse, ftrue]),
 10.1540 +   (("fFalse", false), [not_ffalse]),
 10.1541 +   (("fFalse", true), @{thms True_or_False}),
 10.1542 +   (("fTrue", false), [ftrue]),
 10.1543 +   (("fTrue", true), @{thms True_or_False}),
 10.1544 +   (("fNot", false),
 10.1545 +    @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1]
 10.1546 +           fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]}),
 10.1547 +   (("fconj", false),
 10.1548 +    @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q"
 10.1549 +        by (unfold fconj_def) fast+}),
 10.1550 +   (("fdisj", false),
 10.1551 +    @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q"
 10.1552 +        by (unfold fdisj_def) fast+}),
 10.1553 +   (("fimplies", false),
 10.1554 +    @{lemma "P | fimplies P Q" "~ Q | fimplies P Q" "~ fimplies P Q | ~ P | Q"
 10.1555 +        by (unfold fimplies_def) fast+}),
 10.1556 +   (("fequal", true),
 10.1557 +    (* This is a lie: Higher-order equality doesn't need a sound type encoding.
 10.1558 +       However, this is done so for backward compatibility: Including the
 10.1559 +       equality helpers by default in Metis breaks a few existing proofs. *)
 10.1560 +    @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1]
 10.1561 +           fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]}),
 10.1562 +   (* Partial characterization of "fAll" and "fEx". A complete characterization
 10.1563 +      would require the axiom of choice for replay with Metis. *)
 10.1564 +   (("fAll", false), [@{lemma "~ fAll P | P x" by (auto simp: fAll_def)}]),
 10.1565 +   (("fEx", false), [@{lemma "~ P x | fEx P" by (auto simp: fEx_def)}]),
 10.1566 +   (("If", true), @{thms if_True if_False True_or_False})]
 10.1567 +  |> map (apsnd (map zero_var_indexes))
 10.1568 +
 10.1569 +fun atype_of_type_vars (Simple_Types (_, Polymorphic, _)) = SOME atype_of_types
 10.1570 +  | atype_of_type_vars _ = NONE
 10.1571 +
 10.1572 +fun bound_tvars type_enc sorts Ts =
 10.1573 +  (sorts ? mk_ahorn (formulas_for_types type_enc add_sorts_on_tvar Ts))
 10.1574 +  #> mk_aquant AForall
 10.1575 +        (map_filter (fn TVar (x as (s, _), _) =>
 10.1576 +                        SOME ((make_schematic_type_var x, s),
 10.1577 +                              atype_of_type_vars type_enc)
 10.1578 +                      | _ => NONE) Ts)
 10.1579 +
 10.1580 +fun eq_formula type_enc atomic_Ts pred_sym tm1 tm2 =
 10.1581 +  (if pred_sym then AConn (AIff, [AAtom tm1, AAtom tm2])
 10.1582 +   else AAtom (ATerm (`I tptp_equal, [tm1, tm2])))
 10.1583 +  |> close_formula_universally
 10.1584 +  |> bound_tvars type_enc true atomic_Ts
 10.1585 +
 10.1586 +val type_tag = `(make_fixed_const NONE) type_tag_name
 10.1587 +
 10.1588 +fun type_tag_idempotence_fact format type_enc =
 10.1589 +  let
 10.1590 +    fun var s = ATerm (`I s, [])
 10.1591 +    fun tag tm = ATerm (type_tag, [var "A", tm])
 10.1592 +    val tagged_var = tag (var "X")
 10.1593 +  in
 10.1594 +    Formula (type_tag_idempotence_helper_name, Axiom,
 10.1595 +             eq_formula type_enc [] false (tag tagged_var) tagged_var,
 10.1596 +             isabelle_info format simpN, NONE)
 10.1597 +  end
 10.1598 +
 10.1599 +fun should_specialize_helper type_enc t =
 10.1600 +  polymorphism_of_type_enc type_enc <> Polymorphic andalso
 10.1601 +  level_of_type_enc type_enc <> No_Types andalso
 10.1602 +  not (null (Term.hidden_polymorphism t))
 10.1603 +
 10.1604 +fun helper_facts_for_sym ctxt format type_enc (s, {types, ...} : sym_info) =
 10.1605 +  case unprefix_and_unascii const_prefix s of
 10.1606 +    SOME mangled_s =>
 10.1607 +    let
 10.1608 +      val thy = Proof_Context.theory_of ctxt
 10.1609 +      val unmangled_s = mangled_s |> unmangled_const_name
 10.1610 +      fun dub needs_fairly_sound j k =
 10.1611 +        (unmangled_s ^ "_" ^ string_of_int j ^ "_" ^ string_of_int k ^
 10.1612 +         (if mangled_s = unmangled_s then "" else "_" ^ ascii_of mangled_s) ^
 10.1613 +         (if needs_fairly_sound then typed_helper_suffix
 10.1614 +          else untyped_helper_suffix),
 10.1615 +         Helper)
 10.1616 +      fun dub_and_inst needs_fairly_sound (th, j) =
 10.1617 +        let val t = prop_of th in
 10.1618 +          if should_specialize_helper type_enc t then
 10.1619 +            map (fn T => specialize_type thy (invert_const unmangled_s, T) t)
 10.1620 +                types
 10.1621 +          else
 10.1622 +            [t]
 10.1623 +        end
 10.1624 +        |> map (fn (k, t) => (dub needs_fairly_sound j k, t)) o tag_list 1
 10.1625 +      val make_facts = map_filter (make_fact ctxt format type_enc false)
 10.1626 +      val fairly_sound = is_type_enc_fairly_sound type_enc
 10.1627 +    in
 10.1628 +      helper_table
 10.1629 +      |> maps (fn ((helper_s, needs_fairly_sound), ths) =>
 10.1630 +                  if helper_s <> unmangled_s orelse
 10.1631 +                     (needs_fairly_sound andalso not fairly_sound) then
 10.1632 +                    []
 10.1633 +                  else
 10.1634 +                    ths ~~ (1 upto length ths)
 10.1635 +                    |> maps (dub_and_inst needs_fairly_sound)
 10.1636 +                    |> make_facts)
 10.1637 +    end
 10.1638 +  | NONE => []
 10.1639 +fun helper_facts_for_sym_table ctxt format type_enc sym_tab =
 10.1640 +  Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_enc) sym_tab
 10.1641 +                  []
 10.1642 +
 10.1643 +(***************************************************************)
 10.1644 +(* Type Classes Present in the Axiom or Conjecture Clauses     *)
 10.1645 +(***************************************************************)
 10.1646 +
 10.1647 +fun set_insert (x, s) = Symtab.update (x, ()) s
 10.1648 +
 10.1649 +fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
 10.1650 +
 10.1651 +(* Remove this trivial type class (FIXME: similar code elsewhere) *)
 10.1652 +fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset
 10.1653 +
 10.1654 +fun classes_of_terms get_Ts =
 10.1655 +  map (map snd o get_Ts)
 10.1656 +  #> List.foldl add_classes Symtab.empty
 10.1657 +  #> delete_type #> Symtab.keys
 10.1658 +
 10.1659 +val tfree_classes_of_terms = classes_of_terms Misc_Legacy.term_tfrees
 10.1660 +val tvar_classes_of_terms = classes_of_terms Misc_Legacy.term_tvars
 10.1661 +
 10.1662 +fun fold_type_constrs f (Type (s, Ts)) x =
 10.1663 +    fold (fold_type_constrs f) Ts (f (s, x))
 10.1664 +  | fold_type_constrs _ _ x = x
 10.1665 +
 10.1666 +(* Type constructors used to instantiate overloaded constants are the only ones
 10.1667 +   needed. *)
 10.1668 +fun add_type_constrs_in_term thy =
 10.1669 +  let
 10.1670 +    fun add (Const (@{const_name Meson.skolem}, _) $ _) = I
 10.1671 +      | add (t $ u) = add t #> add u
 10.1672 +      | add (Const x) =
 10.1673 +        x |> robust_const_typargs thy |> fold (fold_type_constrs set_insert)
 10.1674 +      | add (Abs (_, _, u)) = add u
 10.1675 +      | add _ = I
 10.1676 +  in add end
 10.1677 +
 10.1678 +fun type_constrs_of_terms thy ts =
 10.1679 +  Symtab.keys (fold (add_type_constrs_in_term thy) ts Symtab.empty)
 10.1680 +
 10.1681 +fun extract_lambda_def (Const (@{const_name HOL.eq}, _) $ t $ u) =
 10.1682 +    let val (head, args) = strip_comb t in
 10.1683 +      (head |> dest_Const |> fst,
 10.1684 +       fold_rev (fn t as Var ((s, _), T) =>
 10.1685 +                    (fn u => Abs (s, T, abstract_over (t, u)))
 10.1686 +                  | _ => raise Fail "expected Var") args u)
 10.1687 +    end
 10.1688 +  | extract_lambda_def _ = raise Fail "malformed lifted lambda"
 10.1689 +
 10.1690 +fun trans_lams_from_string ctxt type_enc lam_trans =
 10.1691 +  if lam_trans = no_lamsN then
 10.1692 +    rpair []
 10.1693 +  else if lam_trans = hide_lamsN then
 10.1694 +    lift_lams ctxt type_enc ##> K []
 10.1695 +  else if lam_trans = lam_liftingN then
 10.1696 +    lift_lams ctxt type_enc
 10.1697 +  else if lam_trans = combinatorsN then
 10.1698 +    map (introduce_combinators ctxt) #> rpair []
 10.1699 +  else if lam_trans = hybrid_lamsN then
 10.1700 +    lift_lams_part_1 ctxt type_enc
 10.1701 +    ##> maps (fn t => [t, introduce_combinators ctxt (intentionalize_def t)])
 10.1702 +    #> lift_lams_part_2
 10.1703 +  else if lam_trans = keep_lamsN then
 10.1704 +    map (Envir.eta_contract) #> rpair []
 10.1705 +  else
 10.1706 +    error ("Unknown lambda translation scheme: " ^ quote lam_trans ^ ".")
 10.1707 +
 10.1708 +fun translate_formulas ctxt format prem_kind type_enc lam_trans presimp hyp_ts
 10.1709 +                       concl_t facts =
 10.1710 +  let
 10.1711 +    val thy = Proof_Context.theory_of ctxt
 10.1712 +    val trans_lams = trans_lams_from_string ctxt type_enc lam_trans
 10.1713 +    val fact_ts = facts |> map snd
 10.1714 +    (* Remove existing facts from the conjecture, as this can dramatically
 10.1715 +       boost an ATP's performance (for some reason). *)
 10.1716 +    val hyp_ts =
 10.1717 +      hyp_ts
 10.1718 +      |> map (fn t => if member (op aconv) fact_ts t then @{prop True} else t)
 10.1719 +    val facts = facts |> map (apsnd (pair Axiom))
 10.1720 +    val conjs =
 10.1721 +      map (pair prem_kind) hyp_ts @ [(Conjecture, s_not_trueprop concl_t)]
 10.1722 +      |> map (apsnd freeze_term)
 10.1723 +      |> map2 (pair o rpair Local o string_of_int) (0 upto length hyp_ts)
 10.1724 +    val ((conjs, facts), lam_facts) =
 10.1725 +      (conjs, facts)
 10.1726 +      |> presimp ? pairself (map (apsnd (uncurry (presimp_prop ctxt))))
 10.1727 +      |> (if lam_trans = no_lamsN then
 10.1728 +            rpair []
 10.1729 +          else
 10.1730 +            op @
 10.1731 +            #> preprocess_abstractions_in_terms trans_lams
 10.1732 +            #>> chop (length conjs))
 10.1733 +    val conjs = conjs |> make_conjecture ctxt format type_enc
 10.1734 +    val (fact_names, facts) =
 10.1735 +      facts
 10.1736 +      |> map_filter (fn (name, (_, t)) =>
 10.1737 +                        make_fact ctxt format type_enc true (name, t)
 10.1738 +                        |> Option.map (pair name))
 10.1739 +      |> ListPair.unzip
 10.1740 +    val lifted = lam_facts |> map (extract_lambda_def o snd o snd)
 10.1741 +    val lam_facts =
 10.1742 +      lam_facts |> map_filter (make_fact ctxt format type_enc true o apsnd snd)
 10.1743 +    val all_ts = concl_t :: hyp_ts @ fact_ts
 10.1744 +    val subs = tfree_classes_of_terms all_ts
 10.1745 +    val supers = tvar_classes_of_terms all_ts
 10.1746 +    val tycons = type_constrs_of_terms thy all_ts
 10.1747 +    val (supers, arity_clauses) =
 10.1748 +      if level_of_type_enc type_enc = No_Types then ([], [])
 10.1749 +      else make_arity_clauses thy tycons supers
 10.1750 +    val class_rel_clauses = make_class_rel_clauses thy subs supers
 10.1751 +  in
 10.1752 +    (fact_names |> map single, union (op =) subs supers, conjs,
 10.1753 +     facts @ lam_facts, class_rel_clauses, arity_clauses, lifted)
 10.1754 +  end
 10.1755 +
 10.1756 +val type_guard = `(make_fixed_const NONE) type_guard_name
 10.1757 +
 10.1758 +fun type_guard_iterm format type_enc T tm =
 10.1759 +  IApp (IConst (type_guard, T --> @{typ bool}, [T])
 10.1760 +        |> mangle_type_args_in_iterm format type_enc, tm)
 10.1761 +
 10.1762 +fun is_var_positively_naked_in_term _ (SOME false) _ accum = accum
 10.1763 +  | is_var_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum =
 10.1764 +    accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, [])))
 10.1765 +  | is_var_positively_naked_in_term _ _ _ _ = true
 10.1766 +
 10.1767 +fun is_var_ghost_type_arg_in_term thy polym_constrs name pos tm accum =
 10.1768 +  is_var_positively_naked_in_term name pos tm accum orelse
 10.1769 +  let
 10.1770 +    val var = ATerm (name, [])
 10.1771 +    fun is_nasty_in_term (ATerm (_, [])) = false
 10.1772 +      | is_nasty_in_term (ATerm ((s, _), tms)) =
 10.1773 +        let
 10.1774 +          val ary = length tms
 10.1775 +          val polym_constr = member (op =) polym_constrs s
 10.1776 +          val ghosts = ghost_type_args thy s ary
 10.1777 +        in
 10.1778 +          exists (fn (j, tm) =>
 10.1779 +                     if polym_constr then
 10.1780 +                       member (op =) ghosts j andalso
 10.1781 +                       (tm = var orelse is_nasty_in_term tm)
 10.1782 +                     else
 10.1783 +                       tm = var andalso member (op =) ghosts j)
 10.1784 +                 (0 upto ary - 1 ~~ tms)
 10.1785 +          orelse (not polym_constr andalso exists is_nasty_in_term tms)
 10.1786 +        end
 10.1787 +      | is_nasty_in_term _ = true
 10.1788 +  in is_nasty_in_term tm end
 10.1789 +
 10.1790 +fun should_guard_var_in_formula thy polym_constrs level pos phi (SOME true)
 10.1791 +                                name =
 10.1792 +    (case granularity_of_type_level level of
 10.1793 +       All_Vars => true
 10.1794 +     | Positively_Naked_Vars =>
 10.1795 +       formula_fold pos (is_var_positively_naked_in_term name) phi false
 10.1796 +     | Ghost_Type_Arg_Vars =>
 10.1797 +       formula_fold pos (is_var_ghost_type_arg_in_term thy polym_constrs name)
 10.1798 +                    phi false)
 10.1799 +  | should_guard_var_in_formula _ _ _ _ _ _ _ = true
 10.1800 +
 10.1801 +fun always_guard_var_in_formula _ _ _ _ _ _ _ = true
 10.1802 +
 10.1803 +fun should_generate_tag_bound_decl _ _ _ (SOME true) _ = false
 10.1804 +  | should_generate_tag_bound_decl ctxt mono (Tags (_, level)) _ T =
 10.1805 +    granularity_of_type_level level <> All_Vars andalso
 10.1806 +    should_encode_type ctxt mono level T
 10.1807 +  | should_generate_tag_bound_decl _ _ _ _ _ = false
 10.1808 +
 10.1809 +fun mk_aterm format type_enc name T_args args =
 10.1810 +  ATerm (name, map_filter (ho_term_for_type_arg format type_enc) T_args @ args)
 10.1811 +
 10.1812 +fun tag_with_type ctxt format mono type_enc pos T tm =
 10.1813 +  IConst (type_tag, T --> T, [T])
 10.1814 +  |> mangle_type_args_in_iterm format type_enc
 10.1815 +  |> ho_term_from_iterm ctxt format mono type_enc pos
 10.1816 +  |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm])
 10.1817 +       | _ => raise Fail "unexpected lambda-abstraction")
 10.1818 +and ho_term_from_iterm ctxt format mono type_enc =
 10.1819 +  let
 10.1820 +    fun term site u =
 10.1821 +      let
 10.1822 +        val (head, args) = strip_iterm_comb u
 10.1823 +        val pos =
 10.1824 +          case site of
 10.1825 +            Top_Level pos => pos
 10.1826 +          | Eq_Arg pos => pos
 10.1827 +          | _ => NONE
 10.1828 +        val t =
 10.1829 +          case head of
 10.1830 +            IConst (name as (s, _), _, T_args) =>
 10.1831 +            let
 10.1832 +              val arg_site = if is_tptp_equal s then Eq_Arg pos else Elsewhere
 10.1833 +            in
 10.1834 +              map (term arg_site) args |> mk_aterm format type_enc name T_args
 10.1835 +            end
 10.1836 +          | IVar (name, _) =>
 10.1837 +            map (term Elsewhere) args |> mk_aterm format type_enc name []
 10.1838 +          | IAbs ((name, T), tm) =>
 10.1839 +            AAbs ((name, ho_type_from_typ format type_enc true 0 T),
 10.1840 +                  term Elsewhere tm)
 10.1841 +          | IApp _ => raise Fail "impossible \"IApp\""
 10.1842 +        val T = ityp_of u
 10.1843 +      in
 10.1844 +        if should_tag_with_type ctxt mono type_enc site u T then
 10.1845 +          tag_with_type ctxt format mono type_enc pos T t
 10.1846 +        else
 10.1847 +          t
 10.1848 +      end
 10.1849 +  in term o Top_Level end
 10.1850 +and formula_from_iformula ctxt polym_constrs format mono type_enc
 10.1851 +                          should_guard_var =
 10.1852 +  let
 10.1853 +    val thy = Proof_Context.theory_of ctxt
 10.1854 +    val level = level_of_type_enc type_enc
 10.1855 +    val do_term = ho_term_from_iterm ctxt format mono type_enc
 10.1856 +    val do_bound_type =
 10.1857 +      case type_enc of
 10.1858 +        Simple_Types _ => fused_type ctxt mono level 0
 10.1859 +        #> ho_type_from_typ format type_enc false 0 #> SOME
 10.1860 +      | _ => K NONE
 10.1861 +    fun do_out_of_bound_type pos phi universal (name, T) =
 10.1862 +      if should_guard_type ctxt mono type_enc
 10.1863 +             (fn () => should_guard_var thy polym_constrs level pos phi
 10.1864 +                                        universal name) T then
 10.1865 +        IVar (name, T)
 10.1866 +        |> type_guard_iterm format type_enc T
 10.1867 +        |> do_term pos |> AAtom |> SOME
 10.1868 +      else if should_generate_tag_bound_decl ctxt mono type_enc universal T then
 10.1869 +        let
 10.1870 +          val var = ATerm (name, [])
 10.1871 +          val tagged_var = tag_with_type ctxt format mono type_enc pos T var
 10.1872 +        in SOME (AAtom (ATerm (`I tptp_equal, [tagged_var, var]))) end
 10.1873 +      else
 10.1874 +        NONE
 10.1875 +    fun do_formula pos (AQuant (q, xs, phi)) =
 10.1876 +        let
 10.1877 +          val phi = phi |> do_formula pos
 10.1878 +          val universal = Option.map (q = AExists ? not) pos
 10.1879 +        in
 10.1880 +          AQuant (q, xs |> map (apsnd (fn NONE => NONE
 10.1881 +                                        | SOME T => do_bound_type T)),
 10.1882 +                  (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd))
 10.1883 +                      (map_filter
 10.1884 +                           (fn (_, NONE) => NONE
 10.1885 +                             | (s, SOME T) =>
 10.1886 +                               do_out_of_bound_type pos phi universal (s, T))
 10.1887 +                           xs)
 10.1888 +                      phi)
 10.1889 +        end
 10.1890 +      | do_formula pos (AConn conn) = aconn_map pos do_formula conn
 10.1891 +      | do_formula pos (AAtom tm) = AAtom (do_term pos tm)
 10.1892 +  in do_formula end
 10.1893 +
 10.1894 +(* Each fact is given a unique fact number to avoid name clashes (e.g., because
 10.1895 +   of monomorphization). The TPTP explicitly forbids name clashes, and some of
 10.1896 +   the remote provers might care. *)
 10.1897 +fun formula_line_for_fact ctxt polym_constrs format prefix encode freshen pos
 10.1898 +        mono type_enc (j, {name, locality, kind, iformula, atomic_types}) =
 10.1899 +  (prefix ^ (if freshen then string_of_int j ^ "_" else "") ^ encode name, kind,
 10.1900 +   iformula
 10.1901 +   |> formula_from_iformula ctxt polym_constrs format mono type_enc
 10.1902 +          should_guard_var_in_formula (if pos then SOME true else NONE)
 10.1903 +   |> close_formula_universally
 10.1904 +   |> bound_tvars type_enc true atomic_types,
 10.1905 +   NONE,
 10.1906 +   case locality of
 10.1907 +     Intro => isabelle_info format introN
 10.1908 +   | Elim => isabelle_info format elimN
 10.1909 +   | Simp => isabelle_info format simpN
 10.1910 +   | _ => NONE)
 10.1911 +  |> Formula
 10.1912 +
 10.1913 +fun formula_line_for_class_rel_clause format type_enc
 10.1914 +        ({name, subclass, superclass, ...} : class_rel_clause) =
 10.1915 +  let val ty_arg = ATerm (tvar_a_name, []) in
 10.1916 +    Formula (class_rel_clause_prefix ^ ascii_of name, Axiom,
 10.1917 +             AConn (AImplies,
 10.1918 +                    [type_class_formula type_enc subclass ty_arg,
 10.1919 +                     type_class_formula type_enc superclass ty_arg])
 10.1920 +             |> mk_aquant AForall
 10.1921 +                          [(tvar_a_name, atype_of_type_vars type_enc)],
 10.1922 +             isabelle_info format introN, NONE)
 10.1923 +  end
 10.1924 +
 10.1925 +fun formula_from_arity_atom type_enc (class, t, args) =
 10.1926 +  ATerm (t, map (fn arg => ATerm (arg, [])) args)
 10.1927 +  |> type_class_formula type_enc class
 10.1928 +
 10.1929 +fun formula_line_for_arity_clause format type_enc
 10.1930 +        ({name, prem_atoms, concl_atom} : arity_clause) =
 10.1931 +  Formula (arity_clause_prefix ^ name, Axiom,
 10.1932 +           mk_ahorn (map (formula_from_arity_atom type_enc) prem_atoms)
 10.1933 +                    (formula_from_arity_atom type_enc concl_atom)
 10.1934 +           |> mk_aquant AForall
 10.1935 +                  (map (rpair (atype_of_type_vars type_enc)) (#3 concl_atom)),
 10.1936 +           isabelle_info format introN, NONE)
 10.1937 +
 10.1938 +fun formula_line_for_conjecture ctxt polym_constrs format mono type_enc
 10.1939 +        ({name, kind, iformula, atomic_types, ...} : translated_formula) =
 10.1940 +  Formula (conjecture_prefix ^ name, kind,
 10.1941 +           iformula
 10.1942 +           |> formula_from_iformula ctxt polym_constrs format mono type_enc
 10.1943 +                  should_guard_var_in_formula (SOME false)
 10.1944 +           |> close_formula_universally
 10.1945 +           |> bound_tvars type_enc true atomic_types, NONE, NONE)
 10.1946 +
 10.1947 +fun formula_line_for_free_type j phi =
 10.1948 +  Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, phi, NONE, NONE)
 10.1949 +fun formula_lines_for_free_types type_enc (facts : translated_formula list) =
 10.1950 +  let
 10.1951 +    val phis =
 10.1952 +      fold (union (op =)) (map #atomic_types facts) []
 10.1953 +      |> formulas_for_types type_enc add_sorts_on_tfree
 10.1954 +  in map2 formula_line_for_free_type (0 upto length phis - 1) phis end
 10.1955 +
 10.1956 +(** Symbol declarations **)
 10.1957 +
 10.1958 +fun decl_line_for_class order s =
 10.1959 +  let val name as (s, _) = `make_type_class s in
 10.1960 +    Decl (sym_decl_prefix ^ s, name,
 10.1961 +          if order = First_Order then
 10.1962 +            ATyAbs ([tvar_a_name],
 10.1963 +                    if avoid_first_order_ghost_type_vars then
 10.1964 +                      AFun (a_itself_atype, bool_atype)
 10.1965 +                    else
 10.1966 +                      bool_atype)
 10.1967 +          else
 10.1968 +            AFun (atype_of_types, bool_atype))
 10.1969 +  end
 10.1970 +
 10.1971 +fun decl_lines_for_classes type_enc classes =
 10.1972 +  case type_enc of
 10.1973 +    Simple_Types (order, Polymorphic, _) =>
 10.1974 +    map (decl_line_for_class order) classes
 10.1975 +  | _ => []
 10.1976 +
 10.1977 +fun sym_decl_table_for_facts ctxt format type_enc sym_tab (conjs, facts) =
 10.1978 +  let
 10.1979 +    fun add_iterm_syms tm =
 10.1980 +      let val (head, args) = strip_iterm_comb tm in
 10.1981 +        (case head of
 10.1982 +           IConst ((s, s'), T, T_args) =>
 10.1983 +           let
 10.1984 +             val (pred_sym, in_conj) =
 10.1985 +               case Symtab.lookup sym_tab s of
 10.1986 +                 SOME ({pred_sym, in_conj, ...} : sym_info) =>
 10.1987 +                 (pred_sym, in_conj)
 10.1988 +               | NONE => (false, false)
 10.1989 +             val decl_sym =
 10.1990 +               (case type_enc of
 10.1991 +                  Guards _ => not pred_sym
 10.1992 +                | _ => true) andalso
 10.1993 +               is_tptp_user_symbol s
 10.1994 +           in
 10.1995 +             if decl_sym then
 10.1996 +               Symtab.map_default (s, [])
 10.1997 +                   (insert_type ctxt #3 (s', T_args, T, pred_sym, length args,
 10.1998 +                                         in_conj))
 10.1999 +             else
 10.2000 +               I
 10.2001 +           end
 10.2002 +         | IAbs (_, tm) => add_iterm_syms tm
 10.2003 +         | _ => I)
 10.2004 +        #> fold add_iterm_syms args
 10.2005 +      end
 10.2006 +    val add_fact_syms = K add_iterm_syms |> formula_fold NONE |> fact_lift
 10.2007 +    fun add_formula_var_types (AQuant (_, xs, phi)) =
 10.2008 +        fold (fn (_, SOME T) => insert_type ctxt I T | _ => I) xs
 10.2009 +        #> add_formula_var_types phi
 10.2010 +      | add_formula_var_types (AConn (_, phis)) =
 10.2011 +        fold add_formula_var_types phis
 10.2012 +      | add_formula_var_types _ = I
 10.2013 +    fun var_types () =
 10.2014 +      if polymorphism_of_type_enc type_enc = Polymorphic then [tvar_a]
 10.2015 +      else fold (fact_lift add_formula_var_types) (conjs @ facts) []
 10.2016 +    fun add_undefined_const T =
 10.2017 +      let
 10.2018 +        val (s, s') =
 10.2019 +          `(make_fixed_const NONE) @{const_name undefined}
 10.2020 +          |> (case type_arg_policy [] type_enc @{const_name undefined} of
 10.2021 +                Mangled_Type_Args => mangled_const_name format type_enc [T]
 10.2022 +              | _ => I)
 10.2023 +      in
 10.2024 +        Symtab.map_default (s, [])
 10.2025 +                           (insert_type ctxt #3 (s', [T], T, false, 0, false))
 10.2026 +      end
 10.2027 +    fun add_TYPE_const () =
 10.2028 +      let val (s, s') = TYPE_name in
 10.2029 +        Symtab.map_default (s, [])
 10.2030 +            (insert_type ctxt #3
 10.2031 +                         (s', [tvar_a], @{typ "'a itself"}, false, 0, false))
 10.2032 +      end
 10.2033 +  in
 10.2034 +    Symtab.empty
 10.2035 +    |> is_type_enc_fairly_sound type_enc
 10.2036 +       ? (fold (fold add_fact_syms) [conjs, facts]
 10.2037 +          #> (case type_enc of
 10.2038 +                Simple_Types (First_Order, Polymorphic, _) =>
 10.2039 +                if avoid_first_order_ghost_type_vars then add_TYPE_const ()
 10.2040 +                else I
 10.2041 +              | Simple_Types _ => I
 10.2042 +              | _ => fold add_undefined_const (var_types ())))
 10.2043 +  end
 10.2044 +
 10.2045 +(* We add "bool" in case the helper "True_or_False" is included later. *)
 10.2046 +fun default_mono level =
 10.2047 +  {maybe_finite_Ts = [@{typ bool}],
 10.2048 +   surely_finite_Ts = [@{typ bool}],
 10.2049 +   maybe_infinite_Ts = known_infinite_types,
 10.2050 +   surely_infinite_Ts =
 10.2051 +     case level of
 10.2052 +       Noninf_Nonmono_Types (Strict, _) => []
 10.2053 +     | _ => known_infinite_types,
 10.2054 +   maybe_nonmono_Ts = [@{typ bool}]}
 10.2055 +
 10.2056 +(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it
 10.2057 +   out with monotonicity" paper presented at CADE 2011. *)
 10.2058 +fun add_iterm_mononotonicity_info _ _ (SOME false) _ mono = mono
 10.2059 +  | add_iterm_mononotonicity_info ctxt level _
 10.2060 +        (IApp (IApp (IConst ((s, _), Type (_, [T, _]), _), tm1), tm2))
 10.2061 +        (mono as {maybe_finite_Ts, surely_finite_Ts, maybe_infinite_Ts,
 10.2062 +                  surely_infinite_Ts, maybe_nonmono_Ts}) =
 10.2063 +    if is_tptp_equal s andalso exists is_maybe_universal_var [tm1, tm2] then
 10.2064 +      case level of
 10.2065 +        Noninf_Nonmono_Types (strictness, _) =>
 10.2066 +        if exists (type_instance ctxt T) surely_infinite_Ts orelse
 10.2067 +           member (type_equiv ctxt) maybe_finite_Ts T then
 10.2068 +          mono
 10.2069 +        else if is_type_kind_of_surely_infinite ctxt strictness
 10.2070 +                                                surely_infinite_Ts T then
 10.2071 +          {maybe_finite_Ts = maybe_finite_Ts,
 10.2072 +           surely_finite_Ts = surely_finite_Ts,
 10.2073 +           maybe_infinite_Ts = maybe_infinite_Ts,
 10.2074 +           surely_infinite_Ts = surely_infinite_Ts |> insert_type ctxt I T,
 10.2075 +           maybe_nonmono_Ts = maybe_nonmono_Ts}
 10.2076 +        else
 10.2077 +          {maybe_finite_Ts = maybe_finite_Ts |> insert (type_equiv ctxt) T,
 10.2078 +           surely_finite_Ts = surely_finite_Ts,
 10.2079 +           maybe_infinite_Ts = maybe_infinite_Ts,
 10.2080 +           surely_infinite_Ts = surely_infinite_Ts,
 10.2081 +           maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T}
 10.2082 +      | Fin_Nonmono_Types _ =>
 10.2083 +        if exists (type_instance ctxt T) surely_finite_Ts orelse
 10.2084 +           member (type_equiv ctxt) maybe_infinite_Ts T then
 10.2085 +          mono
 10.2086 +        else if is_type_surely_finite ctxt T then
 10.2087 +          {maybe_finite_Ts = maybe_finite_Ts,
 10.2088 +           surely_finite_Ts = surely_finite_Ts |> insert_type ctxt I T,
 10.2089 +           maybe_infinite_Ts = maybe_infinite_Ts,
 10.2090 +           surely_infinite_Ts = surely_infinite_Ts,
 10.2091 +           maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T}
 10.2092 +        else
 10.2093 +          {maybe_finite_Ts = maybe_finite_Ts,
 10.2094 +           surely_finite_Ts = surely_finite_Ts,
 10.2095 +           maybe_infinite_Ts = maybe_infinite_Ts |> insert (type_equiv ctxt) T,
 10.2096 +           surely_infinite_Ts = surely_infinite_Ts,
 10.2097 +           maybe_nonmono_Ts = maybe_nonmono_Ts}
 10.2098 +      | _ => mono
 10.2099 +    else
 10.2100 +      mono
 10.2101 +  | add_iterm_mononotonicity_info _ _ _ _ mono = mono
 10.2102 +fun add_fact_mononotonicity_info ctxt level
 10.2103 +        ({kind, iformula, ...} : translated_formula) =
 10.2104 +  formula_fold (SOME (kind <> Conjecture))
 10.2105 +               (add_iterm_mononotonicity_info ctxt level) iformula
 10.2106 +fun mononotonicity_info_for_facts ctxt type_enc facts =
 10.2107 +  let val level = level_of_type_enc type_enc in
 10.2108 +    default_mono level
 10.2109 +    |> is_type_level_monotonicity_based level
 10.2110 +       ? fold (add_fact_mononotonicity_info ctxt level) facts
 10.2111 +  end
 10.2112 +
 10.2113 +fun add_iformula_monotonic_types ctxt mono type_enc =
 10.2114 +  let
 10.2115 +    val level = level_of_type_enc type_enc
 10.2116 +    val should_encode = should_encode_type ctxt mono level
 10.2117 +    fun add_type T = not (should_encode T) ? insert_type ctxt I T
 10.2118 +    fun add_args (IApp (tm1, tm2)) = add_args tm1 #> add_term tm2
 10.2119 +      | add_args _ = I
 10.2120 +    and add_term tm = add_type (ityp_of tm) #> add_args tm
 10.2121 +  in formula_fold NONE (K add_term) end
 10.2122 +fun add_fact_monotonic_types ctxt mono type_enc =
 10.2123 +  add_iformula_monotonic_types ctxt mono type_enc |> fact_lift
 10.2124 +fun monotonic_types_for_facts ctxt mono type_enc facts =
 10.2125 +  let val level = level_of_type_enc type_enc in
 10.2126 +    [] |> (polymorphism_of_type_enc type_enc = Polymorphic andalso
 10.2127 +           is_type_level_monotonicity_based level andalso
 10.2128 +           granularity_of_type_level level <> Ghost_Type_Arg_Vars)
 10.2129 +          ? fold (add_fact_monotonic_types ctxt mono type_enc) facts
 10.2130 +  end
 10.2131 +
 10.2132 +fun formula_line_for_guards_mono_type ctxt format mono type_enc T =
 10.2133 +  Formula (guards_sym_formula_prefix ^
 10.2134 +           ascii_of (mangled_type format type_enc T),
 10.2135 +           Axiom,
 10.2136 +           IConst (`make_bound_var "X", T, [])
 10.2137 +           |> type_guard_iterm format type_enc T
 10.2138 +           |> AAtom
 10.2139 +           |> formula_from_iformula ctxt [] format mono type_enc
 10.2140 +                                    always_guard_var_in_formula (SOME true)
 10.2141 +           |> close_formula_universally
 10.2142 +           |> bound_tvars type_enc true (atomic_types_of T),
 10.2143 +           isabelle_info format introN, NONE)
 10.2144 +
 10.2145 +fun formula_line_for_tags_mono_type ctxt format mono type_enc T =
 10.2146 +  let val x_var = ATerm (`make_bound_var "X", []) in
 10.2147 +    Formula (tags_sym_formula_prefix ^
 10.2148 +             ascii_of (mangled_type format type_enc T),
 10.2149 +             Axiom,
 10.2150 +             eq_formula type_enc (atomic_types_of T) false
 10.2151 +                  (tag_with_type ctxt format mono type_enc NONE T x_var) x_var,
 10.2152 +             isabelle_info format simpN, NONE)
 10.2153 +  end
 10.2154 +
 10.2155 +fun problem_lines_for_mono_types ctxt format mono type_enc Ts =
 10.2156 +  case type_enc of
 10.2157 +    Simple_Types _ => []
 10.2158 +  | Guards _ =>
 10.2159 +    map (formula_line_for_guards_mono_type ctxt format mono type_enc) Ts
 10.2160 +  | Tags _ => map (formula_line_for_tags_mono_type ctxt format mono type_enc) Ts
 10.2161 +
 10.2162 +fun decl_line_for_sym ctxt format mono type_enc s
 10.2163 +                      (s', T_args, T, pred_sym, ary, _) =
 10.2164 +  let
 10.2165 +    val thy = Proof_Context.theory_of ctxt
 10.2166 +    val (T, T_args) =
 10.2167 +      if null T_args then
 10.2168 +        (T, [])
 10.2169 +      else case unprefix_and_unascii const_prefix s of
 10.2170 +        SOME s' =>
 10.2171 +        let
 10.2172 +          val s' = s' |> invert_const
 10.2173 +          val T = s' |> robust_const_type thy
 10.2174 +        in (T, robust_const_typargs thy (s', T)) end
 10.2175 +      | NONE => raise Fail "unexpected type arguments"
 10.2176 +  in
 10.2177 +    Decl (sym_decl_prefix ^ s, (s, s'),
 10.2178 +          T |> fused_type ctxt mono (level_of_type_enc type_enc) ary
 10.2179 +            |> ho_type_from_typ format type_enc pred_sym ary
 10.2180 +            |> not (null T_args)
 10.2181 +               ? curry ATyAbs (map (tvar_name o fst o dest_TVar) T_args))
 10.2182 +  end
 10.2183 +
 10.2184 +fun formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono type_enc n s
 10.2185 +                                     j (s', T_args, T, _, ary, in_conj) =
 10.2186 +  let
 10.2187 +    val thy = Proof_Context.theory_of ctxt
 10.2188 +    val (kind, maybe_negate) =
 10.2189 +      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 10.2190 +      else (Axiom, I)
 10.2191 +    val (arg_Ts, res_T) = chop_fun ary T
 10.2192 +    val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int)
 10.2193 +    val bounds =
 10.2194 +      bound_names ~~ arg_Ts |> map (fn (name, T) => IConst (name, T, []))
 10.2195 +    val bound_Ts =
 10.2196 +      if exists (curry (op =) dummyT) T_args then
 10.2197 +        case level_of_type_enc type_enc of
 10.2198 +          All_Types => map SOME arg_Ts
 10.2199 +        | level =>
 10.2200 +          if granularity_of_type_level level = Ghost_Type_Arg_Vars then
 10.2201 +            let val ghosts = ghost_type_args thy s ary in
 10.2202 +              map2 (fn j => if member (op =) ghosts j then SOME else K NONE)
 10.2203 +                   (0 upto ary - 1) arg_Ts
 10.2204 +            end
 10.2205 +          else
 10.2206 +            replicate ary NONE
 10.2207 +      else
 10.2208 +        replicate ary NONE
 10.2209 +  in
 10.2210 +    Formula (guards_sym_formula_prefix ^ s ^
 10.2211 +             (if n > 1 then "_" ^ string_of_int j else ""), kind,
 10.2212 +             IConst ((s, s'), T, T_args)
 10.2213 +             |> fold (curry (IApp o swap)) bounds
 10.2214 +             |> type_guard_iterm format type_enc res_T
 10.2215 +             |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts)
 10.2216 +             |> formula_from_iformula ctxt [] format mono type_enc
 10.2217 +                                      always_guard_var_in_formula (SOME true)
 10.2218 +             |> close_formula_universally
 10.2219 +             |> bound_tvars type_enc (n > 1) (atomic_types_of T)
 10.2220 +             |> maybe_negate,
 10.2221 +             isabelle_info format introN, NONE)
 10.2222 +  end
 10.2223 +
 10.2224 +fun formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono type_enc n s
 10.2225 +        (j, (s', T_args, T, pred_sym, ary, in_conj)) =
 10.2226 +  let
 10.2227 +    val thy = Proof_Context.theory_of ctxt
 10.2228 +    val level = level_of_type_enc type_enc
 10.2229 +    val grain = granularity_of_type_level level
 10.2230 +    val ident_base =
 10.2231 +      tags_sym_formula_prefix ^ s ^
 10.2232 +      (if n > 1 then "_" ^ string_of_int j else "")
 10.2233 +    val (kind, maybe_negate) =
 10.2234 +      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 10.2235 +      else (Axiom, I)
 10.2236 +    val (arg_Ts, res_T) = chop_fun ary T
 10.2237 +    val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int)
 10.2238 +    val bounds = bound_names |> map (fn name => ATerm (name, []))
 10.2239 +    val cst = mk_aterm format type_enc (s, s') T_args
 10.2240 +    val eq = maybe_negate oo eq_formula type_enc (atomic_types_of T) pred_sym
 10.2241 +    val should_encode = should_encode_type ctxt mono level
 10.2242 +    val tag_with = tag_with_type ctxt format mono type_enc NONE
 10.2243 +    val add_formula_for_res =
 10.2244 +      if should_encode res_T then
 10.2245 +        let
 10.2246 +          val tagged_bounds =
 10.2247 +            if grain = Ghost_Type_Arg_Vars then
 10.2248 +              let val ghosts = ghost_type_args thy s ary in
 10.2249 +                map2 (fn (j, arg_T) => member (op =) ghosts j ? tag_with arg_T)
 10.2250 +                     (0 upto ary - 1 ~~ arg_Ts) bounds
 10.2251 +              end
 10.2252 +            else
 10.2253 +              bounds
 10.2254 +        in
 10.2255 +          cons (Formula (ident_base ^ "_res", kind,
 10.2256 +                         eq (tag_with res_T (cst bounds)) (cst tagged_bounds),
 10.2257 +                         isabelle_info format simpN, NONE))
 10.2258 +        end
 10.2259 +      else
 10.2260 +        I
 10.2261 +    fun add_formula_for_arg k =
 10.2262 +      let val arg_T = nth arg_Ts k in
 10.2263 +        if should_encode arg_T then
 10.2264 +          case chop k bounds of
 10.2265 +            (bounds1, bound :: bounds2) =>
 10.2266 +            cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind,
 10.2267 +                           eq (cst (bounds1 @ tag_with arg_T bound :: bounds2))
 10.2268 +                              (cst bounds),
 10.2269 +                           isabelle_info format simpN, NONE))
 10.2270 +          | _ => raise Fail "expected nonempty tail"
 10.2271 +        else
 10.2272 +          I
 10.2273 +      end
 10.2274 +  in
 10.2275 +    [] |> not pred_sym ? add_formula_for_res
 10.2276 +       |> (Config.get ctxt type_tag_arguments andalso
 10.2277 +           grain = Positively_Naked_Vars)
 10.2278 +          ? fold add_formula_for_arg (ary - 1 downto 0)
 10.2279 +  end
 10.2280 +
 10.2281 +fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
 10.2282 +
 10.2283 +fun rationalize_decls ctxt (decls as decl :: (decls' as _ :: _)) =
 10.2284 +    let
 10.2285 +      val T = result_type_of_decl decl
 10.2286 +              |> map_type_tvar (fn (z, _) => TVar (z, HOLogic.typeS))
 10.2287 +    in
 10.2288 +      if forall (type_generalization ctxt T o result_type_of_decl) decls' then
 10.2289 +        [decl]
 10.2290 +      else
 10.2291 +        decls
 10.2292 +    end
 10.2293 +  | rationalize_decls _ decls = decls
 10.2294 +
 10.2295 +fun problem_lines_for_sym_decls ctxt format conj_sym_kind mono type_enc
 10.2296 +                                (s, decls) =
 10.2297 +  case type_enc of
 10.2298 +    Simple_Types _ => [decl_line_for_sym ctxt format mono type_enc s (hd decls)]
 10.2299 +  | Guards (_, level) =>
 10.2300 +    let
 10.2301 +      val decls = decls |> rationalize_decls ctxt
 10.2302 +      val n = length decls
 10.2303 +      val decls =
 10.2304 +        decls |> filter (should_encode_type ctxt mono level
 10.2305 +                         o result_type_of_decl)
 10.2306 +    in
 10.2307 +      (0 upto length decls - 1, decls)
 10.2308 +      |-> map2 (formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono
 10.2309 +                                                 type_enc n s)
 10.2310 +    end
 10.2311 +  | Tags (_, level) =>
 10.2312 +    if granularity_of_type_level level = All_Vars then
 10.2313 +      []
 10.2314 +    else
 10.2315 +      let val n = length decls in
 10.2316 +        (0 upto n - 1 ~~ decls)
 10.2317 +        |> maps (formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono
 10.2318 +                                                 type_enc n s)
 10.2319 +      end
 10.2320 +
 10.2321 +fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono type_enc
 10.2322 +                                     mono_Ts sym_decl_tab =
 10.2323 +  let
 10.2324 +    val syms = sym_decl_tab |> Symtab.dest |> sort_wrt fst
 10.2325 +    val mono_lines =
 10.2326 +      problem_lines_for_mono_types ctxt format mono type_enc mono_Ts
 10.2327 +    val decl_lines =
 10.2328 +      fold_rev (append o problem_lines_for_sym_decls ctxt format conj_sym_kind
 10.2329 +                             mono type_enc)
 10.2330 +               syms []
 10.2331 +  in mono_lines @ decl_lines end
 10.2332 +
 10.2333 +fun needs_type_tag_idempotence ctxt (Tags (poly, level)) =
 10.2334 +    Config.get ctxt type_tag_idempotence andalso
 10.2335 +    is_type_level_monotonicity_based level andalso
 10.2336 +    poly <> Mangled_Monomorphic
 10.2337 +  | needs_type_tag_idempotence _ _ = false
 10.2338 +
 10.2339 +val implicit_declsN = "Should-be-implicit typings"
 10.2340 +val explicit_declsN = "Explicit typings"
 10.2341 +val factsN = "Relevant facts"
 10.2342 +val class_relsN = "Class relationships"
 10.2343 +val aritiesN = "Arities"
 10.2344 +val helpersN = "Helper facts"
 10.2345 +val conjsN = "Conjectures"
 10.2346 +val free_typesN = "Type variables"
 10.2347 +
 10.2348 +(* TFF allows implicit declarations of types, function symbols, and predicate
 10.2349 +   symbols (with "$i" as the type of individuals), but some provers (e.g.,
 10.2350 +   SNARK) require explicit declarations. The situation is similar for THF. *)
 10.2351 +
 10.2352 +fun default_type type_enc pred_sym s =
 10.2353 +  let
 10.2354 +    val ind =
 10.2355 +      case type_enc of
 10.2356 +        Simple_Types _ =>
 10.2357 +        if String.isPrefix type_const_prefix s then atype_of_types
 10.2358 +        else individual_atype
 10.2359 +      | _ => individual_atype
 10.2360 +    fun typ 0 = if pred_sym then bool_atype else ind
 10.2361 +      | typ ary = AFun (ind, typ (ary - 1))
 10.2362 +  in typ end
 10.2363 +
 10.2364 +fun nary_type_constr_type n =
 10.2365 +  funpow n (curry AFun atype_of_types) atype_of_types
 10.2366 +
 10.2367 +fun undeclared_syms_in_problem type_enc problem =
 10.2368 +  let
 10.2369 +    val declared = declared_syms_in_problem problem
 10.2370 +    fun do_sym name ty =
 10.2371 +      if member (op =) declared name then I else AList.default (op =) (name, ty)
 10.2372 +    fun do_type (AType (name as (s, _), tys)) =
 10.2373 +        is_tptp_user_symbol s
 10.2374 +        ? do_sym name (fn () => nary_type_constr_type (length tys))
 10.2375 +        #> fold do_type tys
 10.2376 +      | do_type (AFun (ty1, ty2)) = do_type ty1 #> do_type ty2
 10.2377 +      | do_type (ATyAbs (_, ty)) = do_type ty
 10.2378 +    fun do_term pred_sym (ATerm (name as (s, _), tms)) =
 10.2379 +        is_tptp_user_symbol s
 10.2380 +        ? do_sym name (fn _ => default_type type_enc pred_sym s (length tms))
 10.2381 +        #> fold (do_term false) tms
 10.2382 +      | do_term _ (AAbs ((_, ty), tm)) = do_type ty #> do_term false tm
 10.2383 +    fun do_formula (AQuant (_, xs, phi)) =
 10.2384 +        fold do_type (map_filter snd xs) #> do_formula phi
 10.2385 +      | do_formula (AConn (_, phis)) = fold do_formula phis
 10.2386 +      | do_formula (AAtom tm) = do_term true tm
 10.2387 +    fun do_problem_line (Decl (_, _, ty)) = do_type ty
 10.2388 +      | do_problem_line (Formula (_, _, phi, _, _)) = do_formula phi
 10.2389 +  in
 10.2390 +    fold (fold do_problem_line o snd) problem []
 10.2391 +    |> filter_out (is_built_in_tptp_symbol o fst o fst)
 10.2392 +  end
 10.2393 +
 10.2394 +fun declare_undeclared_syms_in_atp_problem type_enc problem =
 10.2395 +  let
 10.2396 +    val decls =
 10.2397 +      problem
 10.2398 +      |> undeclared_syms_in_problem type_enc
 10.2399 +      |> sort_wrt (fst o fst)
 10.2400 +      |> map (fn (x as (s, _), ty) => Decl (type_decl_prefix ^ s, x, ty ()))
 10.2401 +  in (implicit_declsN, decls) :: problem end
 10.2402 +
 10.2403 +fun exists_subdtype P =
 10.2404 +  let
 10.2405 +    fun ex U = P U orelse
 10.2406 +      (case U of Datatype.DtType (_, Us) => exists ex Us | _ => false)
 10.2407 +  in ex end
 10.2408 +
 10.2409 +fun is_poly_constr (_, Us) =
 10.2410 +  exists (exists_subdtype (fn Datatype.DtTFree _ => true | _ => false)) Us
 10.2411 +
 10.2412 +fun all_constrs_of_polymorphic_datatypes thy =
 10.2413 +  Symtab.fold (snd
 10.2414 +               #> #descr
 10.2415 +               #> maps (snd #> #3)
 10.2416 +               #> (fn cs => exists is_poly_constr cs ? append cs))
 10.2417 +              (Datatype.get_all thy) []
 10.2418 +  |> List.partition is_poly_constr
 10.2419 +  |> pairself (map fst)
 10.2420 +
 10.2421 +(* Forcing explicit applications is expensive for polymorphic encodings, because
 10.2422 +   it takes only one existential variable ranging over "'a => 'b" to ruin
 10.2423 +   everything. Hence we do it only if there are few facts (is normally the case
 10.2424 +   for "metis" and the minimizer. *)
 10.2425 +val explicit_apply_threshold = 50
 10.2426 +
 10.2427 +fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_enc exporter
 10.2428 +                        lam_trans readable_names preproc hyp_ts concl_t facts =
 10.2429 +  let
 10.2430 +    val thy = Proof_Context.theory_of ctxt
 10.2431 +    val type_enc = type_enc |> adjust_type_enc format
 10.2432 +    val explicit_apply =
 10.2433 +      if polymorphism_of_type_enc type_enc <> Polymorphic orelse
 10.2434 +         length facts <= explicit_apply_threshold then
 10.2435 +        NONE
 10.2436 +      else
 10.2437 +        SOME false
 10.2438 +    val lam_trans =
 10.2439 +      if lam_trans = keep_lamsN andalso
 10.2440 +         not (is_type_enc_higher_order type_enc) then
 10.2441 +        error ("Lambda translation scheme incompatible with first-order \
 10.2442 +               \encoding.")
 10.2443 +      else
 10.2444 +        lam_trans
 10.2445 +    val (fact_names, classes, conjs, facts, class_rel_clauses, arity_clauses,
 10.2446 +         lifted) =
 10.2447 +      translate_formulas ctxt format prem_kind type_enc lam_trans preproc hyp_ts
 10.2448 +                         concl_t facts
 10.2449 +    val sym_tab = sym_table_for_facts ctxt type_enc explicit_apply conjs facts
 10.2450 +    val mono = conjs @ facts |> mononotonicity_info_for_facts ctxt type_enc
 10.2451 +    val (polym_constrs, monom_constrs) =
 10.2452 +      all_constrs_of_polymorphic_datatypes thy
 10.2453 +      |>> map (make_fixed_const (SOME format))
 10.2454 +    val firstorderize =
 10.2455 +      firstorderize_fact thy monom_constrs format type_enc sym_tab
 10.2456 +    val (conjs, facts) = (conjs, facts) |> pairself (map firstorderize)
 10.2457 +    val sym_tab = sym_table_for_facts ctxt type_enc (SOME false) conjs facts
 10.2458 +    val helpers =
 10.2459 +      sym_tab |> helper_facts_for_sym_table ctxt format type_enc
 10.2460 +              |> map firstorderize
 10.2461 +    val mono_Ts =
 10.2462 +      helpers @ conjs @ facts |> monotonic_types_for_facts ctxt mono type_enc
 10.2463 +    val class_decl_lines = decl_lines_for_classes type_enc classes
 10.2464 +    val sym_decl_lines =
 10.2465 +      (conjs, helpers @ facts)
 10.2466 +      |> sym_decl_table_for_facts ctxt format type_enc sym_tab
 10.2467 +      |> problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono
 10.2468 +                                               type_enc mono_Ts
 10.2469 +    val helper_lines =
 10.2470 +      0 upto length helpers - 1 ~~ helpers
 10.2471 +      |> map (formula_line_for_fact ctxt polym_constrs format helper_prefix I
 10.2472 +                                    false true mono type_enc)
 10.2473 +      |> (if needs_type_tag_idempotence ctxt type_enc then
 10.2474 +            cons (type_tag_idempotence_fact format type_enc)
 10.2475 +          else
 10.2476 +            I)
 10.2477 +    (* Reordering these might confuse the proof reconstruction code or the SPASS
 10.2478 +       FLOTTER hack. *)
 10.2479 +    val problem =
 10.2480 +      [(explicit_declsN, class_decl_lines @ sym_decl_lines),
 10.2481 +       (factsN,
 10.2482 +        map (formula_line_for_fact ctxt polym_constrs format fact_prefix
 10.2483 +                 ascii_of (not exporter) (not exporter) mono type_enc)
 10.2484 +            (0 upto length facts - 1 ~~ facts)),
 10.2485 +       (class_relsN,
 10.2486 +        map (formula_line_for_class_rel_clause format type_enc)
 10.2487 +            class_rel_clauses),
 10.2488 +       (aritiesN,
 10.2489 +        map (formula_line_for_arity_clause format type_enc) arity_clauses),
 10.2490 +       (helpersN, helper_lines),
 10.2491 +       (conjsN,
 10.2492 +        map (formula_line_for_conjecture ctxt polym_constrs format mono
 10.2493 +                                         type_enc) conjs),
 10.2494 +       (free_typesN, formula_lines_for_free_types type_enc (facts @ conjs))]
 10.2495 +    val problem =
 10.2496 +      problem
 10.2497 +      |> (case format of
 10.2498 +            CNF => ensure_cnf_problem
 10.2499 +          | CNF_UEQ => filter_cnf_ueq_problem
 10.2500 +          | FOF => I
 10.2501 +          | TFF (_, TPTP_Implicit) => I
 10.2502 +          | THF (_, TPTP_Implicit, _) => I
 10.2503 +          | _ => declare_undeclared_syms_in_atp_problem type_enc)
 10.2504 +    val (problem, pool) = problem |> nice_atp_problem readable_names format
 10.2505 +    fun add_sym_ary (s, {min_ary, ...} : sym_info) =
 10.2506 +      min_ary > 0 ? Symtab.insert (op =) (s, min_ary)
 10.2507 +  in
 10.2508 +    (problem,
 10.2509 +     case pool of SOME the_pool => snd the_pool | NONE => Symtab.empty,
 10.2510 +     fact_names |> Vector.fromList,
 10.2511 +     lifted,
 10.2512 +     Symtab.empty |> Symtab.fold add_sym_ary sym_tab)
 10.2513 +  end
 10.2514 +
 10.2515 +(* FUDGE *)
 10.2516 +val conj_weight = 0.0
 10.2517 +val hyp_weight = 0.1
 10.2518 +val fact_min_weight = 0.2
 10.2519 +val fact_max_weight = 1.0
 10.2520 +val type_info_default_weight = 0.8
 10.2521 +
 10.2522 +fun add_term_weights weight (ATerm (s, tms)) =
 10.2523 +    is_tptp_user_symbol s ? Symtab.default (s, weight)
 10.2524 +    #> fold (add_term_weights weight) tms
 10.2525 +  | add_term_weights weight (AAbs (_, tm)) = add_term_weights weight tm
 10.2526 +fun add_problem_line_weights weight (Formula (_, _, phi, _, _)) =
 10.2527 +    formula_fold NONE (K (add_term_weights weight)) phi
 10.2528 +  | add_problem_line_weights _ _ = I
 10.2529 +
 10.2530 +fun add_conjectures_weights [] = I
 10.2531 +  | add_conjectures_weights conjs =
 10.2532 +    let val (hyps, conj) = split_last conjs in
 10.2533 +      add_problem_line_weights conj_weight conj
 10.2534 +      #> fold (add_problem_line_weights hyp_weight) hyps
 10.2535 +    end
 10.2536 +
 10.2537 +fun add_facts_weights facts =
 10.2538 +  let
 10.2539 +    val num_facts = length facts
 10.2540 +    fun weight_of j =
 10.2541 +      fact_min_weight + (fact_max_weight - fact_min_weight) * Real.fromInt j
 10.2542 +                        / Real.fromInt num_facts
 10.2543 +  in
 10.2544 +    map weight_of (0 upto num_facts - 1) ~~ facts
 10.2545 +    |> fold (uncurry add_problem_line_weights)
 10.2546 +  end
 10.2547 +
 10.2548 +(* Weights are from 0.0 (most important) to 1.0 (least important). *)
 10.2549 +fun atp_problem_weights problem =
 10.2550 +  let val get = these o AList.lookup (op =) problem in
 10.2551 +    Symtab.empty
 10.2552 +    |> add_conjectures_weights (get free_typesN @ get conjsN)
 10.2553 +    |> add_facts_weights (get factsN)
 10.2554 +    |> fold (fold (add_problem_line_weights type_info_default_weight) o get)
 10.2555 +            [explicit_declsN, class_relsN, aritiesN]
 10.2556 +    |> Symtab.dest
 10.2557 +    |> sort (prod_ord Real.compare string_ord o pairself swap)
 10.2558 +  end
 10.2559 +
 10.2560 +end;
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Tools/ATP/atp_proof_reconstruct.ML	Mon Jan 23 17:40:32 2012 +0100
    11.3 @@ -0,0 +1,951 @@
    11.4 +(*  Title:      HOL/Tools/ATP/atp_proof_reconstruct.ML
    11.5 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    11.6 +    Author:     Claire Quigley, Cambridge University Computer Laboratory
    11.7 +    Author:     Jasmin Blanchette, TU Muenchen
    11.8 +
    11.9 +Proof reconstruction from ATP proofs.
   11.10 +*)
   11.11 +
   11.12 +signature ATP_PROOF_RECONSTRUCT =
   11.13 +sig
   11.14 +  type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term
   11.15 +  type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula
   11.16 +  type 'a proof = 'a ATP_Proof.proof
   11.17 +  type locality = ATP_Problem_Generate.locality
   11.18 +
   11.19 +  datatype reconstructor =
   11.20 +    Metis of string * string |
   11.21 +    SMT
   11.22 +
   11.23 +  datatype play =
   11.24 +    Played of reconstructor * Time.time |
   11.25 +    Trust_Playable of reconstructor * Time.time option |
   11.26 +    Failed_to_Play of reconstructor
   11.27 +
   11.28 +  type minimize_command = string list -> string
   11.29 +  type one_line_params =
   11.30 +    play * string * (string * locality) list * minimize_command * int * int
   11.31 +  type isar_params =
   11.32 +    bool * int * string Symtab.table * (string * locality) list vector
   11.33 +    * int Symtab.table * string proof * thm
   11.34 +
   11.35 +  val metisN : string
   11.36 +  val smtN : string
   11.37 +  val full_typesN : string
   11.38 +  val partial_typesN : string
   11.39 +  val no_typesN : string
   11.40 +  val really_full_type_enc : string
   11.41 +  val full_type_enc : string
   11.42 +  val partial_type_enc : string
   11.43 +  val no_type_enc : string
   11.44 +  val full_type_encs : string list
   11.45 +  val partial_type_encs : string list
   11.46 +  val metis_default_lam_trans : string
   11.47 +  val metis_call : string -> string -> string
   11.48 +  val string_for_reconstructor : reconstructor -> string
   11.49 +  val used_facts_in_atp_proof :
   11.50 +    Proof.context -> (string * locality) list vector -> string proof
   11.51 +    -> (string * locality) list
   11.52 +  val lam_trans_from_atp_proof : string proof -> string -> string
   11.53 +  val is_typed_helper_used_in_atp_proof : string proof -> bool
   11.54 +  val used_facts_in_unsound_atp_proof :
   11.55 +    Proof.context -> (string * locality) list vector -> 'a proof
   11.56 +    -> string list option
   11.57 +  val unalias_type_enc : string -> string list
   11.58 +  val one_line_proof_text : one_line_params -> string
   11.59 +  val make_tvar : string -> typ
   11.60 +  val make_tfree : Proof.context -> string -> typ
   11.61 +  val term_from_atp :
   11.62 +    Proof.context -> bool -> int Symtab.table -> typ option
   11.63 +    -> (string, string) ho_term -> term
   11.64 +  val prop_from_atp :
   11.65 +    Proof.context -> bool -> int Symtab.table
   11.66 +    -> (string, string, (string, string) ho_term) formula -> term
   11.67 +  val isar_proof_text :
   11.68 +    Proof.context -> bool -> isar_params -> one_line_params -> string
   11.69 +  val proof_text :
   11.70 +    Proof.context -> bool -> isar_params -> one_line_params -> string
   11.71 +end;
   11.72 +
   11.73 +structure ATP_Proof_Reconstruct : ATP_PROOF_RECONSTRUCT =
   11.74 +struct
   11.75 +
   11.76 +open ATP_Util
   11.77 +open ATP_Problem
   11.78 +open ATP_Proof
   11.79 +open ATP_Problem_Generate
   11.80 +
   11.81 +structure String_Redirect = ATP_Proof_Redirect(
   11.82 +    type key = step_name
   11.83 +    val ord = fn ((s, _ : string list), (s', _)) => fast_string_ord (s, s')
   11.84 +    val string_of = fst)
   11.85 +
   11.86 +open String_Redirect
   11.87 +
   11.88 +datatype reconstructor =
   11.89 +  Metis of string * string |
   11.90 +  SMT
   11.91 +
   11.92 +datatype play =
   11.93 +  Played of reconstructor * Time.time |
   11.94 +  Trust_Playable of reconstructor * Time.time option |
   11.95 +  Failed_to_Play of reconstructor
   11.96 +
   11.97 +type minimize_command = string list -> string
   11.98 +type one_line_params =
   11.99 +  play * string * (string * locality) list * minimize_command * int * int
  11.100 +type isar_params =
  11.101 +  bool * int * string Symtab.table * (string * locality) list vector
  11.102 +  * int Symtab.table * string proof * thm
  11.103 +
  11.104 +val metisN = "metis"
  11.105 +val smtN = "smt"
  11.106 +
  11.107 +val full_typesN = "full_types"
  11.108 +val partial_typesN = "partial_types"
  11.109 +val no_typesN = "no_types"
  11.110 +
  11.111 +val really_full_type_enc = "mono_tags"
  11.112 +val full_type_enc = "poly_guards_query"
  11.113 +val partial_type_enc = "poly_args"
  11.114 +val no_type_enc = "erased"
  11.115 +
  11.116 +val full_type_encs = [full_type_enc, really_full_type_enc]
  11.117 +val partial_type_encs = partial_type_enc :: full_type_encs
  11.118 +
  11.119 +val type_enc_aliases =
  11.120 +  [(full_typesN, full_type_encs),
  11.121 +   (partial_typesN, partial_type_encs),
  11.122 +   (no_typesN, [no_type_enc])]
  11.123 +
  11.124 +fun unalias_type_enc s =
  11.125 +  AList.lookup (op =) type_enc_aliases s |> the_default [s]
  11.126 +
  11.127 +val metis_default_lam_trans = combinatorsN
  11.128 +
  11.129 +fun metis_call type_enc lam_trans =
  11.130 +  let
  11.131 +    val type_enc =
  11.132 +      case AList.find (fn (enc, encs) => enc = hd encs) type_enc_aliases
  11.133 +                      type_enc of
  11.134 +        [alias] => alias
  11.135 +      | _ => type_enc
  11.136 +    val opts = [] |> type_enc <> partial_typesN ? cons type_enc
  11.137 +                  |> lam_trans <> metis_default_lam_trans ? cons lam_trans
  11.138 +  in metisN ^ (if null opts then "" else " (" ^ commas opts ^ ")") end
  11.139 +
  11.140 +fun string_for_reconstructor (Metis (type_enc, lam_trans)) =
  11.141 +    metis_call type_enc lam_trans
  11.142 +  | string_for_reconstructor SMT = smtN
  11.143 +
  11.144 +fun find_first_in_list_vector vec key =
  11.145 +  Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key
  11.146 +                 | (_, value) => value) NONE vec
  11.147 +
  11.148 +val unprefix_fact_number = space_implode "_" o tl o space_explode "_"
  11.149 +
  11.150 +fun resolve_one_named_fact fact_names s =
  11.151 +  case try (unprefix fact_prefix) s of
  11.152 +    SOME s' =>
  11.153 +    let val s' = s' |> unprefix_fact_number |> unascii_of in
  11.154 +      s' |> find_first_in_list_vector fact_names |> Option.map (pair s')
  11.155 +    end
  11.156 +  | NONE => NONE
  11.157 +fun resolve_fact fact_names = map_filter (resolve_one_named_fact fact_names)
  11.158 +fun is_fact fact_names = not o null o resolve_fact fact_names
  11.159 +
  11.160 +fun resolve_one_named_conjecture s =
  11.161 +  case try (unprefix conjecture_prefix) s of
  11.162 +    SOME s' => Int.fromString s'
  11.163 +  | NONE => NONE
  11.164 +
  11.165 +val resolve_conjecture = map_filter resolve_one_named_conjecture
  11.166 +val is_conjecture = not o null o resolve_conjecture
  11.167 +
  11.168 +fun is_axiom_used_in_proof pred =
  11.169 +  exists (fn Inference ((_, ss), _, _, []) => exists pred ss | _ => false)
  11.170 +
  11.171 +val is_combinator_def = String.isPrefix (helper_prefix ^ combinator_prefix)
  11.172 +
  11.173 +val ascii_of_lam_fact_prefix = ascii_of lam_fact_prefix
  11.174 +
  11.175 +(* overapproximation (good enough) *)
  11.176 +fun is_lam_lifted s =
  11.177 +  String.isPrefix fact_prefix s andalso
  11.178 +  String.isSubstring ascii_of_lam_fact_prefix s
  11.179 +
  11.180 +fun lam_trans_from_atp_proof atp_proof default =
  11.181 +  if is_axiom_used_in_proof is_combinator_def atp_proof then combinatorsN
  11.182 +  else if is_axiom_used_in_proof is_lam_lifted atp_proof then lam_liftingN
  11.183 +  else default
  11.184 +
  11.185 +val is_typed_helper_name =
  11.186 +  String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix
  11.187 +fun is_typed_helper_used_in_atp_proof atp_proof =
  11.188 +  is_axiom_used_in_proof is_typed_helper_name atp_proof
  11.189 +
  11.190 +val leo2_ext = "extcnf_equal_neg"
  11.191 +val isa_ext = Thm.get_name_hint @{thm ext}
  11.192 +val isa_short_ext = Long_Name.base_name isa_ext
  11.193 +
  11.194 +fun ext_name ctxt =
  11.195 +  if Thm.eq_thm_prop (@{thm ext},
  11.196 +         singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then
  11.197 +    isa_short_ext
  11.198 +  else
  11.199 +    isa_ext
  11.200 +
  11.201 +fun add_fact _ fact_names (Inference ((_, ss), _, _, [])) =
  11.202 +    union (op =) (resolve_fact fact_names ss)
  11.203 +  | add_fact ctxt _ (Inference (_, _, rule, _)) =
  11.204 +    if rule = leo2_ext then insert (op =) (ext_name ctxt, General) else I
  11.205 +  | add_fact _ _ _ = I
  11.206 +
  11.207 +fun used_facts_in_atp_proof ctxt fact_names atp_proof =
  11.208 +  if null atp_proof then Vector.foldl (uncurry (union (op =))) [] fact_names
  11.209 +  else fold (add_fact ctxt fact_names) atp_proof []
  11.210 +
  11.211 +(* (quasi-)underapproximation of the truth *)
  11.212 +fun is_locality_global Local = false
  11.213 +  | is_locality_global Assum = false
  11.214 +  | is_locality_global Chained = false
  11.215 +  | is_locality_global _ = true
  11.216 +
  11.217 +fun used_facts_in_unsound_atp_proof _ _ [] = NONE
  11.218 +  | used_facts_in_unsound_atp_proof ctxt fact_names atp_proof =
  11.219 +    let
  11.220 +      val used_facts = used_facts_in_atp_proof ctxt fact_names atp_proof
  11.221 +    in
  11.222 +      if forall (is_locality_global o snd) used_facts andalso
  11.223 +         not (is_axiom_used_in_proof (is_conjecture o single) atp_proof) then
  11.224 +        SOME (map fst used_facts)
  11.225 +      else
  11.226 +        NONE
  11.227 +    end
  11.228 +
  11.229 +
  11.230 +(** Soft-core proof reconstruction: one-liners **)
  11.231 +
  11.232 +fun string_for_label (s, num) = s ^ string_of_int num
  11.233 +
  11.234 +fun show_time NONE = ""
  11.235 +  | show_time (SOME ext_time) = " (" ^ string_from_ext_time ext_time ^ ")"
  11.236 +
  11.237 +fun apply_on_subgoal _ 1 = "by "
  11.238 +  | apply_on_subgoal 1 _ = "apply "
  11.239 +  | apply_on_subgoal i n =
  11.240 +    "prefer " ^ string_of_int i ^ " " ^ apply_on_subgoal 1 n
  11.241 +fun command_call name [] =
  11.242 +    name |> not (Lexicon.is_identifier name) ? enclose "(" ")"
  11.243 +  | command_call name args = "(" ^ name ^ " " ^ space_implode " " args ^ ")"
  11.244 +fun try_command_line banner time command =
  11.245 +  banner ^ ": " ^ Markup.markup Isabelle_Markup.sendback command ^ show_time time ^ "."
  11.246 +fun using_labels [] = ""
  11.247 +  | using_labels ls =
  11.248 +    "using " ^ space_implode " " (map string_for_label ls) ^ " "
  11.249 +fun reconstructor_command reconstr i n (ls, ss) =
  11.250 +  using_labels ls ^ apply_on_subgoal i n ^
  11.251 +  command_call (string_for_reconstructor reconstr) ss
  11.252 +fun minimize_line _ [] = ""
  11.253 +  | minimize_line minimize_command ss =
  11.254 +    case minimize_command ss of
  11.255 +      "" => ""
  11.256 +    | command => "\nTo minimize: " ^ Markup.markup Isabelle_Markup.sendback command ^ "."
  11.257 +
  11.258 +val split_used_facts =
  11.259 +  List.partition (curry (op =) Chained o snd)
  11.260 +  #> pairself (sort_distinct (string_ord o pairself fst))
  11.261 +
  11.262 +fun one_line_proof_text (preplay, banner, used_facts, minimize_command,
  11.263 +                         subgoal, subgoal_count) =
  11.264 +  let
  11.265 +    val (chained, extra) = split_used_facts used_facts
  11.266 +    val (failed, reconstr, ext_time) =
  11.267 +      case preplay of
  11.268 +        Played (reconstr, time) => (false, reconstr, (SOME (false, time)))
  11.269 +      | Trust_Playable (reconstr, time) =>
  11.270 +        (false, reconstr,
  11.271 +         case time of
  11.272 +           NONE => NONE
  11.273 +         | SOME time =>
  11.274 +           if time = Time.zeroTime then NONE else SOME (true, time))
  11.275 +      | Failed_to_Play reconstr => (true, reconstr, NONE)
  11.276 +    val try_line =
  11.277 +      ([], map fst extra)
  11.278 +      |> reconstructor_command reconstr subgoal subgoal_count
  11.279 +      |> (if failed then enclose "One-line proof reconstruction failed: " "."
  11.280 +          else try_command_line banner ext_time)
  11.281 +  in try_line ^ minimize_line minimize_command (map fst (extra @ chained)) end
  11.282 +
  11.283 +(** Hard-core proof reconstruction: structured Isar proofs **)
  11.284 +
  11.285 +fun forall_of v t = HOLogic.all_const (fastype_of v) $ lambda v t
  11.286 +fun exists_of v t = HOLogic.exists_const (fastype_of v) $ lambda v t
  11.287 +
  11.288 +fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS)
  11.289 +fun make_tfree ctxt w =
  11.290 +  let val ww = "'" ^ w in
  11.291 +    TFree (ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))
  11.292 +  end
  11.293 +
  11.294 +val indent_size = 2
  11.295 +val no_label = ("", ~1)
  11.296 +
  11.297 +val raw_prefix = "x"
  11.298 +val assum_prefix = "a"
  11.299 +val have_prefix = "f"
  11.300 +
  11.301 +fun raw_label_for_name (num, ss) =
  11.302 +  case resolve_conjecture ss of
  11.303 +    [j] => (conjecture_prefix, j)
  11.304 +  | _ => case Int.fromString num of
  11.305 +           SOME j => (raw_prefix, j)
  11.306 +         | NONE => (raw_prefix ^ num, 0)
  11.307 +
  11.308 +(**** INTERPRETATION OF TSTP SYNTAX TREES ****)
  11.309 +
  11.310 +exception HO_TERM of (string, string) ho_term list
  11.311 +exception FORMULA of (string, string, (string, string) ho_term) formula list
  11.312 +exception SAME of unit
  11.313 +
  11.314 +(* Type variables are given the basic sort "HOL.type". Some will later be
  11.315 +   constrained by information from type literals, or by type inference. *)
  11.316 +fun typ_from_atp ctxt (u as ATerm (a, us)) =
  11.317 +  let val Ts = map (typ_from_atp ctxt) us in
  11.318 +    case unprefix_and_unascii type_const_prefix a of
  11.319 +      SOME b => Type (invert_const b, Ts)
  11.320 +    | NONE =>
  11.321 +      if not (null us) then
  11.322 +        raise HO_TERM [u]  (* only "tconst"s have type arguments *)
  11.323 +      else case unprefix_and_unascii tfree_prefix a of
  11.324 +        SOME b => make_tfree ctxt b
  11.325 +      | NONE =>
  11.326 +        (* Could be an Isabelle variable or a variable from the ATP, say "X1"
  11.327 +           or "_5018". Sometimes variables from the ATP are indistinguishable
  11.328 +           from Isabelle variables, which forces us to use a type parameter in
  11.329 +           all cases. *)
  11.330 +        (a |> perhaps (unprefix_and_unascii tvar_prefix), HOLogic.typeS)
  11.331 +        |> Type_Infer.param 0
  11.332 +  end
  11.333 +
  11.334 +(* Type class literal applied to a type. Returns triple of polarity, class,
  11.335 +   type. *)
  11.336 +fun type_constraint_from_term ctxt (u as ATerm (a, us)) =
  11.337 +  case (unprefix_and_unascii class_prefix a, map (typ_from_atp ctxt) us) of
  11.338 +    (SOME b, [T]) => (b, T)
  11.339 +  | _ => raise HO_TERM [u]
  11.340 +
  11.341 +(* Accumulate type constraints in a formula: negative type literals. *)
  11.342 +fun add_var (key, z)  = Vartab.map_default (key, []) (cons z)
  11.343 +fun add_type_constraint false (cl, TFree (a ,_)) = add_var ((a, ~1), cl)
  11.344 +  | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl)
  11.345 +  | add_type_constraint _ _ = I
  11.346 +
  11.347 +fun repair_variable_name f s =
  11.348 +  let
  11.349 +    fun subscript_name s n = s ^ nat_subscript n
  11.350 +    val s = String.map f s
  11.351 +  in
  11.352 +    case space_explode "_" s of
  11.353 +      [_] => (case take_suffix Char.isDigit (String.explode s) of
  11.354 +                (cs1 as _ :: _, cs2 as _ :: _) =>
  11.355 +                subscript_name (String.implode cs1)
  11.356 +                               (the (Int.fromString (String.implode cs2)))
  11.357 +              | (_, _) => s)
  11.358 +    | [s1, s2] => (case Int.fromString s2 of
  11.359 +                     SOME n => subscript_name s1 n
  11.360 +                   | NONE => s)
  11.361 +    | _ => s
  11.362 +  end
  11.363 +
  11.364 +(* The number of type arguments of a constant, zero if it's monomorphic. For
  11.365 +   (instances of) Skolem pseudoconstants, this information is encoded in the
  11.366 +   constant name. *)
  11.367 +fun num_type_args thy s =
  11.368 +  if String.isPrefix skolem_const_prefix s then
  11.369 +    s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the
  11.370 +  else if String.isPrefix lam_lifted_prefix s then
  11.371 +    if String.isPrefix lam_lifted_poly_prefix s then 2 else 0
  11.372 +  else
  11.373 +    (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length
  11.374 +
  11.375 +fun slack_fastype_of t = fastype_of t handle TERM _ => HOLogic.typeT
  11.376 +
  11.377 +(* First-order translation. No types are known for variables. "HOLogic.typeT"
  11.378 +   should allow them to be inferred. *)
  11.379 +fun term_from_atp ctxt textual sym_tab =
  11.380 +  let
  11.381 +    val thy = Proof_Context.theory_of ctxt
  11.382 +    (* For Metis, we use 1 rather than 0 because variable references in clauses
  11.383 +       may otherwise conflict with variable constraints in the goal. At least,
  11.384 +       type inference often fails otherwise. See also "axiom_inference" in
  11.385 +       "Metis_Reconstruct". *)
  11.386 +    val var_index = if textual then 0 else 1
  11.387 +    fun do_term extra_ts opt_T u =
  11.388 +      case u of
  11.389 +        ATerm (s, us) =>
  11.390 +        if String.isPrefix simple_type_prefix s then
  11.391 +          @{const True} (* ignore TPTP type information *)
  11.392 +        else if s = tptp_equal then
  11.393 +          let val ts = map (do_term [] NONE) us in
  11.394 +            if textual andalso length ts = 2 andalso
  11.395 +              hd ts aconv List.last ts then
  11.396 +              (* Vampire is keen on producing these. *)
  11.397 +              @{const True}
  11.398 +            else
  11.399 +              list_comb (Const (@{const_name HOL.eq}, HOLogic.typeT), ts)
  11.400 +          end
  11.401 +        else case unprefix_and_unascii const_prefix s of
  11.402 +          SOME s' =>
  11.403 +          let
  11.404 +            val ((s', s''), mangled_us) =
  11.405 +              s' |> unmangled_const |>> `invert_const
  11.406 +          in
  11.407 +            if s' = type_tag_name then
  11.408 +              case mangled_us @ us of
  11.409 +                [typ_u, term_u] =>
  11.410 +                do_term extra_ts (SOME (typ_from_atp ctxt typ_u)) term_u
  11.411 +              | _ => raise HO_TERM us
  11.412 +            else if s' = predicator_name then
  11.413 +              do_term [] (SOME @{typ bool}) (hd us)
  11.414 +            else if s' = app_op_name then
  11.415 +              let val extra_t = do_term [] NONE (List.last us) in
  11.416 +                do_term (extra_t :: extra_ts)
  11.417 +                        (case opt_T of
  11.418 +                           SOME T => SOME (slack_fastype_of extra_t --> T)
  11.419 +                         | NONE => NONE)
  11.420 +                        (nth us (length us - 2))
  11.421 +              end
  11.422 +            else if s' = type_guard_name then
  11.423 +              @{const True} (* ignore type predicates *)
  11.424 +            else
  11.425 +              let
  11.426 +                val new_skolem = String.isPrefix new_skolem_const_prefix s''
  11.427 +                val num_ty_args =
  11.428 +                  length us - the_default 0 (Symtab.lookup sym_tab s)
  11.429 +                val (type_us, term_us) =
  11.430 +                  chop num_ty_args us |>> append mangled_us
  11.431 +                val term_ts = map (do_term [] NONE) term_us
  11.432 +                val T =
  11.433 +                  (if not (null type_us) andalso
  11.434 +                      num_type_args thy s' = length type_us then
  11.435 +                     let val Ts = type_us |> map (typ_from_atp ctxt) in
  11.436 +                       if new_skolem then
  11.437 +                         SOME (Type_Infer.paramify_vars (tl Ts ---> hd Ts))
  11.438 +                       else if textual then
  11.439 +                         try (Sign.const_instance thy) (s', Ts)
  11.440 +                       else
  11.441 +                         NONE
  11.442 +                     end
  11.443 +                   else
  11.444 +                     NONE)
  11.445 +                  |> (fn SOME T => T
  11.446 +                       | NONE => map slack_fastype_of term_ts --->
  11.447 +                                 (case opt_T of
  11.448 +                                    SOME T => T
  11.449 +                                  | NONE => HOLogic.typeT))
  11.450 +                val t =
  11.451 +                  if new_skolem then
  11.452 +                    Var ((new_skolem_var_name_from_const s'', var_index), T)
  11.453 +                  else
  11.454 +                    Const (unproxify_const s', T)
  11.455 +              in list_comb (t, term_ts @ extra_ts) end
  11.456 +          end
  11.457 +        | NONE => (* a free or schematic variable *)
  11.458 +          let
  11.459 +            val term_ts = map (do_term [] NONE) us
  11.460 +            val ts = term_ts @ extra_ts
  11.461 +            val T =
  11.462 +              case opt_T of
  11.463 +                SOME T => map slack_fastype_of term_ts ---> T
  11.464 +              | NONE => map slack_fastype_of ts ---> HOLogic.typeT
  11.465 +            val t =
  11.466 +              case unprefix_and_unascii fixed_var_prefix s of
  11.467 +                SOME s => Free (s, T)
  11.468 +              | NONE =>
  11.469 +                case unprefix_and_unascii schematic_var_prefix s of
  11.470 +                  SOME s => Var ((s, var_index), T)
  11.471 +                | NONE =>
  11.472 +                  Var ((s |> textual ? repair_variable_name Char.toLower,
  11.473 +                        var_index), T)
  11.474 +          in list_comb (t, ts) end
  11.475 +  in do_term [] end
  11.476 +
  11.477 +fun term_from_atom ctxt textual sym_tab pos (u as ATerm (s, _)) =
  11.478 +  if String.isPrefix class_prefix s then
  11.479 +    add_type_constraint pos (type_constraint_from_term ctxt u)
  11.480 +    #> pair @{const True}
  11.481 +  else
  11.482 +    pair (term_from_atp ctxt textual sym_tab (SOME @{typ bool}) u)
  11.483 +
  11.484 +val combinator_table =
  11.485 +  [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}),
  11.486 +   (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}),
  11.487 +   (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}),
  11.488 +   (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}),
  11.489 +   (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})]
  11.490 +
  11.491 +fun uncombine_term thy =
  11.492 +  let
  11.493 +    fun aux (t1 $ t2) = betapply (pairself aux (t1, t2))
  11.494 +      | aux (Abs (s, T, t')) = Abs (s, T, aux t')
  11.495 +      | aux (t as Const (x as (s, _))) =
  11.496 +        (case AList.lookup (op =) combinator_table s of
  11.497 +           SOME thm => thm |> prop_of |> specialize_type thy x
  11.498 +                           |> Logic.dest_equals |> snd
  11.499 +         | NONE => t)
  11.500 +      | aux t = t
  11.501 +  in aux end
  11.502 +
  11.503 +(* Update schematic type variables with detected sort constraints. It's not
  11.504 +   totally clear whether this code is necessary. *)
  11.505 +fun repair_tvar_sorts (t, tvar_tab) =
  11.506 +  let
  11.507 +    fun do_type (Type (a, Ts)) = Type (a, map do_type Ts)
  11.508 +      | do_type (TVar (xi, s)) =
  11.509 +        TVar (xi, the_default s (Vartab.lookup tvar_tab xi))
  11.510 +      | do_type (TFree z) = TFree z
  11.511 +    fun do_term (Const (a, T)) = Const (a, do_type T)
  11.512 +      | do_term (Free (a, T)) = Free (a, do_type T)
  11.513 +      | do_term (Var (xi, T)) = Var (xi, do_type T)
  11.514 +      | do_term (t as Bound _) = t
  11.515 +      | do_term (Abs (a, T, t)) = Abs (a, do_type T, do_term t)
  11.516 +      | do_term (t1 $ t2) = do_term t1 $ do_term t2
  11.517 +  in t |> not (Vartab.is_empty tvar_tab) ? do_term end
  11.518 +
  11.519 +fun quantify_over_var quant_of var_s t =
  11.520 +  let
  11.521 +    val vars = [] |> Term.add_vars t |> filter (fn ((s, _), _) => s = var_s)
  11.522 +                  |> map Var
  11.523 +  in fold_rev quant_of vars t end
  11.524 +
  11.525 +(* Interpret an ATP formula as a HOL term, extracting sort constraints as they
  11.526 +   appear in the formula. *)
  11.527 +fun prop_from_atp ctxt textual sym_tab phi =
  11.528 +  let
  11.529 +    fun do_formula pos phi =
  11.530 +      case phi of
  11.531 +        AQuant (_, [], phi) => do_formula pos phi
  11.532 +      | AQuant (q, (s, _) :: xs, phi') =>
  11.533 +        do_formula pos (AQuant (q, xs, phi'))
  11.534 +        (* FIXME: TFF *)
  11.535 +        #>> quantify_over_var (case q of
  11.536 +                                 AForall => forall_of
  11.537 +                               | AExists => exists_of)
  11.538 +                              (s |> textual ? repair_variable_name Char.toLower)
  11.539 +      | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not
  11.540 +      | AConn (c, [phi1, phi2]) =>
  11.541 +        do_formula (pos |> c = AImplies ? not) phi1
  11.542 +        ##>> do_formula pos phi2
  11.543 +        #>> (case c of
  11.544 +               AAnd => s_conj
  11.545 +             | AOr => s_disj
  11.546 +             | AImplies => s_imp
  11.547 +             | AIff => s_iff
  11.548 +             | ANot => raise Fail "impossible connective")
  11.549 +      | AAtom tm => term_from_atom ctxt textual sym_tab pos tm
  11.550 +      | _ => raise FORMULA [phi]
  11.551 +  in repair_tvar_sorts (do_formula true phi Vartab.empty) end
  11.552 +
  11.553 +fun infer_formula_types ctxt =
  11.554 +  Type.constraint HOLogic.boolT
  11.555 +  #> Syntax.check_term
  11.556 +         (Proof_Context.set_mode Proof_Context.mode_schematic ctxt)
  11.557 +
  11.558 +fun uncombined_etc_prop_from_atp ctxt textual sym_tab =
  11.559 +  let val thy = Proof_Context.theory_of ctxt in
  11.560 +    prop_from_atp ctxt textual sym_tab
  11.561 +    #> textual ? uncombine_term thy #> infer_formula_types ctxt
  11.562 +  end
  11.563 +
  11.564 +(**** Translation of TSTP files to Isar proofs ****)
  11.565 +
  11.566 +fun unvarify_term (Var ((s, 0), T)) = Free (s, T)
  11.567 +  | unvarify_term t = raise TERM ("unvarify_term: non-Var", [t])
  11.568 +
  11.569 +fun decode_line sym_tab (Definition (name, phi1, phi2)) ctxt =
  11.570 +    let
  11.571 +      val thy = Proof_Context.theory_of ctxt
  11.572 +      val t1 = prop_from_atp ctxt true sym_tab phi1
  11.573 +      val vars = snd (strip_comb t1)
  11.574 +      val frees = map unvarify_term vars
  11.575 +      val unvarify_args = subst_atomic (vars ~~ frees)
  11.576 +      val t2 = prop_from_atp ctxt true sym_tab phi2
  11.577 +      val (t1, t2) =
  11.578 +        HOLogic.eq_const HOLogic.typeT $ t1 $ t2
  11.579 +        |> unvarify_args |> uncombine_term thy |> infer_formula_types ctxt
  11.580 +        |> HOLogic.dest_eq
  11.581 +    in
  11.582 +      (Definition (name, t1, t2),
  11.583 +       fold Variable.declare_term (maps Misc_Legacy.term_frees [t1, t2]) ctxt)
  11.584 +    end
  11.585 +  | decode_line sym_tab (Inference (name, u, rule, deps)) ctxt =
  11.586 +    let val t = u |> uncombined_etc_prop_from_atp ctxt true sym_tab in
  11.587 +      (Inference (name, t, rule, deps),
  11.588 +       fold Variable.declare_term (Misc_Legacy.term_frees t) ctxt)
  11.589 +    end
  11.590 +fun decode_lines ctxt sym_tab lines =
  11.591 +  fst (fold_map (decode_line sym_tab) lines ctxt)
  11.592 +
  11.593 +fun is_same_inference _ (Definition _) = false
  11.594 +  | is_same_inference t (Inference (_, t', _, _)) = t aconv t'
  11.595 +
  11.596 +(* No "real" literals means only type information (tfree_tcs, clsrel, or
  11.597 +   clsarity). *)
  11.598 +val is_only_type_information = curry (op aconv) @{term True}
  11.599 +
  11.600 +fun replace_one_dependency (old, new) dep =
  11.601 +  if is_same_atp_step dep old then new else [dep]
  11.602 +fun replace_dependencies_in_line _ (line as Definition _) = line
  11.603 +  | replace_dependencies_in_line p (Inference (name, t, rule, deps)) =
  11.604 +    Inference (name, t, rule,
  11.605 +               fold (union (op =) o replace_one_dependency p) deps [])
  11.606 +
  11.607 +(* Discard facts; consolidate adjacent lines that prove the same formula, since
  11.608 +   they differ only in type information.*)
  11.609 +fun add_line _ (line as Definition _) lines = line :: lines
  11.610 +  | add_line fact_names (Inference (name as (_, ss), t, rule, [])) lines =
  11.611 +    (* No dependencies: fact, conjecture, or (for Vampire) internal facts or
  11.612 +       definitions. *)
  11.613 +    if is_fact fact_names ss then
  11.614 +      (* Facts are not proof lines. *)
  11.615 +      if is_only_type_information t then
  11.616 +        map (replace_dependencies_in_line (name, [])) lines
  11.617 +      (* Is there a repetition? If so, replace later line by earlier one. *)
  11.618 +      else case take_prefix (not o is_same_inference t) lines of
  11.619 +        (_, []) => lines (* no repetition of proof line *)
  11.620 +      | (pre, Inference (name', _, _, _) :: post) =>
  11.621 +        pre @ map (replace_dependencies_in_line (name', [name])) post
  11.622 +      | _ => raise Fail "unexpected inference"
  11.623 +    else if is_conjecture ss then
  11.624 +      Inference (name, s_not t, rule, []) :: lines
  11.625 +    else
  11.626 +      map (replace_dependencies_in_line (name, [])) lines
  11.627 +  | add_line _ (Inference (name, t, rule, deps)) lines =
  11.628 +    (* Type information will be deleted later; skip repetition test. *)
  11.629 +    if is_only_type_information t then
  11.630 +      Inference (name, t, rule, deps) :: lines
  11.631 +    (* Is there a repetition? If so, replace later line by earlier one. *)
  11.632 +    else case take_prefix (not o is_same_inference t) lines of
  11.633 +      (* FIXME: Doesn't this code risk conflating proofs involving different
  11.634 +         types? *)
  11.635 +       (_, []) => Inference (name, t, rule, deps) :: lines
  11.636 +     | (pre, Inference (name', t', rule, _) :: post) =>
  11.637 +       Inference (name, t', rule, deps) ::
  11.638 +       pre @ map (replace_dependencies_in_line (name', [name])) post
  11.639 +     | _ => raise Fail "unexpected inference"
  11.640 +
  11.641 +(* Recursively delete empty lines (type information) from the proof. *)
  11.642 +fun add_nontrivial_line (line as Inference (name, t, _, [])) lines =
  11.643 +    if is_only_type_information t then delete_dependency name lines
  11.644 +    else line :: lines
  11.645 +  | add_nontrivial_line line lines = line :: lines
  11.646 +and delete_dependency name lines =
  11.647 +  fold_rev add_nontrivial_line
  11.648 +           (map (replace_dependencies_in_line (name, [])) lines) []
  11.649 +
  11.650 +(* ATPs sometimes reuse free variable names in the strangest ways. Removing
  11.651 +   offending lines often does the trick. *)
  11.652 +fun is_bad_free frees (Free x) = not (member (op =) frees x)
  11.653 +  | is_bad_free _ _ = false
  11.654 +
  11.655 +fun add_desired_line _ _ _ (line as Definition (name, _, _)) (j, lines) =
  11.656 +    (j, line :: map (replace_dependencies_in_line (name, [])) lines)
  11.657 +  | add_desired_line isar_shrink_factor fact_names frees
  11.658 +                     (Inference (name as (_, ss), t, rule, deps)) (j, lines) =
  11.659 +    (j + 1,
  11.660 +     if is_fact fact_names ss orelse
  11.661 +        is_conjecture ss orelse
  11.662 +        (* the last line must be kept *)
  11.663 +        j = 0 orelse
  11.664 +        (not (is_only_type_information t) andalso
  11.665 +         null (Term.add_tvars t []) andalso
  11.666 +         not (exists_subterm (is_bad_free frees) t) andalso
  11.667 +         length deps >= 2 andalso j mod isar_shrink_factor = 0 andalso
  11.668 +         (* kill next to last line, which usually results in a trivial step *)
  11.669 +         j <> 1) then
  11.670 +       Inference (name, t, rule, deps) :: lines  (* keep line *)
  11.671 +     else
  11.672 +       map (replace_dependencies_in_line (name, deps)) lines)  (* drop line *)
  11.673 +
  11.674 +(** Isar proof construction and manipulation **)
  11.675 +
  11.676 +type label = string * int
  11.677 +type facts = label list * string list
  11.678 +
  11.679 +datatype isar_qualifier = Show | Then | Moreover | Ultimately
  11.680 +
  11.681 +datatype isar_step =
  11.682 +  Fix of (string * typ) list |
  11.683 +  Let of term * term |
  11.684 +  Assume of label * term |
  11.685 +  Prove of isar_qualifier list * label * term * byline
  11.686 +and byline =
  11.687 +  By_Metis of facts |
  11.688 +  Case_Split of isar_step list list * facts
  11.689 +
  11.690 +fun add_fact_from_dependency fact_names (name as (_, ss)) =
  11.691 +  if is_fact fact_names ss then
  11.692 +    apsnd (union (op =) (map fst (resolve_fact fact_names ss)))
  11.693 +  else
  11.694 +    apfst (insert (op =) (raw_label_for_name name))
  11.695 +
  11.696 +fun repair_name "$true" = "c_True"
  11.697 +  | repair_name "$false" = "c_False"
  11.698 +  | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *)
  11.699 +  | repair_name s =
  11.700 +    if is_tptp_equal s orelse
  11.701 +       (* seen in Vampire proofs *)
  11.702 +       (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then
  11.703 +      tptp_equal
  11.704 +    else
  11.705 +      s
  11.706 +
  11.707 +(* FIXME: Still needed? Try with SPASS proofs perhaps. *)
  11.708 +val kill_duplicate_assumptions_in_proof =
  11.709 +  let
  11.710 +    fun relabel_facts subst =
  11.711 +      apfst (map (fn l => AList.lookup (op =) subst l |> the_default l))
  11.712 +    fun do_step (step as Assume (l, t)) (proof, subst, assums) =
  11.713 +        (case AList.lookup (op aconv) assums t of
  11.714 +           SOME l' => (proof, (l, l') :: subst, assums)
  11.715 +         | NONE => (step :: proof, subst, (t, l) :: assums))
  11.716 +      | do_step (Prove (qs, l, t, by)) (proof, subst, assums) =
  11.717 +        (Prove (qs, l, t,
  11.718 +                case by of
  11.719 +                  By_Metis facts => By_Metis (relabel_facts subst facts)
  11.720 +                | Case_Split (proofs, facts) =>
  11.721 +                  Case_Split (map do_proof proofs,
  11.722 +                              relabel_facts subst facts)) ::
  11.723 +         proof, subst, assums)
  11.724 +      | do_step step (proof, subst, assums) = (step :: proof, subst, assums)
  11.725 +    and do_proof proof = fold do_step proof ([], [], []) |> #1 |> rev
  11.726 +  in do_proof end
  11.727 +
  11.728 +fun used_labels_of_step (Prove (_, _, _, by)) =
  11.729 +    (case by of
  11.730 +       By_Metis (ls, _) => ls
  11.731 +     | Case_Split (proofs, (ls, _)) =>
  11.732 +       fold (union (op =) o used_labels_of) proofs ls)
  11.733 +  | used_labels_of_step _ = []
  11.734 +and used_labels_of proof = fold (union (op =) o used_labels_of_step) proof []
  11.735 +
  11.736 +fun kill_useless_labels_in_proof proof =
  11.737 +  let
  11.738 +    val used_ls = used_labels_of proof
  11.739 +    fun do_label l = if member (op =) used_ls l then l else no_label
  11.740 +    fun do_step (Assume (l, t)) = Assume (do_label l, t)
  11.741 +      | do_step (Prove (qs, l, t, by)) =
  11.742 +        Prove (qs, do_label l, t,
  11.743 +               case by of
  11.744 +                 Case_Split (proofs, facts) =>
  11.745 +                 Case_Split (map (map do_step) proofs, facts)
  11.746 +               | _ => by)
  11.747 +      | do_step step = step
  11.748 +  in map do_step proof end
  11.749 +
  11.750 +fun prefix_for_depth n = replicate_string (n + 1)
  11.751 +
  11.752 +val relabel_proof =
  11.753 +  let
  11.754 +    fun aux _ _ _ [] = []
  11.755 +      | aux subst depth (next_assum, next_fact) (Assume (l, t) :: proof) =
  11.756 +        if l = no_label then
  11.757 +          Assume (l, t) :: aux subst depth (next_assum, next_fact) proof
  11.758 +        else
  11.759 +          let val l' = (prefix_for_depth depth assum_prefix, next_assum) in
  11.760 +            Assume (l', t) ::
  11.761 +            aux ((l, l') :: subst) depth (next_assum + 1, next_fact) proof
  11.762 +          end
  11.763 +      | aux subst depth (next_assum, next_fact)
  11.764 +            (Prove (qs, l, t, by) :: proof) =
  11.765 +        let
  11.766 +          val (l', subst, next_fact) =
  11.767 +            if l = no_label then
  11.768 +              (l, subst, next_fact)
  11.769 +            else
  11.770 +              let
  11.771 +                val l' = (prefix_for_depth depth have_prefix, next_fact)
  11.772 +              in (l', (l, l') :: subst, next_fact + 1) end
  11.773 +          val relabel_facts =
  11.774 +            apfst (maps (the_list o AList.lookup (op =) subst))
  11.775 +          val by =
  11.776 +            case by of
  11.777 +              By_Metis facts => By_Metis (relabel_facts facts)
  11.778 +            | Case_Split (proofs, facts) =>
  11.779 +              Case_Split (map (aux subst (depth + 1) (1, 1)) proofs,
  11.780 +                          relabel_facts facts)
  11.781 +        in
  11.782 +          Prove (qs, l', t, by) :: aux subst depth (next_assum, next_fact) proof
  11.783 +        end
  11.784 +      | aux subst depth nextp (step :: proof) =
  11.785 +        step :: aux subst depth nextp proof
  11.786 +  in aux [] 0 (1, 1) end
  11.787 +
  11.788 +fun string_for_proof ctxt0 type_enc lam_trans i n =
  11.789 +  let
  11.790 +    val ctxt =
  11.791 +      ctxt0 |> Config.put show_free_types false
  11.792 +            |> Config.put show_types true
  11.793 +            |> Config.put show_sorts true
  11.794 +    fun fix_print_mode f x =
  11.795 +      Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN)
  11.796 +                               (print_mode_value ())) f x
  11.797 +    fun do_indent ind = replicate_string (ind * indent_size) " "
  11.798 +    fun do_free (s, T) =
  11.799 +      maybe_quote s ^ " :: " ^
  11.800 +      maybe_quote (fix_print_mode (Syntax.string_of_typ ctxt) T)
  11.801 +    fun do_label l = if l = no_label then "" else string_for_label l ^ ": "
  11.802 +    fun do_have qs =
  11.803 +      (if member (op =) qs Moreover then "moreover " else "") ^
  11.804 +      (if member (op =) qs Ultimately then "ultimately " else "") ^
  11.805 +      (if member (op =) qs Then then
  11.806 +         if member (op =) qs Show then "thus" else "hence"
  11.807 +       else
  11.808 +         if member (op =) qs Show then "show" else "have")
  11.809 +    val do_term = maybe_quote o fix_print_mode (Syntax.string_of_term ctxt)
  11.810 +    val reconstr = Metis (type_enc, lam_trans)
  11.811 +    fun do_facts (ls, ss) =
  11.812 +      reconstructor_command reconstr 1 1
  11.813 +          (ls |> sort_distinct (prod_ord string_ord int_ord),
  11.814 +           ss |> sort_distinct string_ord)
  11.815 +    and do_step ind (Fix xs) =
  11.816 +        do_indent ind ^ "fix " ^ space_implode " and " (map do_free xs) ^ "\n"
  11.817 +      | do_step ind (Let (t1, t2)) =
  11.818 +        do_indent ind ^ "let " ^ do_term t1 ^ " = " ^ do_term t2 ^ "\n"
  11.819 +      | do_step ind (Assume (l, t)) =
  11.820 +        do_indent ind ^ "assume " ^ do_label l ^ do_term t ^ "\n"
  11.821 +      | do_step ind (Prove (qs, l, t, By_Metis facts)) =
  11.822 +        do_indent ind ^ do_have qs ^ " " ^
  11.823 +        do_label l ^ do_term t ^ " " ^ do_facts facts ^ "\n"
  11.824 +      | do_step ind (Prove (qs, l, t, Case_Split (proofs, facts))) =
  11.825 +        implode (map (prefix (do_indent ind ^ "moreover\n") o do_block ind)
  11.826 +                     proofs) ^
  11.827 +        do_indent ind ^ do_have qs ^ " " ^ do_label l ^ do_term t ^ " " ^
  11.828 +        do_facts facts ^ "\n"
  11.829 +    and do_steps prefix suffix ind steps =
  11.830 +      let val s = implode (map (do_step ind) steps) in
  11.831 +        replicate_string (ind * indent_size - size prefix) " " ^ prefix ^
  11.832 +        String.extract (s, ind * indent_size,
  11.833 +                        SOME (size s - ind * indent_size - 1)) ^
  11.834 +        suffix ^ "\n"
  11.835 +      end
  11.836 +    and do_block ind proof = do_steps "{ " " }" (ind + 1) proof
  11.837 +    (* One-step proofs are pointless; better use the Metis one-liner
  11.838 +       directly. *)
  11.839 +    and do_proof [Prove (_, _, _, By_Metis _)] = ""
  11.840 +      | do_proof proof =
  11.841 +        (if i <> 1 then "prefer " ^ string_of_int i ^ "\n" else "") ^
  11.842 +        do_indent 0 ^ "proof -\n" ^ do_steps "" "" 1 proof ^ do_indent 0 ^
  11.843 +        (if n <> 1 then "next" else "qed")
  11.844 +  in do_proof end
  11.845 +
  11.846 +fun isar_proof_text ctxt isar_proof_requested
  11.847 +        (debug, isar_shrink_factor, pool, fact_names, sym_tab, atp_proof, goal)
  11.848 +        (one_line_params as (_, _, _, _, subgoal, subgoal_count)) =
  11.849 +  let
  11.850 +    val isar_shrink_factor =
  11.851 +      (if isar_proof_requested then 1 else 2) * isar_shrink_factor
  11.852 +    val (params, hyp_ts, concl_t) = strip_subgoal ctxt goal subgoal
  11.853 +    val frees = fold Term.add_frees (concl_t :: hyp_ts) []
  11.854 +    val one_line_proof = one_line_proof_text one_line_params
  11.855 +    val type_enc =
  11.856 +      if is_typed_helper_used_in_atp_proof atp_proof then full_typesN
  11.857 +      else partial_typesN
  11.858 +    val lam_trans = lam_trans_from_atp_proof atp_proof metis_default_lam_trans
  11.859 +
  11.860 +    fun isar_proof_of () =
  11.861 +      let
  11.862 +        val atp_proof =
  11.863 +          atp_proof
  11.864 +          |> clean_up_atp_proof_dependencies
  11.865 +          |> nasty_atp_proof pool
  11.866 +          |> map_term_names_in_atp_proof repair_name
  11.867 +          |> decode_lines ctxt sym_tab
  11.868 +          |> rpair [] |-> fold_rev (add_line fact_names)
  11.869 +          |> rpair [] |-> fold_rev add_nontrivial_line
  11.870 +          |> rpair (0, [])
  11.871 +          |-> fold_rev (add_desired_line isar_shrink_factor fact_names frees)
  11.872 +          |> snd
  11.873 +        val conj_name = conjecture_prefix ^ string_of_int (length hyp_ts)
  11.874 +        val conjs =
  11.875 +          atp_proof
  11.876 +          |> map_filter (fn Inference (name as (_, ss), _, _, []) =>
  11.877 +                            if member (op =) ss conj_name then SOME name else NONE
  11.878 +                          | _ => NONE)
  11.879 +        fun dep_of_step (Definition _) = NONE
  11.880 +          | dep_of_step (Inference (name, _, _, from)) = SOME (from, name)
  11.881 +        val ref_graph = atp_proof |> map_filter dep_of_step |> make_ref_graph
  11.882 +        val axioms = axioms_of_ref_graph ref_graph conjs
  11.883 +        val tainted = tainted_atoms_of_ref_graph ref_graph conjs
  11.884 +        val props =
  11.885 +          Symtab.empty
  11.886 +          |> fold (fn Definition _ => I (* FIXME *)
  11.887 +                    | Inference ((s, _), t, _, _) =>
  11.888 +                      Symtab.update_new (s,
  11.889 +                          t |> member (op = o apsnd fst) tainted s ? s_not))
  11.890 +                  atp_proof
  11.891 +        (* FIXME: add "fold_rev forall_of (map Var (Term.add_vars t []))"? *)
  11.892 +        fun prop_of_clause c =
  11.893 +          fold (curry s_disj) (map_filter (Symtab.lookup props o fst) c)
  11.894 +               @{term False}
  11.895 +        fun label_of_clause c = (space_implode "___" (map fst c), 0)
  11.896 +        fun maybe_show outer c =
  11.897 +          (outer andalso length c = 1 andalso subset (op =) (c, conjs))
  11.898 +          ? cons Show
  11.899 +        fun do_have outer qs (gamma, c) =
  11.900 +          Prove (maybe_show outer c qs, label_of_clause c, prop_of_clause c,
  11.901 +                 By_Metis (fold (add_fact_from_dependency fact_names
  11.902 +                                 o the_single) gamma ([], [])))
  11.903 +        fun do_inf outer (Have z) = do_have outer [] z
  11.904 +          | do_inf outer (Hence z) = do_have outer [Then] z
  11.905 +          | do_inf outer (Cases cases) =
  11.906 +            let val c = succedent_of_cases cases in
  11.907 +              Prove (maybe_show outer c [Ultimately], label_of_clause c,
  11.908 +                     prop_of_clause c,
  11.909 +                     Case_Split (map (do_case false) cases, ([], [])))
  11.910 +            end
  11.911 +        and do_case outer (c, infs) =
  11.912 +          Assume (label_of_clause c, prop_of_clause c) ::
  11.913 +          map (do_inf outer) infs
  11.914 +        val isar_proof =
  11.915 +          (if null params then [] else [Fix params]) @
  11.916 +          (ref_graph
  11.917 +           |> redirect_graph axioms tainted
  11.918 +           |> chain_direct_proof
  11.919 +           |> map (do_inf true)
  11.920 +           |> kill_duplicate_assumptions_in_proof
  11.921 +           |> kill_useless_labels_in_proof
  11.922 +           |> relabel_proof)
  11.923 +          |> string_for_proof ctxt type_enc lam_trans subgoal subgoal_count
  11.924 +      in
  11.925 +        case isar_proof of
  11.926 +          "" =>
  11.927 +          if isar_proof_requested then
  11.928 +            "\nNo structured proof available (proof too short)."
  11.929 +          else
  11.930 +            ""
  11.931 +        | _ =>
  11.932 +          "\n\n" ^ (if isar_proof_requested then "Structured proof"
  11.933 +                    else "Perhaps this will work") ^
  11.934 +          ":\n" ^ Markup.markup Isabelle_Markup.sendback isar_proof
  11.935 +      end
  11.936 +    val isar_proof =
  11.937 +      if debug then
  11.938 +        isar_proof_of ()
  11.939 +      else case try isar_proof_of () of
  11.940 +        SOME s => s
  11.941 +      | NONE => if isar_proof_requested then
  11.942 +                  "\nWarning: The Isar proof construction failed."
  11.943 +                else
  11.944 +                  ""
  11.945 +  in one_line_proof ^ isar_proof end
  11.946 +
  11.947 +fun proof_text ctxt isar_proof isar_params
  11.948 +               (one_line_params as (preplay, _, _, _, _, _)) =
  11.949 +  (if case preplay of Failed_to_Play _ => true | _ => isar_proof then
  11.950 +     isar_proof_text ctxt isar_proof isar_params
  11.951 +   else
  11.952 +     one_line_proof_text) one_line_params
  11.953 +
  11.954 +end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/ATP/atp_proof_redirect.ML	Mon Jan 23 17:40:32 2012 +0100
    12.3 @@ -0,0 +1,223 @@
    12.4 +(*  Title:      HOL/Tools/ATP/atp_proof_redirect.ML
    12.5 +    Author:     Jasmin Blanchette, TU Muenchen
    12.6 +
    12.7 +Transformation of a proof by contradiction into a direct proof.
    12.8 +*)
    12.9 +
   12.10 +signature ATP_ATOM =
   12.11 +sig
   12.12 +  type key
   12.13 +  val ord : key * key -> order
   12.14 +  val string_of : key -> string
   12.15 +end;
   12.16 +
   12.17 +signature ATP_PROOF_REDIRECT =
   12.18 +sig
   12.19 +  type atom
   12.20 +
   12.21 +  structure Atom_Graph : GRAPH
   12.22 +
   12.23 +  type ref_sequent = atom list * atom
   12.24 +  type ref_graph = unit Atom_Graph.T
   12.25 +
   12.26 +  type clause = atom list
   12.27 +  type direct_sequent = atom list * clause
   12.28 +  type direct_graph = unit Atom_Graph.T
   12.29 +
   12.30 +  type rich_sequent = clause list * clause
   12.31 +
   12.32 +  datatype direct_inference =
   12.33 +    Have of rich_sequent |
   12.34 +    Hence of rich_sequent |
   12.35 +    Cases of (clause * direct_inference list) list
   12.36 +
   12.37 +  type direct_proof = direct_inference list
   12.38 +
   12.39 +  val make_ref_graph : (atom list * atom) list -> ref_graph
   12.40 +  val axioms_of_ref_graph : ref_graph -> atom list -> atom list
   12.41 +  val tainted_atoms_of_ref_graph : ref_graph -> atom list -> atom list
   12.42 +  val sequents_of_ref_graph : ref_graph -> ref_sequent list
   12.43 +  val redirect_sequent : atom list -> atom -> ref_sequent -> direct_sequent
   12.44 +  val direct_graph : direct_sequent list -> direct_graph
   12.45 +  val redirect_graph : atom list -> atom list -> ref_graph -> direct_proof
   12.46 +  val succedent_of_cases : (clause * direct_inference list) list -> clause
   12.47 +  val chain_direct_proof : direct_proof -> direct_proof
   12.48 +  val string_of_direct_proof : direct_proof -> string
   12.49 +end;
   12.50 +
   12.51 +functor ATP_Proof_Redirect(Atom : ATP_ATOM): ATP_PROOF_REDIRECT =
   12.52 +struct
   12.53 +
   12.54 +type atom = Atom.key
   12.55 +
   12.56 +structure Atom_Graph = Graph(Atom)
   12.57 +
   12.58 +type ref_sequent = atom list * atom
   12.59 +type ref_graph = unit Atom_Graph.T
   12.60 +
   12.61 +type clause = atom list
   12.62 +type direct_sequent = atom list * clause
   12.63 +type direct_graph = unit Atom_Graph.T
   12.64 +
   12.65 +type rich_sequent = clause list * clause
   12.66 +
   12.67 +datatype direct_inference =
   12.68 +  Have of rich_sequent |
   12.69 +  Hence of rich_sequent |
   12.70 +  Cases of (clause * direct_inference list) list
   12.71 +
   12.72 +type direct_proof = direct_inference list
   12.73 +
   12.74 +fun atom_eq p = (Atom.ord p = EQUAL)
   12.75 +fun clause_eq (c, d) = (length c = length d andalso forall atom_eq (c ~~ d))
   12.76 +fun direct_sequent_eq ((gamma, c), (delta, d)) =
   12.77 +  clause_eq (gamma, delta) andalso clause_eq (c, d)
   12.78 +
   12.79 +fun make_ref_graph infers =
   12.80 +  let
   12.81 +    fun add_edge to from =
   12.82 +      Atom_Graph.default_node (from, ())
   12.83 +      #> Atom_Graph.default_node (to, ())
   12.84 +      #> Atom_Graph.add_edge_acyclic (from, to)
   12.85 +    fun add_infer (froms, to) = fold (add_edge to) froms
   12.86 +  in Atom_Graph.empty |> fold add_infer infers end
   12.87 +
   12.88 +fun axioms_of_ref_graph ref_graph conjs =
   12.89 +  subtract atom_eq conjs (Atom_Graph.minimals ref_graph)
   12.90 +fun tainted_atoms_of_ref_graph ref_graph = Atom_Graph.all_succs ref_graph
   12.91 +
   12.92 +fun sequents_of_ref_graph ref_graph =
   12.93 +  map (`(Atom_Graph.immediate_preds ref_graph))
   12.94 +      (filter_out (Atom_Graph.is_minimal ref_graph) (Atom_Graph.keys ref_graph))
   12.95 +
   12.96 +fun redirect_sequent tainted bot (gamma, c) =
   12.97 +  if member atom_eq tainted c then
   12.98 +    gamma |> List.partition (not o member atom_eq tainted)
   12.99 +          |>> not (atom_eq (c, bot)) ? cons c
  12.100 +  else
  12.101 +    (gamma, [c])
  12.102 +
  12.103 +fun direct_graph seqs =
  12.104 +  let
  12.105 +    fun add_edge from to =
  12.106 +      Atom_Graph.default_node (from, ())
  12.107 +      #> Atom_Graph.default_node (to, ())
  12.108 +      #> Atom_Graph.add_edge_acyclic (from, to)
  12.109 +    fun add_seq (gamma, c) = fold (fn l => fold (add_edge l) c) gamma
  12.110 +  in Atom_Graph.empty |> fold add_seq seqs end
  12.111 +
  12.112 +fun disj cs = fold (union atom_eq) cs [] |> sort Atom.ord
  12.113 +
  12.114 +fun succedent_of_inference (Have (_, c)) = c
  12.115 +  | succedent_of_inference (Hence (_, c)) = c
  12.116 +  | succedent_of_inference (Cases cases) = succedent_of_cases cases
  12.117 +and succedent_of_case (c, []) = c
  12.118 +  | succedent_of_case (_, infs) = succedent_of_inference (List.last infs)
  12.119 +and succedent_of_cases cases = disj (map succedent_of_case cases)
  12.120 +
  12.121 +fun dest_Have (Have z) = z
  12.122 +  | dest_Have _ = raise Fail "non-Have"
  12.123 +
  12.124 +fun enrich_Have nontrivs trivs (cs, c) =
  12.125 +  (cs |> map (fn c => if member clause_eq nontrivs c then disj (c :: trivs)
  12.126 +                      else c),
  12.127 +   disj (c :: trivs))
  12.128 +  |> Have
  12.129 +
  12.130 +fun s_cases cases =
  12.131 +  case cases |> List.partition (null o snd) of
  12.132 +    (trivs, nontrivs as [(nontriv0, proof)]) =>
  12.133 +    if forall (can dest_Have) proof then
  12.134 +      let val seqs = proof |> map dest_Have in
  12.135 +        seqs |> map (enrich_Have (nontriv0 :: map snd seqs) (map fst trivs))
  12.136 +      end
  12.137 +    else
  12.138 +      [Cases nontrivs]
  12.139 +  | (_, nontrivs) => [Cases nontrivs]
  12.140 +
  12.141 +fun descendants direct_graph =
  12.142 +  these o try (Atom_Graph.all_succs direct_graph) o single
  12.143 +
  12.144 +fun zones_of 0 _ = []
  12.145 +  | zones_of n (bs :: bss) =
  12.146 +    (fold (subtract atom_eq) bss) bs :: zones_of (n - 1) (bss @ [bs])
  12.147 +
  12.148 +fun redirect_graph axioms tainted ref_graph =
  12.149 +  let
  12.150 +    val [bot] = Atom_Graph.maximals ref_graph
  12.151 +    val seqs =
  12.152 +      map (redirect_sequent tainted bot) (sequents_of_ref_graph ref_graph)
  12.153 +    val direct_graph = direct_graph seqs
  12.154 +
  12.155 +    fun redirect c proved seqs =
  12.156 +      if null seqs then
  12.157 +        []
  12.158 +      else if length c < 2 then
  12.159 +        let
  12.160 +          val proved = c @ proved
  12.161 +          val provable =
  12.162 +            filter (fn (gamma, _) => subset atom_eq (gamma, proved)) seqs
  12.163 +          val horn_provable = filter (fn (_, [_]) => true | _ => false) provable
  12.164 +          val seq as (gamma, c) = hd (horn_provable @ provable)
  12.165 +        in
  12.166 +          Have (map single gamma, c) ::
  12.167 +          redirect c proved (filter (curry (not o direct_sequent_eq) seq) seqs)
  12.168 +        end
  12.169 +      else
  12.170 +        let
  12.171 +          fun subsequents seqs zone =
  12.172 +            filter (fn (gamma, _) => subset atom_eq (gamma, zone @ proved)) seqs
  12.173 +          val zones = zones_of (length c) (map (descendants direct_graph) c)
  12.174 +          val subseqss = map (subsequents seqs) zones
  12.175 +          val seqs = fold (subtract direct_sequent_eq) subseqss seqs
  12.176 +          val cases =
  12.177 +            map2 (fn l => fn subseqs => ([l], redirect [l] proved subseqs))
  12.178 +                 c subseqss
  12.179 +        in s_cases cases @ redirect (succedent_of_cases cases) proved seqs end
  12.180 +  in redirect [] axioms seqs end
  12.181 +
  12.182 +val chain_direct_proof =
  12.183 +  let
  12.184 +    fun chain_inf cl0 (seq as Have (cs, c)) =
  12.185 +        if member clause_eq cs cl0 then
  12.186 +          Hence (filter_out (curry clause_eq cl0) cs, c)
  12.187 +        else
  12.188 +          seq
  12.189 +      | chain_inf _ (Cases cases) = Cases (map chain_case cases)
  12.190 +    and chain_case (c, is) = (c, chain_proof (SOME c) is)
  12.191 +    and chain_proof _ [] = []
  12.192 +      | chain_proof (SOME prev) (i :: is) =
  12.193 +        chain_inf prev i :: chain_proof (SOME (succedent_of_inference i)) is
  12.194 +      | chain_proof _ (i :: is) =
  12.195 +        i :: chain_proof (SOME (succedent_of_inference i)) is
  12.196 +  in chain_proof NONE end
  12.197 +
  12.198 +fun indent 0 = ""
  12.199 +  | indent n = "  " ^ indent (n - 1)
  12.200 +
  12.201 +fun string_of_clause [] = "\<bottom>"
  12.202 +  | string_of_clause ls = space_implode " \<or> " (map Atom.string_of ls)
  12.203 +
  12.204 +fun string_of_rich_sequent ch ([], c) = ch ^ " " ^ string_of_clause c
  12.205 +  | string_of_rich_sequent ch (cs, c) =
  12.206 +    commas (map string_of_clause cs) ^ " " ^ ch ^ " " ^ string_of_clause c
  12.207 +
  12.208 +fun string_of_case depth (c, proof) =
  12.209 +  indent (depth + 1) ^ "[" ^ string_of_clause c ^ "]"
  12.210 +  |> not (null proof) ? suffix ("\n" ^ string_of_subproof (depth + 1) proof)
  12.211 +
  12.212 +and string_of_inference depth (Have seq) =
  12.213 +    indent depth ^ string_of_rich_sequent "\<triangleright>" seq
  12.214 +  | string_of_inference depth (Hence seq) =
  12.215 +    indent depth ^ string_of_rich_sequent "\<guillemotright>" seq
  12.216 +  | string_of_inference depth (Cases cases) =
  12.217 +    indent depth ^ "[\n" ^
  12.218 +    space_implode ("\n" ^ indent depth ^ "|\n")
  12.219 +                  (map (string_of_case depth) cases) ^ "\n" ^
  12.220 +    indent depth ^ "]"
  12.221 +
  12.222 +and string_of_subproof depth = cat_lines o map (string_of_inference depth)
  12.223 +
  12.224 +val string_of_direct_proof = string_of_subproof 0
  12.225 +
  12.226 +end;
    13.1 --- a/src/HOL/Tools/ATP/atp_reconstruct.ML	Mon Jan 23 17:40:31 2012 +0100
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,951 +0,0 @@
    13.4 -(*  Title:      HOL/Tools/ATP/atp_reconstruct.ML
    13.5 -    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    13.6 -    Author:     Claire Quigley, Cambridge University Computer Laboratory
    13.7 -    Author:     Jasmin Blanchette, TU Muenchen
    13.8 -
    13.9 -Proof reconstruction from ATP proofs.
   13.10 -*)
   13.11 -
   13.12 -signature ATP_RECONSTRUCT =
   13.13 -sig
   13.14 -  type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term
   13.15 -  type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula
   13.16 -  type 'a proof = 'a ATP_Proof.proof
   13.17 -  type locality = ATP_Translate.locality
   13.18 -
   13.19 -  datatype reconstructor =
   13.20 -    Metis of string * string |
   13.21 -    SMT
   13.22 -
   13.23 -  datatype play =
   13.24 -    Played of reconstructor * Time.time |
   13.25 -    Trust_Playable of reconstructor * Time.time option |
   13.26 -    Failed_to_Play of reconstructor
   13.27 -
   13.28 -  type minimize_command = string list -> string
   13.29 -  type one_line_params =
   13.30 -    play * string * (string * locality) list * minimize_command * int * int
   13.31 -  type isar_params =
   13.32 -    bool * int * string Symtab.table * (string * locality) list vector
   13.33 -    * int Symtab.table * string proof * thm
   13.34 -
   13.35 -  val metisN : string
   13.36 -  val smtN : string
   13.37 -  val full_typesN : string
   13.38 -  val partial_typesN : string
   13.39 -  val no_typesN : string
   13.40 -  val really_full_type_enc : string
   13.41 -  val full_type_enc : string
   13.42 -  val partial_type_enc : string
   13.43 -  val no_type_enc : string
   13.44 -  val full_type_encs : string list
   13.45 -  val partial_type_encs : string list
   13.46 -  val metis_default_lam_trans : string
   13.47 -  val metis_call : string -> string -> string
   13.48 -  val string_for_reconstructor : reconstructor -> string
   13.49 -  val used_facts_in_atp_proof :
   13.50 -    Proof.context -> (string * locality) list vector -> string proof
   13.51 -    -> (string * locality) list
   13.52 -  val lam_trans_from_atp_proof : string proof -> string -> string
   13.53 -  val is_typed_helper_used_in_atp_proof : string proof -> bool
   13.54 -  val used_facts_in_unsound_atp_proof :
   13.55 -    Proof.context -> (string * locality) list vector -> 'a proof
   13.56 -    -> string list option
   13.57 -  val unalias_type_enc : string -> string list
   13.58 -  val one_line_proof_text : one_line_params -> string
   13.59 -  val make_tvar : string -> typ
   13.60 -  val make_tfree : Proof.context -> string -> typ
   13.61 -  val term_from_atp :
   13.62 -    Proof.context -> bool -> int Symtab.table -> typ option
   13.63 -    -> (string, string) ho_term -> term
   13.64 -  val prop_from_atp :
   13.65 -    Proof.context -> bool -> int Symtab.table
   13.66 -    -> (string, string, (string, string) ho_term) formula -> term
   13.67 -  val isar_proof_text :
   13.68 -    Proof.context -> bool -> isar_params -> one_line_params -> string
   13.69 -  val proof_text :
   13.70 -    Proof.context -> bool -> isar_params -> one_line_params -> string
   13.71 -end;
   13.72 -
   13.73 -structure ATP_Reconstruct : ATP_RECONSTRUCT =
   13.74 -struct
   13.75 -
   13.76 -open ATP_Util
   13.77 -open ATP_Problem
   13.78 -open ATP_Proof
   13.79 -open ATP_Translate
   13.80 -
   13.81 -structure String_Redirect = ATP_Redirect(
   13.82 -    type key = step_name
   13.83 -    val ord = fn ((s, _ : string list), (s', _)) => fast_string_ord (s, s')
   13.84 -    val string_of = fst)
   13.85 -
   13.86 -open String_Redirect
   13.87 -
   13.88 -datatype reconstructor =
   13.89 -  Metis of string * string |
   13.90 -  SMT
   13.91 -
   13.92 -datatype play =
   13.93 -  Played of reconstructor * Time.time |
   13.94 -  Trust_Playable of reconstructor * Time.time option |
   13.95 -  Failed_to_Play of reconstructor
   13.96 -
   13.97 -type minimize_command = string list -> string
   13.98 -type one_line_params =
   13.99 -  play * string * (string * locality) list * minimize_command * int * int
  13.100 -type isar_params =
  13.101 -  bool * int * string Symtab.table * (string * locality) list vector
  13.102 -  * int Symtab.table * string proof * thm
  13.103 -
  13.104 -val metisN = "metis"
  13.105 -val smtN = "smt"
  13.106 -
  13.107 -val full_typesN = "full_types"
  13.108 -val partial_typesN = "partial_types"
  13.109 -val no_typesN = "no_types"
  13.110 -
  13.111 -val really_full_type_enc = "mono_tags"
  13.112 -val full_type_enc = "poly_guards_query"
  13.113 -val partial_type_enc = "poly_args"
  13.114 -val no_type_enc = "erased"
  13.115 -
  13.116 -val full_type_encs = [full_type_enc, really_full_type_enc]
  13.117 -val partial_type_encs = partial_type_enc :: full_type_encs
  13.118 -
  13.119 -val type_enc_aliases =
  13.120 -  [(full_typesN, full_type_encs),
  13.121 -   (partial_typesN, partial_type_encs),
  13.122 -   (no_typesN, [no_type_enc])]
  13.123 -
  13.124 -fun unalias_type_enc s =
  13.125 -  AList.lookup (op =) type_enc_aliases s |> the_default [s]
  13.126 -
  13.127 -val metis_default_lam_trans = combinatorsN
  13.128 -
  13.129 -fun metis_call type_enc lam_trans =
  13.130 -  let
  13.131 -    val type_enc =
  13.132 -      case AList.find (fn (enc, encs) => enc = hd encs) type_enc_aliases
  13.133 -                      type_enc of
  13.134 -        [alias] => alias
  13.135 -      | _ => type_enc
  13.136 -    val opts = [] |> type_enc <> partial_typesN ? cons type_enc
  13.137 -                  |> lam_trans <> metis_default_lam_trans ? cons lam_trans
  13.138 -  in metisN ^ (if null opts then "" else " (" ^ commas opts ^ ")") end
  13.139 -
  13.140 -fun string_for_reconstructor (Metis (type_enc, lam_trans)) =
  13.141 -    metis_call type_enc lam_trans
  13.142 -  | string_for_reconstructor SMT = smtN
  13.143 -
  13.144 -fun find_first_in_list_vector vec key =
  13.145 -  Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key
  13.146 -                 | (_, value) => value) NONE vec
  13.147 -
  13.148 -val unprefix_fact_number = space_implode "_" o tl o space_explode "_"
  13.149 -
  13.150 -fun resolve_one_named_fact fact_names s =
  13.151 -  case try (unprefix fact_prefix) s of
  13.152 -    SOME s' =>
  13.153 -    let val s' = s' |> unprefix_fact_number |> unascii_of in
  13.154 -      s' |> find_first_in_list_vector fact_names |> Option.map (pair s')
  13.155 -    end
  13.156 -  | NONE => NONE
  13.157 -fun resolve_fact fact_names = map_filter (resolve_one_named_fact fact_names)
  13.158 -fun is_fact fact_names = not o null o resolve_fact fact_names
  13.159 -
  13.160 -fun resolve_one_named_conjecture s =
  13.161 -  case try (unprefix conjecture_prefix) s of
  13.162 -    SOME s' => Int.fromString s'
  13.163 -  | NONE => NONE
  13.164 -
  13.165 -val resolve_conjecture = map_filter resolve_one_named_conjecture
  13.166 -val is_conjecture = not o null o resolve_conjecture
  13.167 -
  13.168 -fun is_axiom_used_in_proof pred =
  13.169 -  exists (fn Inference ((_, ss), _, _, []) => exists pred ss | _ => false)
  13.170 -
  13.171 -val is_combinator_def = String.isPrefix (helper_prefix ^ combinator_prefix)
  13.172 -
  13.173 -val ascii_of_lam_fact_prefix = ascii_of lam_fact_prefix
  13.174 -
  13.175 -(* overapproximation (good enough) *)
  13.176 -fun is_lam_lifted s =
  13.177 -  String.isPrefix fact_prefix s andalso
  13.178 -  String.isSubstring ascii_of_lam_fact_prefix s
  13.179 -
  13.180 -fun lam_trans_from_atp_proof atp_proof default =
  13.181 -  if is_axiom_used_in_proof is_combinator_def atp_proof then combinatorsN
  13.182 -  else if is_axiom_used_in_proof is_lam_lifted atp_proof then lam_liftingN
  13.183 -  else default
  13.184 -
  13.185 -val is_typed_helper_name =
  13.186 -  String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix
  13.187 -fun is_typed_helper_used_in_atp_proof atp_proof =
  13.188 -  is_axiom_used_in_proof is_typed_helper_name atp_proof
  13.189 -
  13.190 -val leo2_ext = "extcnf_equal_neg"
  13.191 -val isa_ext = Thm.get_name_hint @{thm ext}
  13.192 -val isa_short_ext = Long_Name.base_name isa_ext
  13.193 -
  13.194 -fun ext_name ctxt =
  13.195 -  if Thm.eq_thm_prop (@{thm ext},
  13.196 -         singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then
  13.197 -    isa_short_ext
  13.198 -  else
  13.199 -    isa_ext
  13.200 -
  13.201 -fun add_fact _ fact_names (Inference ((_, ss), _, _, [])) =
  13.202 -    union (op =) (resolve_fact fact_names ss)
  13.203 -  | add_fact ctxt _ (Inference (_, _, rule, _)) =
  13.204 -    if rule = leo2_ext then insert (op =) (ext_name ctxt, General) else I
  13.205 -  | add_fact _ _ _ = I
  13.206 -
  13.207 -fun used_facts_in_atp_proof ctxt fact_names atp_proof =
  13.208 -  if null atp_proof then Vector.foldl (uncurry (union (op =))) [] fact_names
  13.209 -  else fold (add_fact ctxt fact_names) atp_proof []
  13.210 -
  13.211 -(* (quasi-)underapproximation of the truth *)
  13.212 -fun is_locality_global Local = false
  13.213 -  | is_locality_global Assum = false
  13.214 -  | is_locality_global Chained = false
  13.215 -  | is_locality_global _ = true
  13.216 -
  13.217 -fun used_facts_in_unsound_atp_proof _ _ [] = NONE
  13.218 -  | used_facts_in_unsound_atp_proof ctxt fact_names atp_proof =
  13.219 -    let
  13.220 -      val used_facts = used_facts_in_atp_proof ctxt fact_names atp_proof
  13.221 -    in
  13.222 -      if forall (is_locality_global o snd) used_facts andalso
  13.223 -         not (is_axiom_used_in_proof (is_conjecture o single) atp_proof) then
  13.224 -        SOME (map fst used_facts)
  13.225 -      else
  13.226 -        NONE
  13.227 -    end
  13.228 -
  13.229 -
  13.230 -(** Soft-core proof reconstruction: one-liners **)
  13.231 -
  13.232 -fun string_for_label (s, num) = s ^ string_of_int num
  13.233 -
  13.234 -fun show_time NONE = ""
  13.235 -  | show_time (SOME ext_time) = " (" ^ string_from_ext_time ext_time ^ ")"
  13.236 -
  13.237 -fun apply_on_subgoal _ 1 = "by "
  13.238 -  | apply_on_subgoal 1 _ = "apply "
  13.239 -  | apply_on_subgoal i n =
  13.240 -    "prefer " ^ string_of_int i ^ " " ^ apply_on_subgoal 1 n
  13.241 -fun command_call name [] =
  13.242 -    name |> not (Lexicon.is_identifier name) ? enclose "(" ")"
  13.243 -  | command_call name args = "(" ^ name ^ " " ^ space_implode " " args ^ ")"
  13.244 -fun try_command_line banner time command =
  13.245 -  banner ^ ": " ^ Markup.markup Isabelle_Markup.sendback command ^ show_time time ^ "."
  13.246 -fun using_labels [] = ""
  13.247 -  | using_labels ls =
  13.248 -    "using " ^ space_implode " " (map string_for_label ls) ^ " "
  13.249 -fun reconstructor_command reconstr i n (ls, ss) =
  13.250 -  using_labels ls ^ apply_on_subgoal i n ^
  13.251 -  command_call (string_for_reconstructor reconstr) ss
  13.252 -fun minimize_line _ [] = ""
  13.253 -  | minimize_line minimize_command ss =
  13.254 -    case minimize_command ss of
  13.255 -      "" => ""
  13.256 -    | command => "\nTo minimize: " ^ Markup.markup Isabelle_Markup.sendback command ^ "."
  13.257 -
  13.258 -val split_used_facts =
  13.259 -  List.partition (curry (op =) Chained o snd)
  13.260 -  #> pairself (sort_distinct (string_ord o pairself fst))
  13.261 -
  13.262 -fun one_line_proof_text (preplay, banner, used_facts, minimize_command,
  13.263 -                         subgoal, subgoal_count) =
  13.264 -  let
  13.265 -    val (chained, extra) = split_used_facts used_facts
  13.266 -    val (failed, reconstr, ext_time) =
  13.267 -      case preplay of
  13.268 -        Played (reconstr, time) => (false, reconstr, (SOME (false, time)))
  13.269 -      | Trust_Playable (reconstr, time) =>
  13.270 -        (false, reconstr,
  13.271 -         case time of
  13.272 -           NONE => NONE
  13.273 -         | SOME time =>
  13.274 -           if time = Time.zeroTime then NONE else SOME (true, time))
  13.275 -      | Failed_to_Play reconstr => (true, reconstr, NONE)
  13.276 -    val try_line =
  13.277 -      ([], map fst extra)
  13.278 -      |> reconstructor_command reconstr subgoal subgoal_count
  13.279 -      |> (if failed then enclose "One-line proof reconstruction failed: " "."
  13.280 -          else try_command_line banner ext_time)
  13.281 -  in try_line ^ minimize_line minimize_command (map fst (extra @ chained)) end
  13.282 -
  13.283 -(** Hard-core proof reconstruction: structured Isar proofs **)
  13.284 -
  13.285 -fun forall_of v t = HOLogic.all_const (fastype_of v) $ lambda v t
  13.286 -fun exists_of v t = HOLogic.exists_const (fastype_of v) $ lambda v t
  13.287 -
  13.288 -fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS)
  13.289 -fun make_tfree ctxt w =
  13.290 -  let val ww = "'" ^ w in
  13.291 -    TFree (ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))
  13.292 -  end
  13.293 -
  13.294 -val indent_size = 2
  13.295 -val no_label = ("", ~1)
  13.296 -
  13.297 -val raw_prefix = "x"
  13.298 -val assum_prefix = "a"
  13.299 -val have_prefix = "f"
  13.300 -
  13.301 -fun raw_label_for_name (num, ss) =
  13.302 -  case resolve_conjecture ss of
  13.303 -    [j] => (conjecture_prefix, j)
  13.304 -  | _ => case Int.fromString num of
  13.305 -           SOME j => (raw_prefix, j)
  13.306 -         | NONE => (raw_prefix ^ num, 0)
  13.307 -
  13.308 -(**** INTERPRETATION OF TSTP SYNTAX TREES ****)
  13.309 -
  13.310 -exception HO_TERM of (string, string) ho_term list
  13.311 -exception FORMULA of (string, string, (string, string) ho_term) formula list
  13.312 -exception SAME of unit
  13.313 -
  13.314 -(* Type variables are given the basic sort "HOL.type". Some will later be
  13.315 -   constrained by information from type literals, or by type inference. *)
  13.316 -fun typ_from_atp ctxt (u as ATerm (a, us)) =
  13.317 -  let val Ts = map (typ_from_atp ctxt) us in
  13.318 -    case unprefix_and_unascii type_const_prefix a of
  13.319 -      SOME b => Type (invert_const b, Ts)
  13.320 -    | NONE =>
  13.321 -      if not (null us) then
  13.322 -        raise HO_TERM [u]  (* only "tconst"s have type arguments *)
  13.323 -      else case unprefix_and_unascii tfree_prefix a of
  13.324 -        SOME b => make_tfree ctxt b
  13.325 -      | NONE =>
  13.326 -        (* Could be an Isabelle variable or a variable from the ATP, say "X1"
  13.327 -           or "_5018". Sometimes variables from the ATP are indistinguishable
  13.328 -           from Isabelle variables, which forces us to use a type parameter in
  13.329 -           all cases. *)
  13.330 -        (a |> perhaps (unprefix_and_unascii tvar_prefix), HOLogic.typeS)
  13.331 -        |> Type_Infer.param 0
  13.332 -  end
  13.333 -
  13.334 -(* Type class literal applied to a type. Returns triple of polarity, class,
  13.335 -   type. *)
  13.336 -fun type_constraint_from_term ctxt (u as ATerm (a, us)) =
  13.337 -  case (unprefix_and_unascii class_prefix a, map (typ_from_atp ctxt) us) of
  13.338 -    (SOME b, [T]) => (b, T)
  13.339 -  | _ => raise HO_TERM [u]
  13.340 -
  13.341 -(* Accumulate type constraints in a formula: negative type literals. *)
  13.342 -fun add_var (key, z)  = Vartab.map_default (key, []) (cons z)
  13.343 -fun add_type_constraint false (cl, TFree (a ,_)) = add_var ((a, ~1), cl)
  13.344 -  | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl)
  13.345 -  | add_type_constraint _ _ = I
  13.346 -
  13.347 -fun repair_variable_name f s =
  13.348 -  let
  13.349 -    fun subscript_name s n = s ^ nat_subscript n
  13.350 -    val s = String.map f s
  13.351 -  in
  13.352 -    case space_explode "_" s of
  13.353 -      [_] => (case take_suffix Char.isDigit (String.explode s) of
  13.354 -                (cs1 as _ :: _, cs2 as _ :: _) =>
  13.355 -                subscript_name (String.implode cs1)
  13.356 -                               (the (Int.fromString (String.implode cs2)))
  13.357 -              | (_, _) => s)
  13.358 -    | [s1, s2] => (case Int.fromString s2 of
  13.359 -                     SOME n => subscript_name s1 n
  13.360 -                   | NONE => s)
  13.361 -    | _ => s
  13.362 -  end
  13.363 -
  13.364 -(* The number of type arguments of a constant, zero if it's monomorphic. For
  13.365 -   (instances of) Skolem pseudoconstants, this information is encoded in the
  13.366 -   constant name. *)
  13.367 -fun num_type_args thy s =
  13.368 -  if String.isPrefix skolem_const_prefix s then
  13.369 -    s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the
  13.370 -  else if String.isPrefix lam_lifted_prefix s then
  13.371 -    if String.isPrefix lam_lifted_poly_prefix s then 2 else 0
  13.372 -  else
  13.373 -    (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length
  13.374 -
  13.375 -fun slack_fastype_of t = fastype_of t handle TERM _ => HOLogic.typeT
  13.376 -
  13.377 -(* First-order translation. No types are known for variables. "HOLogic.typeT"
  13.378 -   should allow them to be inferred. *)
  13.379 -fun term_from_atp ctxt textual sym_tab =
  13.380 -  let
  13.381 -    val thy = Proof_Context.theory_of ctxt
  13.382 -    (* For Metis, we use 1 rather than 0 because variable references in clauses
  13.383 -       may otherwise conflict with variable constraints in the goal. At least,
  13.384 -       type inference often fails otherwise. See also "axiom_inference" in
  13.385 -       "Metis_Reconstruct". *)
  13.386 -    val var_index = if textual then 0 else 1
  13.387 -    fun do_term extra_ts opt_T u =
  13.388 -      case u of
  13.389 -        ATerm (s, us) =>
  13.390 -        if String.isPrefix simple_type_prefix s then
  13.391 -          @{const True} (* ignore TPTP type information *)
  13.392 -        else if s = tptp_equal then
  13.393 -          let val ts = map (do_term [] NONE) us in
  13.394 -            if textual andalso length ts = 2 andalso
  13.395 -              hd ts aconv List.last ts then
  13.396 -              (* Vampire is keen on producing these. *)
  13.397 -              @{const True}
  13.398 -            else
  13.399 -              list_comb (Const (@{const_name HOL.eq}, HOLogic.typeT), ts)
  13.400 -          end
  13.401 -        else case unprefix_and_unascii const_prefix s of
  13.402 -          SOME s' =>
  13.403 -          let
  13.404 -            val ((s', s''), mangled_us) =
  13.405 -              s' |> unmangled_const |>> `invert_const
  13.406 -          in
  13.407 -            if s' = type_tag_name then
  13.408 -              case mangled_us @ us of
  13.409 -                [typ_u, term_u] =>
  13.410 -                do_term extra_ts (SOME (typ_from_atp ctxt typ_u)) term_u
  13.411 -              | _ => raise HO_TERM us
  13.412 -            else if s' = predicator_name then
  13.413 -              do_term [] (SOME @{typ bool}) (hd us)
  13.414 -            else if s' = app_op_name then
  13.415 -              let val extra_t = do_term [] NONE (List.last us) in
  13.416 -                do_term (extra_t :: extra_ts)
  13.417 -                        (case opt_T of
  13.418 -                           SOME T => SOME (slack_fastype_of extra_t --> T)
  13.419 -                         | NONE => NONE)
  13.420 -                        (nth us (length us - 2))
  13.421 -              end
  13.422 -            else if s' = type_guard_name then
  13.423 -              @{const True} (* ignore type predicates *)
  13.424 -            else
  13.425 -              let
  13.426 -                val new_skolem = String.isPrefix new_skolem_const_prefix s''
  13.427 -                val num_ty_args =
  13.428 -                  length us - the_default 0 (Symtab.lookup sym_tab s)
  13.429 -                val (type_us, term_us) =
  13.430 -                  chop num_ty_args us |>> append mangled_us
  13.431 -                val term_ts = map (do_term [] NONE) term_us
  13.432 -                val T =
  13.433 -                  (if not (null type_us) andalso
  13.434 -                      num_type_args thy s' = length type_us then
  13.435 -                     let val Ts = type_us |> map (typ_from_atp ctxt) in
  13.436 -                       if new_skolem then
  13.437 -                         SOME (Type_Infer.paramify_vars (tl Ts ---> hd Ts))
  13.438 -                       else if textual then
  13.439 -                         try (Sign.const_instance thy) (s', Ts)
  13.440 -                       else
  13.441 -                         NONE
  13.442 -                     end
  13.443 -                   else
  13.444 -                     NONE)
  13.445 -                  |> (fn SOME T => T
  13.446 -                       | NONE => map slack_fastype_of term_ts --->
  13.447 -                                 (case opt_T of
  13.448 -                                    SOME T => T
  13.449 -                                  | NONE => HOLogic.typeT))
  13.450 -                val t =
  13.451 -                  if new_skolem then
  13.452 -                    Var ((new_skolem_var_name_from_const s'', var_index), T)
  13.453 -                  else
  13.454 -                    Const (unproxify_const s', T)
  13.455 -              in list_comb (t, term_ts @ extra_ts) end
  13.456 -          end
  13.457 -        | NONE => (* a free or schematic variable *)
  13.458 -          let
  13.459 -            val term_ts = map (do_term [] NONE) us
  13.460 -            val ts = term_ts @ extra_ts
  13.461 -            val T =
  13.462 -              case opt_T of
  13.463 -                SOME T => map slack_fastype_of term_ts ---> T
  13.464 -              | NONE => map slack_fastype_of ts ---> HOLogic.typeT
  13.465 -            val t =
  13.466 -              case unprefix_and_unascii fixed_var_prefix s of
  13.467 -                SOME s => Free (s, T)
  13.468 -              | NONE =>
  13.469 -                case unprefix_and_unascii schematic_var_prefix s of
  13.470 -                  SOME s => Var ((s, var_index), T)
  13.471 -                | NONE =>
  13.472 -                  Var ((s |> textual ? repair_variable_name Char.toLower,
  13.473 -                        var_index), T)
  13.474 -          in list_comb (t, ts) end
  13.475 -  in do_term [] end
  13.476 -
  13.477 -fun term_from_atom ctxt textual sym_tab pos (u as ATerm (s, _)) =
  13.478 -  if String.isPrefix class_prefix s then
  13.479 -    add_type_constraint pos (type_constraint_from_term ctxt u)
  13.480 -    #> pair @{const True}
  13.481 -  else
  13.482 -    pair (term_from_atp ctxt textual sym_tab (SOME @{typ bool}) u)
  13.483 -
  13.484 -val combinator_table =
  13.485 -  [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}),
  13.486 -   (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}),
  13.487 -   (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}),
  13.488 -   (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}),
  13.489 -   (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})]
  13.490 -
  13.491 -fun uncombine_term thy =
  13.492 -  let
  13.493 -    fun aux (t1 $ t2) = betapply (pairself aux (t1, t2))
  13.494 -      | aux (Abs (s, T, t')) = Abs (s, T, aux t')
  13.495 -      | aux (t as Const (x as (s, _))) =
  13.496 -        (case AList.lookup (op =) combinator_table s of
  13.497 -           SOME thm => thm |> prop_of |> specialize_type thy x
  13.498 -                           |> Logic.dest_equals |> snd
  13.499 -         | NONE => t)
  13.500 -      | aux t = t
  13.501 -  in aux end
  13.502 -
  13.503 -(* Update schematic type variables with detected sort constraints. It's not
  13.504 -   totally clear whether this code is necessary. *)
  13.505 -fun repair_tvar_sorts (t, tvar_tab) =
  13.506 -  let
  13.507 -    fun do_type (Type (a, Ts)) = Type (a, map do_type Ts)
  13.508 -      | do_type (TVar (xi, s)) =
  13.509 -        TVar (xi, the_default s (Vartab.lookup tvar_tab xi))
  13.510 -      | do_type (TFree z) = TFree z
  13.511 -    fun do_term (Const (a, T)) = Const (a, do_type T)
  13.512 -      | do_term (Free (a, T)) = Free (a, do_type T)
  13.513 -      | do_term (Var (xi, T)) = Var (xi, do_type T)
  13.514 -      | do_term (t as Bound _) = t
  13.515 -      | do_term (Abs (a, T, t)) = Abs (a, do_type T, do_term t)
  13.516 -      | do_term (t1 $ t2) = do_term t1 $ do_term t2
  13.517 -  in t |> not (Vartab.is_empty tvar_tab) ? do_term end
  13.518 -
  13.519 -fun quantify_over_var quant_of var_s t =
  13.520 -  let
  13.521 -    val vars = [] |> Term.add_vars t |> filter (fn ((s, _), _) => s = var_s)
  13.522 -                  |> map Var
  13.523 -  in fold_rev quant_of vars t end
  13.524 -
  13.525 -(* Interpret an ATP formula as a HOL term, extracting sort constraints as they
  13.526 -   appear in the formula. *)
  13.527 -fun prop_from_atp ctxt textual sym_tab phi =
  13.528 -  let
  13.529 -    fun do_formula pos phi =
  13.530 -      case phi of
  13.531 -        AQuant (_, [], phi) => do_formula pos phi
  13.532 -      | AQuant (q, (s, _) :: xs, phi') =>
  13.533 -        do_formula pos (AQuant (q, xs, phi'))
  13.534 -        (* FIXME: TFF *)
  13.535 -        #>> quantify_over_var (case q of
  13.536 -                                 AForall => forall_of
  13.537 -                               | AExists => exists_of)
  13.538 -                              (s |> textual ? repair_variable_name Char.toLower)
  13.539 -      | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not
  13.540 -      | AConn (c, [phi1, phi2]) =>
  13.541 -        do_formula (pos |> c = AImplies ? not) phi1
  13.542 -        ##>> do_formula pos phi2
  13.543 -        #>> (case c of
  13.544 -               AAnd => s_conj
  13.545 -             | AOr => s_disj
  13.546 -             | AImplies => s_imp
  13.547 -             | AIff => s_iff
  13.548 -             | ANot => raise Fail "impossible connective")
  13.549 -      | AAtom tm => term_from_atom ctxt textual sym_tab pos tm
  13.550 -      | _ => raise FORMULA [phi]
  13.551 -  in repair_tvar_sorts (do_formula true phi Vartab.empty) end
  13.552 -
  13.553 -fun infer_formula_types ctxt =
  13.554 -  Type.constraint HOLogic.boolT
  13.555 -  #> Syntax.check_term
  13.556 -         (Proof_Context.set_mode Proof_Context.mode_schematic ctxt)
  13.557 -
  13.558 -fun uncombined_etc_prop_from_atp ctxt textual sym_tab =
  13.559 -  let val thy = Proof_Context.theory_of ctxt in
  13.560 -    prop_from_atp ctxt textual sym_tab
  13.561 -    #> textual ? uncombine_term thy #> infer_formula_types ctxt
  13.562 -  end
  13.563 -
  13.564 -(**** Translation of TSTP files to Isar proofs ****)
  13.565 -
  13.566 -fun unvarify_term (Var ((s, 0), T)) = Free (s, T)
  13.567 -  | unvarify_term t = raise TERM ("unvarify_term: non-Var", [t])
  13.568 -
  13.569 -fun decode_line sym_tab (Definition (name, phi1, phi2)) ctxt =
  13.570 -    let
  13.571 -      val thy = Proof_Context.theory_of ctxt
  13.572 -      val t1 = prop_from_atp ctxt true sym_tab phi1
  13.573 -      val vars = snd (strip_comb t1)
  13.574 -      val frees = map unvarify_term vars
  13.575 -      val unvarify_args = subst_atomic (vars ~~ frees)
  13.576 -      val t2 = prop_from_atp ctxt true sym_tab phi2
  13.577 -      val (t1, t2) =
  13.578 -        HOLogic.eq_const HOLogic.typeT $ t1 $ t2
  13.579 -        |> unvarify_args |> uncombine_term thy |> infer_formula_types ctxt
  13.580 -        |> HOLogic.dest_eq
  13.581 -    in
  13.582 -      (Definition (name, t1, t2),
  13.583 -       fold Variable.declare_term (maps Misc_Legacy.term_frees [t1, t2]) ctxt)
  13.584 -    end
  13.585 -  | decode_line sym_tab (Inference (name, u, rule, deps)) ctxt =
  13.586 -    let val t = u |> uncombined_etc_prop_from_atp ctxt true sym_tab in
  13.587 -      (Inference (name, t, rule, deps),
  13.588 -       fold Variable.declare_term (Misc_Legacy.term_frees t) ctxt)
  13.589 -    end
  13.590 -fun decode_lines ctxt sym_tab lines =
  13.591 -  fst (fold_map (decode_line sym_tab) lines ctxt)
  13.592 -
  13.593 -fun is_same_inference _ (Definition _) = false
  13.594 -  | is_same_inference t (Inference (_, t', _, _)) = t aconv t'
  13.595 -
  13.596 -(* No "real" literals means only type information (tfree_tcs, clsrel, or
  13.597 -   clsarity). *)
  13.598 -val is_only_type_information = curry (op aconv) @{term True}
  13.599 -
  13.600 -fun replace_one_dependency (old, new) dep =
  13.601 -  if is_same_atp_step dep old then new else [dep]
  13.602 -fun replace_dependencies_in_line _ (line as Definition _) = line
  13.603 -  | replace_dependencies_in_line p (Inference (name, t, rule, deps)) =
  13.604 -    Inference (name, t, rule,
  13.605 -               fold (union (op =) o replace_one_dependency p) deps [])
  13.606 -
  13.607 -(* Discard facts; consolidate adjacent lines that prove the same formula, since
  13.608 -   they differ only in type information.*)
  13.609 -fun add_line _ (line as Definition _) lines = line :: lines
  13.610 -  | add_line fact_names (Inference (name as (_, ss), t, rule, [])) lines =
  13.611 -    (* No dependencies: fact, conjecture, or (for Vampire) internal facts or
  13.612 -       definitions. *)
  13.613 -    if is_fact fact_names ss then
  13.614 -      (* Facts are not proof lines. *)
  13.615 -      if is_only_type_information t then
  13.616 -        map (replace_dependencies_in_line (name, [])) lines
  13.617 -      (* Is there a repetition? If so, replace later line by earlier one. *)
  13.618 -      else case take_prefix (not o is_same_inference t) lines of
  13.619 -        (_, []) => lines (* no repetition of proof line *)
  13.620 -      | (pre, Inference (name', _, _, _) :: post) =>
  13.621 -        pre @ map (replace_dependencies_in_line (name', [name])) post
  13.622 -      | _ => raise Fail "unexpected inference"
  13.623 -    else if is_conjecture ss then
  13.624 -      Inference (name, s_not t, rule, []) :: lines
  13.625 -    else
  13.626 -      map (replace_dependencies_in_line (name, [])) lines
  13.627 -  | add_line _ (Inference (name, t, rule, deps)) lines =
  13.628 -    (* Type information will be deleted later; skip repetition test. *)
  13.629 -    if is_only_type_information t then
  13.630 -      Inference (name, t, rule, deps) :: lines
  13.631 -    (* Is there a repetition? If so, replace later line by earlier one. *)
  13.632 -    else case take_prefix (not o is_same_inference t) lines of
  13.633 -      (* FIXME: Doesn't this code risk conflating proofs involving different
  13.634 -         types? *)
  13.635 -       (_, []) => Inference (name, t, rule, deps) :: lines
  13.636 -     | (pre, Inference (name', t', rule, _) :: post) =>
  13.637 -       Inference (name, t', rule, deps) ::
  13.638 -       pre @ map (replace_dependencies_in_line (name', [name])) post
  13.639 -     | _ => raise Fail "unexpected inference"
  13.640 -
  13.641 -(* Recursively delete empty lines (type information) from the proof. *)
  13.642 -fun add_nontrivial_line (line as Inference (name, t, _, [])) lines =
  13.643 -    if is_only_type_information t then delete_dependency name lines
  13.644 -    else line :: lines
  13.645 -  | add_nontrivial_line line lines = line :: lines
  13.646 -and delete_dependency name lines =
  13.647 -  fold_rev add_nontrivial_line
  13.648 -           (map (replace_dependencies_in_line (name, [])) lines) []
  13.649 -
  13.650 -(* ATPs sometimes reuse free variable names in the strangest ways. Removing
  13.651 -   offending lines often does the trick. *)
  13.652 -fun is_bad_free frees (Free x) = not (member (op =) frees x)
  13.653 -  | is_bad_free _ _ = false
  13.654 -
  13.655 -fun add_desired_line _ _ _ (line as Definition (name, _, _)) (j, lines) =
  13.656 -    (j, line :: map (replace_dependencies_in_line (name, [])) lines)
  13.657 -  | add_desired_line isar_shrink_factor fact_names frees
  13.658 -                     (Inference (name as (_, ss), t, rule, deps)) (j, lines) =
  13.659 -    (j + 1,
  13.660 -     if is_fact fact_names ss orelse
  13.661 -        is_conjecture ss orelse
  13.662 -        (* the last line must be kept *)
  13.663 -        j = 0 orelse
  13.664 -        (not (is_only_type_information t) andalso
  13.665 -         null (Term.add_tvars t []) andalso
  13.666 -         not (exists_subterm (is_bad_free frees) t) andalso
  13.667 -         length deps >= 2 andalso j mod isar_shrink_factor = 0 andalso
  13.668 -         (* kill next to last line, which usually results in a trivial step *)
  13.669 -         j <> 1) then
  13.670 -       Inference (name, t, rule, deps) :: lines  (* keep line *)
  13.671 -     else
  13.672 -       map (replace_dependencies_in_line (name, deps)) lines)  (* drop line *)
  13.673 -
  13.674 -(** Isar proof construction and manipulation **)
  13.675 -
  13.676 -type label = string * int
  13.677 -type facts = label list * string list
  13.678 -
  13.679 -datatype isar_qualifier = Show | Then | Moreover | Ultimately
  13.680 -
  13.681 -datatype isar_step =
  13.682 -  Fix of (string * typ) list |
  13.683 -  Let of term * term |
  13.684 -  Assume of label * term |
  13.685 -  Prove of isar_qualifier list * label * term * byline
  13.686 -and byline =
  13.687 -  By_Metis of facts |
  13.688 -  Case_Split of isar_step list list * facts
  13.689 -
  13.690 -fun add_fact_from_dependency fact_names (name as (_, ss)) =
  13.691 -  if is_fact fact_names ss then
  13.692 -    apsnd (union (op =) (map fst (resolve_fact fact_names ss)))
  13.693 -  else
  13.694 -    apfst (insert (op =) (raw_label_for_name name))
  13.695 -
  13.696 -fun repair_name "$true" = "c_True"
  13.697 -  | repair_name "$false" = "c_False"
  13.698 -  | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *)
  13.699 -  | repair_name s =
  13.700 -    if is_tptp_equal s orelse
  13.701 -       (* seen in Vampire proofs *)
  13.702 -       (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then
  13.703 -      tptp_equal
  13.704 -    else
  13.705 -      s
  13.706 -
  13.707 -(* FIXME: Still needed? Try with SPASS proofs perhaps. *)
  13.708 -val kill_duplicate_assumptions_in_proof =
  13.709 -  let
  13.710 -    fun relabel_facts subst =
  13.711 -      apfst (map (fn l => AList.lookup (op =) subst l |> the_default l))
  13.712 -    fun do_step (step as Assume (l, t)) (proof, subst, assums) =
  13.713 -        (case AList.lookup (op aconv) assums t of
  13.714 -           SOME l' => (proof, (l, l') :: subst, assums)
  13.715 -         | NONE => (step :: proof, subst, (t, l) :: assums))
  13.716 -      | do_step (Prove (qs, l, t, by)) (proof, subst, assums) =
  13.717 -        (Prove (qs, l, t,
  13.718 -                case by of
  13.719 -                  By_Metis facts => By_Metis (relabel_facts subst facts)
  13.720 -                | Case_Split (proofs, facts) =>
  13.721 -                  Case_Split (map do_proof proofs,
  13.722 -                              relabel_facts subst facts)) ::
  13.723 -         proof, subst, assums)
  13.724 -      | do_step step (proof, subst, assums) = (step :: proof, subst, assums)
  13.725 -    and do_proof proof = fold do_step proof ([], [], []) |> #1 |> rev
  13.726 -  in do_proof end
  13.727 -
  13.728 -fun used_labels_of_step (Prove (_, _, _, by)) =
  13.729 -    (case by of
  13.730 -       By_Metis (ls, _) => ls
  13.731 -     | Case_Split (proofs, (ls, _)) =>
  13.732 -       fold (union (op =) o used_labels_of) proofs ls)
  13.733 -  | used_labels_of_step _ = []
  13.734 -and used_labels_of proof = fold (union (op =) o used_labels_of_step) proof []
  13.735 -
  13.736 -fun kill_useless_labels_in_proof proof =
  13.737 -  let
  13.738 -    val used_ls = used_labels_of proof
  13.739 -    fun do_label l = if member (op =) used_ls l then l else no_label
  13.740 -    fun do_step (Assume (l, t)) = Assume (do_label l, t)
  13.741 -      | do_step (Prove (qs, l, t, by)) =
  13.742 -        Prove (qs, do_label l, t,
  13.743 -               case by of
  13.744 -                 Case_Split (proofs, facts) =>
  13.745 -                 Case_Split (map (map do_step) proofs, facts)
  13.746 -               | _ => by)
  13.747 -      | do_step step = step
  13.748 -  in map do_step proof end
  13.749 -
  13.750 -fun prefix_for_depth n = replicate_string (n + 1)
  13.751 -
  13.752 -val relabel_proof =
  13.753 -  let
  13.754 -    fun aux _ _ _ [] = []
  13.755 -      | aux subst depth (next_assum, next_fact) (Assume (l, t) :: proof) =
  13.756 -        if l = no_label then
  13.757 -          Assume (l, t) :: aux subst depth (next_assum, next_fact) proof
  13.758 -        else
  13.759 -          let val l' = (prefix_for_depth depth assum_prefix, next_assum) in
  13.760 -            Assume (l', t) ::
  13.761 -            aux ((l, l') :: subst) depth (next_assum + 1, next_fact) proof
  13.762 -          end
  13.763 -      | aux subst depth (next_assum, next_fact)
  13.764 -            (Prove (qs, l, t, by) :: proof) =
  13.765 -        let
  13.766 -          val (l', subst, next_fact) =
  13.767 -            if l = no_label then
  13.768 -              (l, subst, next_fact)
  13.769 -            else
  13.770 -              let
  13.771 -                val l' = (prefix_for_depth depth have_prefix, next_fact)
  13.772 -              in (l', (l, l') :: subst, next_fact + 1) end
  13.773 -          val relabel_facts =
  13.774 -            apfst (maps (the_list o AList.lookup (op =) subst))
  13.775 -          val by =
  13.776 -            case by of
  13.777 -              By_Metis facts => By_Metis (relabel_facts facts)
  13.778 -            | Case_Split (proofs, facts) =>
  13.779 -              Case_Split (map (aux subst (depth + 1) (1, 1)) proofs,
  13.780 -                          relabel_facts facts)
  13.781 -        in
  13.782 -          Prove (qs, l', t, by) :: aux subst depth (next_assum, next_fact) proof
  13.783 -        end
  13.784 -      | aux subst depth nextp (step :: proof) =
  13.785 -        step :: aux subst depth nextp proof
  13.786 -  in aux [] 0 (1, 1) end
  13.787 -
  13.788 -fun string_for_proof ctxt0 type_enc lam_trans i n =
  13.789 -  let
  13.790 -    val ctxt =
  13.791 -      ctxt0 |> Config.put show_free_types false
  13.792 -            |> Config.put show_types true
  13.793 -            |> Config.put show_sorts true
  13.794 -    fun fix_print_mode f x =
  13.795 -      Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN)
  13.796 -                               (print_mode_value ())) f x
  13.797 -    fun do_indent ind = replicate_string (ind * indent_size) " "
  13.798 -    fun do_free (s, T) =
  13.799 -      maybe_quote s ^ " :: " ^
  13.800 -      maybe_quote (fix_print_mode (Syntax.string_of_typ ctxt) T)
  13.801 -    fun do_label l = if l = no_label then "" else string_for_label l ^ ": "
  13.802 -    fun do_have qs =
  13.803 -      (if member (op =) qs Moreover then "moreover " else "") ^
  13.804 -      (if member (op =) qs Ultimately then "ultimately " else "") ^
  13.805 -      (if member (op =) qs Then then
  13.806 -         if member (op =) qs Show then "thus" else "hence"
  13.807 -       else
  13.808 -         if member (op =) qs Show then "show" else "have")
  13.809 -    val do_term = maybe_quote o fix_print_mode (Syntax.string_of_term ctxt)
  13.810 -    val reconstr = Metis (type_enc, lam_trans)
  13.811 -    fun do_facts (ls, ss) =
  13.812 -      reconstructor_command reconstr 1 1
  13.813 -          (ls |> sort_distinct (prod_ord string_ord int_ord),
  13.814 -           ss |> sort_distinct string_ord)
  13.815 -    and do_step ind (Fix xs) =
  13.816 -        do_indent ind ^ "fix " ^ space_implode " and " (map do_free xs) ^ "\n"
  13.817 -      | do_step ind (Let (t1, t2)) =
  13.818 -        do_indent ind ^ "let " ^ do_term t1 ^ " = " ^ do_term t2 ^ "\n"
  13.819 -      | do_step ind (Assume (l, t)) =
  13.820 -        do_indent ind ^ "assume " ^ do_label l ^ do_term t ^ "\n"
  13.821 -      | do_step ind (Prove (qs, l, t, By_Metis facts)) =
  13.822 -        do_indent ind ^ do_have qs ^ " " ^
  13.823 -        do_label l ^ do_term t ^ " " ^ do_facts facts ^ "\n"
  13.824 -      | do_step ind (Prove (qs, l, t, Case_Split (proofs, facts))) =
  13.825 -        implode (map (prefix (do_indent ind ^ "moreover\n") o do_block ind)
  13.826 -                     proofs) ^
  13.827 -        do_indent ind ^ do_have qs ^ " " ^ do_label l ^ do_term t ^ " " ^
  13.828 -        do_facts facts ^ "\n"
  13.829 -    and do_steps prefix suffix ind steps =
  13.830 -      let val s = implode (map (do_step ind) steps) in
  13.831 -        replicate_string (ind * indent_size - size prefix) " " ^ prefix ^
  13.832 -        String.extract (s, ind * indent_size,
  13.833 -                        SOME (size s - ind * indent_size - 1)) ^
  13.834 -        suffix ^ "\n"
  13.835 -      end
  13.836 -    and do_block ind proof = do_steps "{ " " }" (ind + 1) proof
  13.837 -    (* One-step proofs are pointless; better use the Metis one-liner
  13.838 -       directly. *)
  13.839 -    and do_proof [Prove (_, _, _, By_Metis _)] = ""
  13.840 -      | do_proof proof =
  13.841 -        (if i <> 1 then "prefer " ^ string_of_int i ^ "\n" else "") ^
  13.842 -        do_indent 0 ^ "proof -\n" ^ do_steps "" "" 1 proof ^ do_indent 0 ^
  13.843 -        (if n <> 1 then "next" else "qed")
  13.844 -  in do_proof end
  13.845 -
  13.846 -fun isar_proof_text ctxt isar_proof_requested
  13.847 -        (debug, isar_shrink_factor, pool, fact_names, sym_tab, atp_proof, goal)
  13.848 -        (one_line_params as (_, _, _, _, subgoal, subgoal_count)) =
  13.849 -  let
  13.850 -    val isar_shrink_factor =
  13.851 -      (if isar_proof_requested then 1 else 2) * isar_shrink_factor
  13.852 -    val (params, hyp_ts, concl_t) = strip_subgoal ctxt goal subgoal
  13.853 -    val frees = fold Term.add_frees (concl_t :: hyp_ts) []
  13.854 -    val one_line_proof = one_line_proof_text one_line_params
  13.855 -    val type_enc =
  13.856 -      if is_typed_helper_used_in_atp_proof atp_proof then full_typesN
  13.857 -      else partial_typesN
  13.858 -    val lam_trans = lam_trans_from_atp_proof atp_proof metis_default_lam_trans
  13.859 -
  13.860 -    fun isar_proof_of () =
  13.861 -      let
  13.862 -        val atp_proof =
  13.863 -          atp_proof
  13.864 -          |> clean_up_atp_proof_dependencies
  13.865 -          |> nasty_atp_proof pool
  13.866 -          |> map_term_names_in_atp_proof repair_name
  13.867 -          |> decode_lines ctxt sym_tab
  13.868 -          |> rpair [] |-> fold_rev (add_line fact_names)
  13.869 -          |> rpair [] |-> fold_rev add_nontrivial_line
  13.870 -          |> rpair (0, [])
  13.871 -          |-> fold_rev (add_desired_line isar_shrink_factor fact_names frees)
  13.872 -          |> snd
  13.873 -        val conj_name = conjecture_prefix ^ string_of_int (length hyp_ts)
  13.874 -        val conjs =
  13.875 -          atp_proof
  13.876 -          |> map_filter (fn Inference (name as (_, ss), _, _, []) =>
  13.877 -                            if member (op =) ss conj_name then SOME name else NONE
  13.878 -                          | _ => NONE)
  13.879 -        fun dep_of_step (Definition _) = NONE
  13.880 -          | dep_of_step (Inference (name, _, _, from)) = SOME (from, name)
  13.881 -        val ref_graph = atp_proof |> map_filter dep_of_step |> make_ref_graph
  13.882 -        val axioms = axioms_of_ref_graph ref_graph conjs
  13.883 -        val tainted = tainted_atoms_of_ref_graph ref_graph conjs
  13.884 -        val props =
  13.885 -          Symtab.empty
  13.886 -          |> fold (fn Definition _ => I (* FIXME *)
  13.887 -                    | Inference ((s, _), t, _, _) =>
  13.888 -                      Symtab.update_new (s,
  13.889 -                          t |> member (op = o apsnd fst) tainted s ? s_not))
  13.890 -                  atp_proof
  13.891 -        (* FIXME: add "fold_rev forall_of (map Var (Term.add_vars t []))"? *)
  13.892 -        fun prop_of_clause c =
  13.893 -          fold (curry s_disj) (map_filter (Symtab.lookup props o fst) c)
  13.894 -               @{term False}
  13.895 -        fun label_of_clause c = (space_implode "___" (map fst c), 0)
  13.896 -        fun maybe_show outer c =
  13.897 -          (outer andalso length c = 1 andalso subset (op =) (c, conjs))
  13.898 -          ? cons Show
  13.899 -        fun do_have outer qs (gamma, c) =
  13.900 -          Prove (maybe_show outer c qs, label_of_clause c, prop_of_clause c,
  13.901 -                 By_Metis (fold (add_fact_from_dependency fact_names
  13.902 -                                 o the_single) gamma ([], [])))
  13.903 -        fun do_inf outer (Have z) = do_have outer [] z
  13.904 -          | do_inf outer (Hence z) = do_have outer [Then] z
  13.905 -          | do_inf outer (Cases cases) =
  13.906 -            let val c = succedent_of_cases cases in
  13.907 -              Prove (maybe_show outer c [Ultimately], label_of_clause c,
  13.908 -                     prop_of_clause c,
  13.909 -                     Case_Split (map (do_case false) cases, ([], [])))
  13.910 -            end
  13.911 -        and do_case outer (c, infs) =
  13.912 -          Assume (label_of_clause c, prop_of_clause c) ::
  13.913 -          map (do_inf outer) infs
  13.914 -        val isar_proof =
  13.915 -          (if null params then [] else [Fix params]) @
  13.916 -          (ref_graph
  13.917 -           |> redirect_graph axioms tainted
  13.918 -           |> chain_direct_proof
  13.919 -           |> map (do_inf true)
  13.920 -           |> kill_duplicate_assumptions_in_proof
  13.921 -           |> kill_useless_labels_in_proof
  13.922 -           |> relabel_proof)
  13.923 -          |> string_for_proof ctxt type_enc lam_trans subgoal subgoal_count
  13.924 -      in
  13.925 -        case isar_proof of
  13.926 -          "" =>
  13.927 -          if isar_proof_requested then
  13.928 -            "\nNo structured proof available (proof too short)."
  13.929 -          else
  13.930 -            ""
  13.931 -        | _ =>
  13.932 -          "\n\n" ^ (if isar_proof_requested then "Structured proof"
  13.933 -                    else "Perhaps this will work") ^
  13.934 -          ":\n" ^ Markup.markup Isabelle_Markup.sendback isar_proof
  13.935 -      end
  13.936 -    val isar_proof =
  13.937 -      if debug then
  13.938 -        isar_proof_of ()
  13.939 -      else case try isar_proof_of () of
  13.940 -        SOME s => s
  13.941 -      | NONE => if isar_proof_requested then
  13.942 -                  "\nWarning: The Isar proof construction failed."
  13.943 -                else
  13.944 -                  ""
  13.945 -  in one_line_proof ^ isar_proof end
  13.946 -
  13.947 -fun proof_text ctxt isar_proof isar_params
  13.948 -               (one_line_params as (preplay, _, _, _, _, _)) =
  13.949 -  (if case preplay of Failed_to_Play _ => true | _ => isar_proof then
  13.950 -     isar_proof_text ctxt isar_proof isar_params
  13.951 -   else
  13.952 -     one_line_proof_text) one_line_params
  13.953 -
  13.954 -end;
    14.1 --- a/src/HOL/Tools/ATP/atp_redirect.ML	Mon Jan 23 17:40:31 2012 +0100
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,223 +0,0 @@
    14.4 -(*  Title:      HOL/Tools/ATP/atp_redirect.ML
    14.5 -    Author:     Jasmin Blanchette, TU Muenchen
    14.6 -
    14.7 -Transformation of a proof by contradiction into a direct proof.
    14.8 -*)
    14.9 -
   14.10 -signature ATP_ATOM =
   14.11 -sig
   14.12 -  type key
   14.13 -  val ord : key * key -> order
   14.14 -  val string_of : key -> string
   14.15 -end;
   14.16 -
   14.17 -signature ATP_REDIRECT =
   14.18 -sig
   14.19 -  type atom
   14.20 -
   14.21 -  structure Atom_Graph : GRAPH
   14.22 -
   14.23 -  type ref_sequent = atom list * atom
   14.24 -  type ref_graph = unit Atom_Graph.T
   14.25 -
   14.26 -  type clause = atom list
   14.27 -  type direct_sequent = atom list * clause
   14.28 -  type direct_graph = unit Atom_Graph.T
   14.29 -
   14.30 -  type rich_sequent = clause list * clause
   14.31 -
   14.32 -  datatype direct_inference =
   14.33 -    Have of rich_sequent |
   14.34 -    Hence of rich_sequent |
   14.35 -    Cases of (clause * direct_inference list) list
   14.36 -
   14.37 -  type direct_proof = direct_inference list
   14.38 -
   14.39 -  val make_ref_graph : (atom list * atom) list -> ref_graph
   14.40 -  val axioms_of_ref_graph : ref_graph -> atom list -> atom list
   14.41 -  val tainted_atoms_of_ref_graph : ref_graph -> atom list -> atom list
   14.42 -  val sequents_of_ref_graph : ref_graph -> ref_sequent list
   14.43 -  val redirect_sequent : atom list -> atom -> ref_sequent -> direct_sequent
   14.44 -  val direct_graph : direct_sequent list -> direct_graph
   14.45 -  val redirect_graph : atom list -> atom list -> ref_graph -> direct_proof
   14.46 -  val succedent_of_cases : (clause * direct_inference list) list -> clause
   14.47 -  val chain_direct_proof : direct_proof -> direct_proof
   14.48 -  val string_of_direct_proof : direct_proof -> string
   14.49 -end;
   14.50 -
   14.51 -functor ATP_Redirect(Atom : ATP_ATOM): ATP_REDIRECT =
   14.52 -struct
   14.53 -
   14.54 -type atom = Atom.key
   14.55 -
   14.56 -structure Atom_Graph = Graph(Atom)
   14.57 -
   14.58 -type ref_sequent = atom list * atom
   14.59 -type ref_graph = unit Atom_Graph.T
   14.60 -
   14.61 -type clause = atom list
   14.62 -type direct_sequent = atom list * clause
   14.63 -type direct_graph = unit Atom_Graph.T
   14.64 -
   14.65 -type rich_sequent = clause list * clause
   14.66 -
   14.67 -datatype direct_inference =
   14.68 -  Have of rich_sequent |
   14.69 -  Hence of rich_sequent |
   14.70 -  Cases of (clause * direct_inference list) list
   14.71 -
   14.72 -type direct_proof = direct_inference list
   14.73 -
   14.74 -fun atom_eq p = (Atom.ord p = EQUAL)
   14.75 -fun clause_eq (c, d) = (length c = length d andalso forall atom_eq (c ~~ d))
   14.76 -fun direct_sequent_eq ((gamma, c), (delta, d)) =
   14.77 -  clause_eq (gamma, delta) andalso clause_eq (c, d)
   14.78 -
   14.79 -fun make_ref_graph infers =
   14.80 -  let
   14.81 -    fun add_edge to from =
   14.82 -      Atom_Graph.default_node (from, ())
   14.83 -      #> Atom_Graph.default_node (to, ())
   14.84 -      #> Atom_Graph.add_edge_acyclic (from, to)
   14.85 -    fun add_infer (froms, to) = fold (add_edge to) froms
   14.86 -  in Atom_Graph.empty |> fold add_infer infers end
   14.87 -
   14.88 -fun axioms_of_ref_graph ref_graph conjs =
   14.89 -  subtract atom_eq conjs (Atom_Graph.minimals ref_graph)
   14.90 -fun tainted_atoms_of_ref_graph ref_graph = Atom_Graph.all_succs ref_graph
   14.91 -
   14.92 -fun sequents_of_ref_graph ref_graph =
   14.93 -  map (`(Atom_Graph.immediate_preds ref_graph))
   14.94 -      (filter_out (Atom_Graph.is_minimal ref_graph) (Atom_Graph.keys ref_graph))
   14.95 -
   14.96 -fun redirect_sequent tainted bot (gamma, c) =
   14.97 -  if member atom_eq tainted c then
   14.98 -    gamma |> List.partition (not o member atom_eq tainted)
   14.99 -          |>> not (atom_eq (c, bot)) ? cons c
  14.100 -  else
  14.101 -    (gamma, [c])
  14.102 -
  14.103 -fun direct_graph seqs =
  14.104 -  let
  14.105 -    fun add_edge from to =
  14.106 -      Atom_Graph.default_node (from, ())
  14.107 -      #> Atom_Graph.default_node (to, ())
  14.108 -      #> Atom_Graph.add_edge_acyclic (from, to)
  14.109 -    fun add_seq (gamma, c) = fold (fn l => fold (add_edge l) c) gamma
  14.110 -  in Atom_Graph.empty |> fold add_seq seqs end
  14.111 -
  14.112 -fun disj cs = fold (union atom_eq) cs [] |> sort Atom.ord
  14.113 -
  14.114 -fun succedent_of_inference (Have (_, c)) = c
  14.115 -  | succedent_of_inference (Hence (_, c)) = c
  14.116 -  | succedent_of_inference (Cases cases) = succedent_of_cases cases
  14.117 -and succedent_of_case (c, []) = c
  14.118 -  | succedent_of_case (_, infs) = succedent_of_inference (List.last infs)
  14.119 -and succedent_of_cases cases = disj (map succedent_of_case cases)
  14.120 -
  14.121 -fun dest_Have (Have z) = z
  14.122 -  | dest_Have _ = raise Fail "non-Have"
  14.123 -
  14.124 -fun enrich_Have nontrivs trivs (cs, c) =
  14.125 -  (cs |> map (fn c => if member clause_eq nontrivs c then disj (c :: trivs)
  14.126 -                      else c),
  14.127 -   disj (c :: trivs))
  14.128 -  |> Have
  14.129 -
  14.130 -fun s_cases cases =
  14.131 -  case cases |> List.partition (null o snd) of
  14.132 -    (trivs, nontrivs as [(nontriv0, proof)]) =>
  14.133 -    if forall (can dest_Have) proof then
  14.134 -      let val seqs = proof |> map dest_Have in
  14.135 -        seqs |> map (enrich_Have (nontriv0 :: map snd seqs) (map fst trivs))
  14.136 -      end
  14.137 -    else
  14.138 -      [Cases nontrivs]
  14.139 -  | (_, nontrivs) => [Cases nontrivs]
  14.140 -
  14.141 -fun descendants direct_graph =
  14.142 -  these o try (Atom_Graph.all_succs direct_graph) o single
  14.143 -
  14.144 -fun zones_of 0 _ = []
  14.145 -  | zones_of n (bs :: bss) =
  14.146 -    (fold (subtract atom_eq) bss) bs :: zones_of (n - 1) (bss @ [bs])
  14.147 -
  14.148 -fun redirect_graph axioms tainted ref_graph =
  14.149 -  let
  14.150 -    val [bot] = Atom_Graph.maximals ref_graph
  14.151 -    val seqs =
  14.152 -      map (redirect_sequent tainted bot) (sequents_of_ref_graph ref_graph)
  14.153 -    val direct_graph = direct_graph seqs
  14.154 -
  14.155 -    fun redirect c proved seqs =
  14.156 -      if null seqs then
  14.157 -        []
  14.158 -      else if length c < 2 then
  14.159 -        let
  14.160 -          val proved = c @ proved
  14.161 -          val provable =
  14.162 -            filter (fn (gamma, _) => subset atom_eq (gamma, proved)) seqs
  14.163 -          val horn_provable = filter (fn (_, [_]) => true | _ => false) provable
  14.164 -          val seq as (gamma, c) = hd (horn_provable @ provable)
  14.165 -        in
  14.166 -          Have (map single gamma, c) ::
  14.167 -          redirect c proved (filter (curry (not o direct_sequent_eq) seq) seqs)
  14.168 -        end
  14.169 -      else
  14.170 -        let
  14.171 -          fun subsequents seqs zone =
  14.172 -            filter (fn (gamma, _) => subset atom_eq (gamma, zone @ proved)) seqs
  14.173 -          val zones = zones_of (length c) (map (descendants direct_graph) c)
  14.174 -          val subseqss = map (subsequents seqs) zones
  14.175 -          val seqs = fold (subtract direct_sequent_eq) subseqss seqs
  14.176 -          val cases =
  14.177 -            map2 (fn l => fn subseqs => ([l], redirect [l] proved subseqs))
  14.178 -                 c subseqss
  14.179 -        in s_cases cases @ redirect (succedent_of_cases cases) proved seqs end
  14.180 -  in redirect [] axioms seqs end
  14.181 -
  14.182 -val chain_direct_proof =
  14.183 -  let
  14.184 -    fun chain_inf cl0 (seq as Have (cs, c)) =
  14.185 -        if member clause_eq cs cl0 then
  14.186 -          Hence (filter_out (curry clause_eq cl0) cs, c)
  14.187 -        else
  14.188 -          seq
  14.189 -      | chain_inf _ (Cases cases) = Cases (map chain_case cases)
  14.190 -    and chain_case (c, is) = (c, chain_proof (SOME c) is)
  14.191 -    and chain_proof _ [] = []
  14.192 -      | chain_proof (SOME prev) (i :: is) =
  14.193 -        chain_inf prev i :: chain_proof (SOME (succedent_of_inference i)) is
  14.194 -      | chain_proof _ (i :: is) =
  14.195 -        i :: chain_proof (SOME (succedent_of_inference i)) is
  14.196 -  in chain_proof NONE end
  14.197 -
  14.198 -fun indent 0 = ""
  14.199 -  | indent n = "  " ^ indent (n - 1)
  14.200 -
  14.201 -fun string_of_clause [] = "\<bottom>"
  14.202 -  | string_of_clause ls = space_implode " \<or> " (map Atom.string_of ls)
  14.203 -
  14.204 -fun string_of_rich_sequent ch ([], c) = ch ^ " " ^ string_of_clause c
  14.205 -  | string_of_rich_sequent ch (cs, c) =
  14.206 -    commas (map string_of_clause cs) ^ " " ^ ch ^ " " ^ string_of_clause c
  14.207 -
  14.208 -fun string_of_case depth (c, proof) =
  14.209 -  indent (depth + 1) ^ "[" ^ string_of_clause c ^ "]"
  14.210 -  |> not (null proof) ? suffix ("\n" ^ string_of_subproof (depth + 1) proof)
  14.211 -
  14.212 -and string_of_inference depth (Have seq) =
  14.213 -    indent depth ^ string_of_rich_sequent "\<triangleright>" seq
  14.214 -  | string_of_inference depth (Hence seq) =
  14.215 -    indent depth ^ string_of_rich_sequent "\<guillemotright>" seq
  14.216 -  | string_of_inference depth (Cases cases) =
  14.217 -    indent depth ^ "[\n" ^
  14.218 -    space_implode ("\n" ^ indent depth ^ "|\n")
  14.219 -                  (map (string_of_case depth) cases) ^ "\n" ^
  14.220 -    indent depth ^ "]"
  14.221 -
  14.222 -and string_of_subproof depth = cat_lines o map (string_of_inference depth)
  14.223 -
  14.224 -val string_of_direct_proof = string_of_subproof 0
  14.225 -
  14.226 -end;
    15.1 --- a/src/HOL/Tools/ATP/atp_systems.ML	Mon Jan 23 17:40:31 2012 +0100
    15.2 +++ b/src/HOL/Tools/ATP/atp_systems.ML	Mon Jan 23 17:40:32 2012 +0100
    15.3 @@ -71,7 +71,7 @@
    15.4  
    15.5  open ATP_Problem
    15.6  open ATP_Proof
    15.7 -open ATP_Translate
    15.8 +open ATP_Problem_Generate
    15.9  
   15.10  (* ATP configuration *)
   15.11  
    16.1 --- a/src/HOL/Tools/ATP/atp_translate.ML	Mon Jan 23 17:40:31 2012 +0100
    16.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.3 @@ -1,2557 +0,0 @@
    16.4 -(*  Title:      HOL/Tools/ATP/atp_translate.ML
    16.5 -    Author:     Fabian Immler, TU Muenchen
    16.6 -    Author:     Makarius
    16.7 -    Author:     Jasmin Blanchette, TU Muenchen
    16.8 -
    16.9 -Translation of HOL to FOL for Metis and Sledgehammer.
   16.10 -*)
   16.11 -
   16.12 -signature ATP_TRANSLATE =
   16.13 -sig
   16.14 -  type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term
   16.15 -  type connective = ATP_Problem.connective
   16.16 -  type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula
   16.17 -  type atp_format = ATP_Problem.atp_format
   16.18 -  type formula_kind = ATP_Problem.formula_kind
   16.19 -  type 'a problem = 'a ATP_Problem.problem
   16.20 -
   16.21 -  datatype locality =
   16.22 -    General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained
   16.23 -
   16.24 -  datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic
   16.25 -  datatype strictness = Strict | Non_Strict
   16.26 -  datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars
   16.27 -  datatype type_level =
   16.28 -    All_Types |
   16.29 -    Noninf_Nonmono_Types of strictness * granularity |
   16.30 -    Fin_Nonmono_Types of granularity |
   16.31 -    Const_Arg_Types |
   16.32 -    No_Types
   16.33 -  type type_enc
   16.34 -
   16.35 -  val type_tag_idempotence : bool Config.T
   16.36 -  val type_tag_arguments : bool Config.T
   16.37 -  val no_lamsN : string
   16.38 -  val hide_lamsN : string
   16.39 -  val lam_liftingN : string
   16.40 -  val combinatorsN : string
   16.41 -  val hybrid_lamsN : string
   16.42 -  val keep_lamsN : string
   16.43 -  val schematic_var_prefix : string
   16.44 -  val fixed_var_prefix : string
   16.45 -  val tvar_prefix : string
   16.46 -  val tfree_prefix : string
   16.47 -  val const_prefix : string
   16.48 -  val type_const_prefix : string
   16.49 -  val class_prefix : string
   16.50 -  val lam_lifted_prefix : string
   16.51 -  val lam_lifted_mono_prefix : string
   16.52 -  val lam_lifted_poly_prefix : string
   16.53 -  val skolem_const_prefix : string
   16.54 -  val old_skolem_const_prefix : string
   16.55 -  val new_skolem_const_prefix : string
   16.56 -  val combinator_prefix : string
   16.57 -  val type_decl_prefix : string
   16.58 -  val sym_decl_prefix : string
   16.59 -  val guards_sym_formula_prefix : string
   16.60 -  val tags_sym_formula_prefix : string
   16.61 -  val fact_prefix : string
   16.62 -  val conjecture_prefix : string
   16.63 -  val helper_prefix : string
   16.64 -  val class_rel_clause_prefix : string
   16.65 -  val arity_clause_prefix : string
   16.66 -  val tfree_clause_prefix : string
   16.67 -  val lam_fact_prefix : string
   16.68 -  val typed_helper_suffix : string
   16.69 -  val untyped_helper_suffix : string
   16.70 -  val type_tag_idempotence_helper_name : string
   16.71 -  val predicator_name : string
   16.72 -  val app_op_name : string
   16.73 -  val type_guard_name : string
   16.74 -  val type_tag_name : string
   16.75 -  val simple_type_prefix : string
   16.76 -  val prefixed_predicator_name : string
   16.77 -  val prefixed_app_op_name : string
   16.78 -  val prefixed_type_tag_name : string
   16.79 -  val ascii_of : string -> string
   16.80 -  val unascii_of : string -> string
   16.81 -  val unprefix_and_unascii : string -> string -> string option
   16.82 -  val proxy_table : (string * (string * (thm * (string * string)))) list
   16.83 -  val proxify_const : string -> (string * string) option
   16.84 -  val invert_const : string -> string
   16.85 -  val unproxify_const : string -> string
   16.86 -  val new_skolem_var_name_from_const : string -> string
   16.87 -  val atp_irrelevant_consts : string list
   16.88 -  val atp_schematic_consts_of : term -> typ list Symtab.table
   16.89 -  val is_type_enc_higher_order : type_enc -> bool
   16.90 -  val polymorphism_of_type_enc : type_enc -> polymorphism
   16.91 -  val level_of_type_enc : type_enc -> type_level
   16.92 -  val is_type_enc_quasi_sound : type_enc -> bool
   16.93 -  val is_type_enc_fairly_sound : type_enc -> bool
   16.94 -  val type_enc_from_string : strictness -> string -> type_enc
   16.95 -  val adjust_type_enc : atp_format -> type_enc -> type_enc
   16.96 -  val mk_aconns :
   16.97 -    connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula
   16.98 -  val unmangled_const : string -> string * (string, 'b) ho_term list
   16.99 -  val unmangled_const_name : string -> string
  16.100 -  val helper_table : ((string * bool) * thm list) list
  16.101 -  val trans_lams_from_string :
  16.102 -    Proof.context -> type_enc -> string -> term list -> term list * term list
  16.103 -  val factsN : string
  16.104 -  val prepare_atp_problem :
  16.105 -    Proof.context -> atp_format -> formula_kind -> formula_kind -> type_enc
  16.106 -    -> bool -> string -> bool -> bool -> term list -> term
  16.107 -    -> ((string * locality) * term) list
  16.108 -    -> string problem * string Symtab.table * (string * locality) list vector
  16.109 -       * (string * term) list * int Symtab.table
  16.110 -  val atp_problem_weights : string problem -> (string * real) list
  16.111 -end;
  16.112 -
  16.113 -structure ATP_Translate : ATP_TRANSLATE =
  16.114 -struct
  16.115 -
  16.116 -open ATP_Util
  16.117 -open ATP_Problem
  16.118 -
  16.119 -type name = string * string
  16.120 -
  16.121 -val type_tag_idempotence =
  16.122 -  Attrib.setup_config_bool @{binding atp_type_tag_idempotence} (K false)
  16.123 -val type_tag_arguments =
  16.124 -  Attrib.setup_config_bool @{binding atp_type_tag_arguments} (K false)
  16.125 -
  16.126 -val no_lamsN = "no_lams" (* used internally; undocumented *)
  16.127 -val hide_lamsN = "hide_lams"
  16.128 -val lam_liftingN = "lam_lifting"
  16.129 -val combinatorsN = "combinators"
  16.130 -val hybrid_lamsN = "hybrid_lams"
  16.131 -val keep_lamsN = "keep_lams"
  16.132 -
  16.133 -(* It's still unclear whether all TFF1 implementations will support type
  16.134 -   signatures such as "!>[A : $tType] : $o", with ghost type variables. *)
  16.135 -val avoid_first_order_ghost_type_vars = false
  16.136 -
  16.137 -val bound_var_prefix = "B_"
  16.138 -val all_bound_var_prefix = "BA_"
  16.139 -val exist_bound_var_prefix = "BE_"
  16.140 -val schematic_var_prefix = "V_"
  16.141 -val fixed_var_prefix = "v_"
  16.142 -val tvar_prefix = "T_"
  16.143 -val tfree_prefix = "t_"
  16.144 -val const_prefix = "c_"
  16.145 -val type_const_prefix = "tc_"
  16.146 -val simple_type_prefix = "s_"
  16.147 -val class_prefix = "cl_"
  16.148 -
  16.149 -(* Freshness almost guaranteed! *)
  16.150 -val atp_weak_prefix = "ATP:"
  16.151 -
  16.152 -val lam_lifted_prefix = atp_weak_prefix ^ "Lam"
  16.153 -val lam_lifted_mono_prefix = lam_lifted_prefix ^ "m"
  16.154 -val lam_lifted_poly_prefix = lam_lifted_prefix ^ "p"
  16.155 -
  16.156 -val skolem_const_prefix = "ATP" ^ Long_Name.separator ^ "Sko"
  16.157 -val old_skolem_const_prefix = skolem_const_prefix ^ "o"
  16.158 -val new_skolem_const_prefix = skolem_const_prefix ^ "n"
  16.159 -
  16.160 -val combinator_prefix = "COMB"
  16.161 -
  16.162 -val type_decl_prefix = "ty_"
  16.163 -val sym_decl_prefix = "sy_"
  16.164 -val guards_sym_formula_prefix = "gsy_"
  16.165 -val tags_sym_formula_prefix = "tsy_"
  16.166 -val fact_prefix = "fact_"
  16.167 -val conjecture_prefix = "conj_"
  16.168 -val helper_prefix = "help_"
  16.169 -val class_rel_clause_prefix = "clar_"
  16.170 -val arity_clause_prefix = "arity_"
  16.171 -val tfree_clause_prefix = "tfree_"
  16.172 -
  16.173 -val lam_fact_prefix = "ATP.lambda_"
  16.174 -val typed_helper_suffix = "_T"
  16.175 -val untyped_helper_suffix = "_U"
  16.176 -val type_tag_idempotence_helper_name = helper_prefix ^ "ti_idem"
  16.177 -
  16.178 -val predicator_name = "pp"
  16.179 -val app_op_name = "aa"
  16.180 -val type_guard_name = "gg"
  16.181 -val type_tag_name = "tt"
  16.182 -
  16.183 -val prefixed_predicator_name = const_prefix ^ predicator_name
  16.184 -val prefixed_app_op_name = const_prefix ^ app_op_name
  16.185 -val prefixed_type_tag_name = const_prefix ^ type_tag_name
  16.186 -
  16.187 -(*Escaping of special characters.
  16.188 -  Alphanumeric characters are left unchanged.
  16.189 -  The character _ goes to __
  16.190 -  Characters in the range ASCII space to / go to _A to _P, respectively.
  16.191 -  Other characters go to _nnn where nnn is the decimal ASCII code.*)
  16.192 -val upper_a_minus_space = Char.ord #"A" - Char.ord #" "
  16.193 -
  16.194 -fun stringN_of_int 0 _ = ""
  16.195 -  | stringN_of_int k n =
  16.196 -    stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10)
  16.197 -
  16.198 -fun ascii_of_char c =
  16.199 -  if Char.isAlphaNum c then
  16.200 -    String.str c
  16.201 -  else if c = #"_" then
  16.202 -    "__"
  16.203 -  else if #" " <= c andalso c <= #"/" then
  16.204 -    "_" ^ String.str (Char.chr (Char.ord c + upper_a_minus_space))
  16.205 -  else
  16.206 -    (* fixed width, in case more digits follow *)
  16.207 -    "_" ^ stringN_of_int 3 (Char.ord c)
  16.208 -
  16.209 -val ascii_of = String.translate ascii_of_char
  16.210 -
  16.211 -(** Remove ASCII armoring from names in proof files **)
  16.212 -
  16.213 -(* We don't raise error exceptions because this code can run inside a worker
  16.214 -   thread. Also, the errors are impossible. *)
  16.215 -val unascii_of =
  16.216 -  let
  16.217 -    fun un rcs [] = String.implode(rev rcs)
  16.218 -      | un rcs [#"_"] = un (#"_" :: rcs) [] (* ERROR *)
  16.219 -        (* Three types of _ escapes: __, _A to _P, _nnn *)
  16.220 -      | un rcs (#"_" :: #"_" :: cs) = un (#"_" :: rcs) cs
  16.221 -      | un rcs (#"_" :: c :: cs) =
  16.222 -        if #"A" <= c andalso c<= #"P" then
  16.223 -          (* translation of #" " to #"/" *)
  16.224 -          un (Char.chr (Char.ord c - upper_a_minus_space) :: rcs) cs
  16.225 -        else
  16.226 -          let val digits = List.take (c :: cs, 3) handle General.Subscript => [] in
  16.227 -            case Int.fromString (String.implode digits) of
  16.228 -              SOME n => un (Char.chr n :: rcs) (List.drop (cs, 2))
  16.229 -            | NONE => un (c :: #"_" :: rcs) cs (* ERROR *)
  16.230 -          end
  16.231 -      | un rcs (c :: cs) = un (c :: rcs) cs
  16.232 -  in un [] o String.explode end
  16.233 -
  16.234 -(* If string s has the prefix s1, return the result of deleting it,
  16.235 -   un-ASCII'd. *)
  16.236 -fun unprefix_and_unascii s1 s =
  16.237 -  if String.isPrefix s1 s then
  16.238 -    SOME (unascii_of (String.extract (s, size s1, NONE)))
  16.239 -  else
  16.240 -    NONE
  16.241 -
  16.242 -val proxy_table =
  16.243 -  [("c_False", (@{const_name False}, (@{thm fFalse_def},
  16.244 -       ("fFalse", @{const_name ATP.fFalse})))),
  16.245 -   ("c_True", (@{const_name True}, (@{thm fTrue_def},
  16.246 -       ("fTrue", @{const_name ATP.fTrue})))),
  16.247 -   ("c_Not", (@{const_name Not}, (@{thm fNot_def},
  16.248 -       ("fNot", @{const_name ATP.fNot})))),
  16.249 -   ("c_conj", (@{const_name conj}, (@{thm fconj_def},
  16.250 -       ("fconj", @{const_name ATP.fconj})))),
  16.251 -   ("c_disj", (@{const_name disj}, (@{thm fdisj_def},
  16.252 -       ("fdisj", @{const_name ATP.fdisj})))),
  16.253 -   ("c_implies", (@{const_name implies}, (@{thm fimplies_def},
  16.254 -       ("fimplies", @{const_name ATP.fimplies})))),
  16.255 -   ("equal", (@{const_name HOL.eq}, (@{thm fequal_def},
  16.256 -       ("fequal", @{const_name ATP.fequal})))),
  16.257 -   ("c_All", (@{const_name All}, (@{thm fAll_def},
  16.258 -       ("fAll", @{const_name ATP.fAll})))),
  16.259 -   ("c_Ex", (@{const_name Ex}, (@{thm fEx_def},
  16.260 -       ("fEx", @{const_name ATP.fEx}))))]
  16.261 -
  16.262 -val proxify_const = AList.lookup (op =) proxy_table #> Option.map (snd o snd)
  16.263 -
  16.264 -(* Readable names for the more common symbolic functions. Do not mess with the
  16.265 -   table unless you know what you are doing. *)
  16.266 -val const_trans_table =
  16.267 -  [(@{type_name Product_Type.prod}, "prod"),
  16.268 -   (@{type_name Sum_Type.sum}, "sum"),
  16.269 -   (@{const_name False}, "False"),
  16.270 -   (@{const_name True}, "True"),
  16.271 -   (@{const_name Not}, "Not"),
  16.272 -   (@{const_name conj}, "conj"),
  16.273 -   (@{const_name disj}, "disj"),
  16.274 -   (@{const_name implies}, "implies"),
  16.275 -   (@{const_name HOL.eq}, "equal"),
  16.276 -   (@{const_name All}, "All"),
  16.277 -   (@{const_name Ex}, "Ex"),
  16.278 -   (@{const_name If}, "If"),
  16.279 -   (@{const_name Set.member}, "member"),
  16.280 -   (@{const_name Meson.COMBI}, combinator_prefix ^ "I"),
  16.281 -   (@{const_name Meson.COMBK}, combinator_prefix ^ "K"),
  16.282 -   (@{const_name Meson.COMBB}, combinator_prefix ^ "B"),
  16.283 -   (@{const_name Meson.COMBC}, combinator_prefix ^ "C"),
  16.284 -   (@{const_name Meson.COMBS}, combinator_prefix ^ "S")]
  16.285 -  |> Symtab.make
  16.286 -  |> fold (Symtab.update o swap o snd o snd o snd) proxy_table
  16.287 -
  16.288 -(* Invert the table of translations between Isabelle and ATPs. *)
  16.289 -val const_trans_table_inv =
  16.290 -  const_trans_table |> Symtab.dest |> map swap |> Symtab.make
  16.291 -val const_trans_table_unprox =
  16.292 -  Symtab.empty
  16.293 -  |> fold (fn (_, (isa, (_, (_, atp)))) => Symtab.update (atp, isa)) proxy_table
  16.294 -
  16.295 -val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
  16.296 -val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox)
  16.297 -
  16.298 -fun lookup_const c =
  16.299 -  case Symtab.lookup const_trans_table c of
  16.300 -    SOME c' => c'
  16.301 -  | NONE => ascii_of c
  16.302 -
  16.303 -fun ascii_of_indexname (v, 0) = ascii_of v
  16.304 -  | ascii_of_indexname (v, i) = ascii_of v ^ "_" ^ string_of_int i
  16.305 -
  16.306 -fun make_bound_var x = bound_var_prefix ^ ascii_of x
  16.307 -fun make_all_bound_var x = all_bound_var_prefix ^ ascii_of x
  16.308 -fun make_exist_bound_var x = exist_bound_var_prefix ^ ascii_of x
  16.309 -fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
  16.310 -fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
  16.311 -
  16.312 -fun make_schematic_type_var (x, i) =
  16.313 -  tvar_prefix ^ (ascii_of_indexname (unprefix "'" x, i))
  16.314 -fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (unprefix "'" x))
  16.315 -
  16.316 -(* "HOL.eq" and choice are mapped to the ATP's equivalents *)
  16.317 -local
  16.318 -  val choice_const = (fst o dest_Const o HOLogic.choice_const) Term.dummyT
  16.319 -  fun default c = const_prefix ^ lookup_const c
  16.320 -in
  16.321 -  fun make_fixed_const _ @{const_name HOL.eq} = tptp_old_equal
  16.322 -    | make_fixed_const (SOME (THF (_, _, THF_With_Choice))) c =
  16.323 -      if c = choice_const then tptp_choice else default c
  16.324 -    | make_fixed_const _ c = default c
  16.325 -end
  16.326 -
  16.327 -fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
  16.328 -
  16.329 -fun make_type_class clas = class_prefix ^ ascii_of clas
  16.330 -
  16.331 -fun new_skolem_var_name_from_const s =
  16.332 -  let val ss = s |> space_explode Long_Name.separator in
  16.333 -    nth ss (length ss - 2)
  16.334 -  end
  16.335 -
  16.336 -(* These are either simplified away by "Meson.presimplify" (most of the time) or
  16.337 -   handled specially via "fFalse", "fTrue", ..., "fequal". *)
  16.338 -val atp_irrelevant_consts =
  16.339 -  [@{const_name False}, @{const_name True}, @{const_name Not},
  16.340 -   @{const_name conj}, @{const_name disj}, @{const_name implies},
  16.341 -   @{const_name HOL.eq}, @{const_name If}, @{const_name Let}]
  16.342 -
  16.343 -val atp_monomorph_bad_consts =
  16.344 -  atp_irrelevant_consts @
  16.345 -  (* These are ignored anyway by the relevance filter (unless they appear in
  16.346 -     higher-order places) but not by the monomorphizer. *)
  16.347 -  [@{const_name all}, @{const_name "==>"}, @{const_name "=="},
  16.348 -   @{const_name Trueprop}, @{const_name All}, @{const_name Ex},
  16.349 -   @{const_name Ex1}, @{const_name Ball}, @{const_name Bex}]
  16.350 -
  16.351 -fun add_schematic_const (x as (_, T)) =
  16.352 -  Monomorph.typ_has_tvars T ? Symtab.insert_list (op =) x
  16.353 -val add_schematic_consts_of =
  16.354 -  Term.fold_aterms (fn Const (x as (s, _)) =>
  16.355 -                       not (member (op =) atp_monomorph_bad_consts s)
  16.356 -                       ? add_schematic_const x
  16.357 -                      | _ => I)
  16.358 -fun atp_schematic_consts_of t = add_schematic_consts_of t Symtab.empty
  16.359 -
  16.360 -(** Definitions and functions for FOL clauses and formulas for TPTP **)
  16.361 -
  16.362 -(** Isabelle arities **)
  16.363 -
  16.364 -type arity_atom = name * name * name list
  16.365 -
  16.366 -val type_class = the_single @{sort type}
  16.367 -
  16.368 -type arity_clause =
  16.369 -  {name : string,
  16.370 -   prem_atoms : arity_atom list,
  16.371 -   concl_atom : arity_atom}
  16.372 -
  16.373 -fun add_prem_atom tvar =
  16.374 -  fold (fn s => s <> type_class ? cons (`make_type_class s, `I tvar, []))
  16.375 -
  16.376 -(* Arity of type constructor "tcon :: (arg1, ..., argN) res" *)
  16.377 -fun make_axiom_arity_clause (tcons, name, (cls, args)) =
  16.378 -  let
  16.379 -    val tvars = map (prefix tvar_prefix o string_of_int) (1 upto length args)
  16.380 -    val tvars_srts = ListPair.zip (tvars, args)
  16.381 -  in
  16.382 -    {name = name,
  16.383 -     prem_atoms = [] |> fold (uncurry add_prem_atom) tvars_srts,
  16.384 -     concl_atom = (`make_type_class cls, `make_fixed_type_const tcons,
  16.385 -                   tvars ~~ tvars)}
  16.386 -  end
  16.387 -
  16.388 -fun arity_clause _ _ (_, []) = []
  16.389 -  | arity_clause seen n (tcons, ("HOL.type", _) :: ars) =  (* ignore *)
  16.390 -    arity_clause seen n (tcons, ars)
  16.391 -  | arity_clause seen n (tcons, (ar as (class, _)) :: ars) =
  16.392 -    if member (op =) seen class then
  16.393 -      (* multiple arities for the same (tycon, class) pair *)
  16.394 -      make_axiom_arity_clause (tcons,
  16.395 -          lookup_const tcons ^ "___" ^ ascii_of class ^ "_" ^ string_of_int n,
  16.396 -          ar) ::
  16.397 -      arity_clause seen (n + 1) (tcons, ars)
  16.398 -    else
  16.399 -      make_axiom_arity_clause (tcons, lookup_const tcons ^ "___" ^
  16.400 -                               ascii_of class, ar) ::
  16.401 -      arity_clause (class :: seen) n (tcons, ars)
  16.402 -
  16.403 -fun multi_arity_clause [] = []
  16.404 -  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
  16.405 -    arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
  16.406 -
  16.407 -(* Generate all pairs (tycon, class, sorts) such that tycon belongs to class in
  16.408 -   theory thy provided its arguments have the corresponding sorts. *)
  16.409 -fun type_class_pairs thy tycons classes =
  16.410 -  let
  16.411 -    val alg = Sign.classes_of thy
  16.412 -    fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
  16.413 -    fun add_class tycon class =
  16.414 -      cons (class, domain_sorts tycon class)
  16.415 -      handle Sorts.CLASS_ERROR _ => I
  16.416 -    fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
  16.417 -  in map try_classes tycons end
  16.418 -
  16.419 -(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  16.420 -fun iter_type_class_pairs _ _ [] = ([], [])
  16.421 -  | iter_type_class_pairs thy tycons classes =
  16.422 -      let
  16.423 -        fun maybe_insert_class s =
  16.424 -          (s <> type_class andalso not (member (op =) classes s))
  16.425 -          ? insert (op =) s
  16.426 -        val cpairs = type_class_pairs thy tycons classes
  16.427 -        val newclasses =
  16.428 -          [] |> fold (fold (fold (fold maybe_insert_class) o snd) o snd) cpairs
  16.429 -        val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  16.430 -      in (classes' @ classes, union (op =) cpairs' cpairs) end
  16.431 -
  16.432 -fun make_arity_clauses thy tycons =
  16.433 -  iter_type_class_pairs thy tycons ##> multi_arity_clause
  16.434 -
  16.435 -
  16.436 -(** Isabelle class relations **)
  16.437 -
  16.438 -type class_rel_clause =
  16.439 -  {name : string,
  16.440 -   subclass : name,
  16.441 -   superclass : name}
  16.442 -
  16.443 -(* Generate all pairs (sub, super) such that sub is a proper subclass of super
  16.444 -   in theory "thy". *)
  16.445 -fun class_pairs _ [] _ = []
  16.446 -  | class_pairs thy subs supers =
  16.447 -      let
  16.448 -        val class_less = Sorts.class_less (Sign.classes_of thy)
  16.449 -        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
  16.450 -        fun add_supers sub = fold (add_super sub) supers
  16.451 -      in fold add_supers subs [] end
  16.452 -
  16.453 -fun make_class_rel_clause (sub, super) =
  16.454 -  {name = sub ^ "_" ^ super, subclass = `make_type_class sub,
  16.455 -   superclass = `make_type_class super}
  16.456 -
  16.457 -fun make_class_rel_clauses thy subs supers =
  16.458 -  map make_class_rel_clause (class_pairs thy subs supers)
  16.459 -
  16.460 -(* intermediate terms *)
  16.461 -datatype iterm =
  16.462 -  IConst of name * typ * typ list |
  16.463 -  IVar of name * typ |
  16.464 -  IApp of iterm * iterm |
  16.465 -  IAbs of (name * typ) * iterm
  16.466 -
  16.467 -fun ityp_of (IConst (_, T, _)) = T
  16.468 -  | ityp_of (IVar (_, T)) = T
  16.469 -  | ityp_of (IApp (t1, _)) = snd (dest_funT (ityp_of t1))
  16.470 -  | ityp_of (IAbs ((_, T), tm)) = T --> ityp_of tm
  16.471 -
  16.472 -(*gets the head of a combinator application, along with the list of arguments*)
  16.473 -fun strip_iterm_comb u =
  16.474 -  let
  16.475 -    fun stripc (IApp (t, u), ts) = stripc (t, u :: ts)
  16.476 -      | stripc x = x
  16.477 -  in stripc (u, []) end
  16.478 -
  16.479 -fun atomic_types_of T = fold_atyps (insert (op =)) T []
  16.480 -
  16.481 -val tvar_a_str = "'a"
  16.482 -val tvar_a = TVar ((tvar_a_str, 0), HOLogic.typeS)
  16.483 -val tvar_a_name = (make_schematic_type_var (tvar_a_str, 0), tvar_a_str)
  16.484 -val itself_name = `make_fixed_type_const @{type_name itself}
  16.485 -val TYPE_name = `(make_fixed_const NONE) @{const_name TYPE}
  16.486 -val tvar_a_atype = AType (tvar_a_name, [])
  16.487 -val a_itself_atype = AType (itself_name, [tvar_a_atype])
  16.488 -
  16.489 -fun new_skolem_const_name s num_T_args =
  16.490 -  [new_skolem_const_prefix, s, string_of_int num_T_args]
  16.491 -  |> space_implode Long_Name.separator
  16.492 -
  16.493 -fun robust_const_type thy s =
  16.494 -  if s = app_op_name then
  16.495 -    Logic.varifyT_global @{typ "('a => 'b) => 'a => 'b"}
  16.496 -  else if String.isPrefix lam_lifted_prefix s then
  16.497 -    Logic.varifyT_global @{typ "'a => 'b"}
  16.498 -  else
  16.499 -    (* Old Skolems throw a "TYPE" exception here, which will be caught. *)
  16.500 -    s |> Sign.the_const_type thy
  16.501 -
  16.502 -(* This function only makes sense if "T" is as general as possible. *)
  16.503 -fun robust_const_typargs thy (s, T) =
  16.504 -  if s = app_op_name then
  16.505 -    let val (T1, T2) = T |> domain_type |> dest_funT in [T1, T2] end
  16.506 -  else if String.isPrefix old_skolem_const_prefix s then
  16.507 -    [] |> Term.add_tvarsT T |> rev |> map TVar
  16.508 -  else if String.isPrefix lam_lifted_prefix s then
  16.509 -    if String.isPrefix lam_lifted_poly_prefix s then
  16.510 -      let val (T1, T2) = T |> dest_funT in [T1, T2] end
  16.511 -    else
  16.512 -      []
  16.513 -  else
  16.514 -    (s, T) |> Sign.const_typargs thy
  16.515 -
  16.516 -(* Converts an Isabelle/HOL term (with combinators) into an intermediate term.
  16.517 -   Also accumulates sort infomation. *)
  16.518 -fun iterm_from_term thy format bs (P $ Q) =
  16.519 -    let
  16.520 -      val (P', P_atomics_Ts) = iterm_from_term thy format bs P
  16.521 -      val (Q', Q_atomics_Ts) = iterm_from_term thy format bs Q
  16.522 -    in (IApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end
  16.523 -  | iterm_from_term thy format _ (Const (c, T)) =
  16.524 -    (IConst (`(make_fixed_const (SOME format)) c, T,
  16.525 -             robust_const_typargs thy (c, T)),
  16.526 -     atomic_types_of T)
  16.527 -  | iterm_from_term _ _ _ (Free (s, T)) =
  16.528 -    (IConst (`make_fixed_var s, T, []), atomic_types_of T)
  16.529 -  | iterm_from_term _ format _ (Var (v as (s, _), T)) =
  16.530 -    (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
  16.531 -       let
  16.532 -         val Ts = T |> strip_type |> swap |> op ::
  16.533 -         val s' = new_skolem_const_name s (length Ts)
  16.534 -       in IConst (`(make_fixed_const (SOME format)) s', T, Ts) end
  16.535 -     else
  16.536 -       IVar ((make_schematic_var v, s), T), atomic_types_of T)
  16.537 -  | iterm_from_term _ _ bs (Bound j) =
  16.538 -    nth bs j |> (fn (_, (name, T)) => (IConst (name, T, []), atomic_types_of T))
  16.539 -  | iterm_from_term thy format bs (Abs (s, T, t)) =
  16.540 -    let
  16.541 -      fun vary s = s |> AList.defined (op =) bs s ? vary o Symbol.bump_string
  16.542 -      val s = vary s
  16.543 -      val name = `make_bound_var s
  16.544 -      val (tm, atomic_Ts) = iterm_from_term thy format ((s, (name, T)) :: bs) t
  16.545 -    in (IAbs ((name, T), tm), union (op =) atomic_Ts (atomic_types_of T)) end
  16.546 -
  16.547 -datatype locality =
  16.548 -  General | Helper | Induction | Intro | Elim | Simp | Local | Assum | Chained
  16.549 -
  16.550 -datatype order = First_Order | Higher_Order
  16.551 -datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic
  16.552 -datatype strictness = Strict | Non_Strict
  16.553 -datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars
  16.554 -datatype type_level =
  16.555 -  All_Types |
  16.556 -  Noninf_Nonmono_Types of strictness * granularity |
  16.557 -  Fin_Nonmono_Types of granularity |
  16.558 -  Const_Arg_Types |
  16.559 -  No_Types
  16.560 -
  16.561 -datatype type_enc =
  16.562 -  Simple_Types of order * polymorphism * type_level |
  16.563 -  Guards of polymorphism * type_level |
  16.564 -  Tags of polymorphism * type_level
  16.565 -
  16.566 -fun is_type_enc_higher_order (Simple_Types (Higher_Order, _, _)) = true
  16.567 -  | is_type_enc_higher_order _ = false
  16.568 -
  16.569 -fun polymorphism_of_type_enc (Simple_Types (_, poly, _)) = poly
  16.570 -  | polymorphism_of_type_enc (Guards (poly, _)) = poly
  16.571 -  | polymorphism_of_type_enc (Tags (poly, _)) = poly
  16.572 -
  16.573 -fun level_of_type_enc (Simple_Types (_, _, level)) = level
  16.574 -  | level_of_type_enc (Guards (_, level)) = level
  16.575 -  | level_of_type_enc (Tags (_, level)) = level
  16.576 -
  16.577 -fun granularity_of_type_level (Noninf_Nonmono_Types (_, grain)) = grain
  16.578 -  | granularity_of_type_level (Fin_Nonmono_Types grain) = grain
  16.579 -  | granularity_of_type_level _ = All_Vars
  16.580 -
  16.581 -fun is_type_level_quasi_sound All_Types = true
  16.582 -  | is_type_level_quasi_sound (Noninf_Nonmono_Types _) = true
  16.583 -  | is_type_level_quasi_sound _ = false
  16.584 -val is_type_enc_quasi_sound = is_type_level_quasi_sound o level_of_type_enc
  16.585 -
  16.586 -fun is_type_level_fairly_sound (Fin_Nonmono_Types _) = true
  16.587 -  | is_type_level_fairly_sound level = is_type_level_quasi_sound level
  16.588 -val is_type_enc_fairly_sound = is_type_level_fairly_sound o level_of_type_enc
  16.589 -
  16.590 -fun is_type_level_monotonicity_based (Noninf_Nonmono_Types _) = true
  16.591 -  | is_type_level_monotonicity_based (Fin_Nonmono_Types _) = true
  16.592 -  | is_type_level_monotonicity_based _ = false
  16.593 -
  16.594 -(* "_query", "_bang", and "_at" are for the ASCII-challenged Metis and
  16.595 -   Mirabelle. *)
  16.596 -val queries = ["?", "_query"]
  16.597 -val bangs = ["!", "_bang"]
  16.598 -val ats = ["@", "_at"]
  16.599 -
  16.600 -fun try_unsuffixes ss s =
  16.601 -  fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE
  16.602 -
  16.603 -fun try_nonmono constr suffixes fallback s =
  16.604 -  case try_unsuffixes suffixes s of
  16.605 -    SOME s =>
  16.606 -    (case try_unsuffixes suffixes s of
  16.607 -       SOME s => (constr Positively_Naked_Vars, s)
  16.608 -     | NONE =>
  16.609 -       case try_unsuffixes ats s of
  16.610 -         SOME s => (constr Ghost_Type_Arg_Vars, s)
  16.611 -       | NONE => (constr All_Vars, s))
  16.612 -  | NONE => fallback s
  16.613 -
  16.614 -fun type_enc_from_string strictness s =
  16.615 -  (case try (unprefix "poly_") s of
  16.616 -     SOME s => (SOME Polymorphic, s)
  16.617 -   | NONE =>
  16.618 -     case try (unprefix "raw_mono_") s of
  16.619 -       SOME s => (SOME Raw_Monomorphic, s)
  16.620 -     | NONE =>
  16.621 -       case try (unprefix "mono_") s of
  16.622 -         SOME s => (SOME Mangled_Monomorphic, s)
  16.623 -       | NONE => (NONE, s))
  16.624 -  ||> (pair All_Types
  16.625 -       |> try_nonmono Fin_Nonmono_Types bangs
  16.626 -       |> try_nonmono (curry Noninf_Nonmono_Types strictness) queries)
  16.627 -  |> (fn (poly, (level, core)) =>
  16.628 -         case (core, (poly, level)) of
  16.629 -           ("simple", (SOME poly, _)) =>
  16.630 -           (case (poly, level) of
  16.631 -              (Polymorphic, All_Types) =>
  16.632 -              Simple_Types (First_Order, Polymorphic, All_Types)
  16.633 -            | (Mangled_Monomorphic, _) =>
  16.634 -              if granularity_of_type_level level = All_Vars then
  16.635 -                Simple_Types (First_Order, Mangled_Monomorphic, level)
  16.636 -              else
  16.637 -                raise Same.SAME
  16.638 -            | _ => raise Same.SAME)
  16.639 -         | ("simple_higher", (SOME poly, _)) =>
  16.640 -           (case (poly, level) of
  16.641 -              (Polymorphic, All_Types) =>
  16.642 -              Simple_Types (Higher_Order, Polymorphic, All_Types)
  16.643 -            | (_, Noninf_Nonmono_Types _) => raise Same.SAME
  16.644 -            | (Mangled_Monomorphic, _) =>
  16.645 -              if granularity_of_type_level level = All_Vars then
  16.646 -                Simple_Types (Higher_Order, Mangled_Monomorphic, level)
  16.647 -              else
  16.648 -                raise Same.SAME
  16.649 -            | _ => raise Same.SAME)
  16.650 -         | ("guards", (SOME poly, _)) =>
  16.651 -           if poly = Mangled_Monomorphic andalso
  16.652 -              granularity_of_type_level level = Ghost_Type_Arg_Vars then
  16.653 -             raise Same.SAME
  16.654 -           else
  16.655 -             Guards (poly, level)
  16.656 -         | ("tags", (SOME poly, _)) =>
  16.657 -           if granularity_of_type_level level = Ghost_Type_Arg_Vars then
  16.658 -             raise Same.SAME
  16.659 -           else
  16.660 -             Tags (poly, level)
  16.661 -         | ("args", (SOME poly, All_Types (* naja *))) =>
  16.662 -           Guards (poly, Const_Arg_Types)
  16.663 -         | ("erased", (NONE, All_Types (* naja *))) =>
  16.664 -           Guards (Polymorphic, No_Types)
  16.665 -         | _ => raise Same.SAME)
  16.666 -  handle Same.SAME => error ("Unknown type encoding: " ^ quote s ^ ".")
  16.667 -
  16.668 -fun adjust_type_enc (THF (TPTP_Monomorphic, _, _))
  16.669 -                    (Simple_Types (order, _, level)) =
  16.670 -    Simple_Types (order, Mangled_Monomorphic, level)
  16.671 -  | adjust_type_enc (THF _) type_enc = type_enc
  16.672 -  | adjust_type_enc (TFF (TPTP_Monomorphic, _)) (Simple_Types (_, _, level)) =
  16.673 -    Simple_Types (First_Order, Mangled_Monomorphic, level)
  16.674 -  | adjust_type_enc (DFG DFG_Sorted) (Simple_Types (_, _, level)) =
  16.675 -    Simple_Types (First_Order, Mangled_Monomorphic, level)
  16.676 -  | adjust_type_enc (TFF _) (Simple_Types (_, poly, level)) =
  16.677 -    Simple_Types (First_Order, poly, level)
  16.678 -  | adjust_type_enc format (Simple_Types (_, poly, level)) =
  16.679 -    adjust_type_enc format (Guards (poly, level))
  16.680 -  | adjust_type_enc CNF_UEQ (type_enc as Guards stuff) =
  16.681 -    (if is_type_enc_fairly_sound type_enc then Tags else Guards) stuff
  16.682 -  | adjust_type_enc _ type_enc = type_enc
  16.683 -
  16.684 -fun constify_lifted (t $ u) = constify_lifted t $ constify_lifted u
  16.685 -  | constify_lifted (Abs (s, T, t)) = Abs (s, T, constify_lifted t)
  16.686 -  | constify_lifted (Free (x as (s, _))) =
  16.687 -    (if String.isPrefix lam_lifted_prefix s then Const else Free) x
  16.688 -  | constify_lifted t = t
  16.689 -
  16.690 -(* Requires bound variables not to clash with any schematic variables (as should
  16.691 -   be the case right after lambda-lifting). *)
  16.692 -fun open_form (Const (@{const_name All}, _) $ Abs (s, T, t)) =
  16.693 -    let
  16.694 -      val names = Name.make_context (map fst (Term.add_var_names t []))
  16.695 -      val (s, _) = Name.variant s names
  16.696 -    in open_form (subst_bound (Var ((s, 0), T), t)) end
  16.697 -  | open_form t = t
  16.698 -
  16.699 -fun lift_lams_part_1 ctxt type_enc =
  16.700 -  map close_form #> rpair ctxt
  16.701 -  #-> Lambda_Lifting.lift_lambdas
  16.702 -          (SOME ((if polymorphism_of_type_enc type_enc = Polymorphic then
  16.703 -                    lam_lifted_poly_prefix
  16.704 -                  else
  16.705 -                    lam_lifted_mono_prefix) ^ "_a"))
  16.706 -          Lambda_Lifting.is_quantifier
  16.707 -  #> fst
  16.708 -val lift_lams_part_2 = pairself (map (open_form o constify_lifted))
  16.709 -val lift_lams = lift_lams_part_2 ooo lift_lams_part_1
  16.710 -
  16.711 -fun intentionalize_def (Const (@{const_name All}, _) $ Abs (_, _, t)) =
  16.712 -    intentionalize_def t
  16.713 -  | intentionalize_def (Const (@{const_name HOL.eq}, _) $ t $ u) =
  16.714 -    let
  16.715 -      fun lam T t = Abs (Name.uu, T, t)
  16.716 -      val (head, args) = strip_comb t ||> rev
  16.717 -      val head_T = fastype_of head
  16.718 -      val n = length args
  16.719 -      val arg_Ts = head_T |> binder_types |> take n |> rev
  16.720 -      val u = u |> subst_atomic (args ~~ map Bound (0 upto n - 1))
  16.721 -    in HOLogic.eq_const head_T $ head $ fold lam arg_Ts u end
  16.722 -  | intentionalize_def t = t
  16.723 -
  16.724 -type translated_formula =
  16.725 -  {name : string,
  16.726 -   locality : locality,
  16.727 -   kind : formula_kind,
  16.728 -   iformula : (name, typ, iterm) formula,
  16.729 -   atomic_types : typ list}
  16.730 -
  16.731 -fun update_iformula f ({name, locality, kind, iformula, atomic_types}
  16.732 -                       : translated_formula) =
  16.733 -  {name = name, locality = locality, kind = kind, iformula = f iformula,
  16.734 -   atomic_types = atomic_types} : translated_formula
  16.735 -
  16.736 -fun fact_lift f ({iformula, ...} : translated_formula) = f iformula
  16.737 -
  16.738 -fun insert_type ctxt get_T x xs =
  16.739 -  let val T = get_T x in
  16.740 -    if exists (type_instance ctxt T o get_T) xs then xs
  16.741 -    else x :: filter_out (type_generalization ctxt T o get_T) xs
  16.742 -  end
  16.743 -
  16.744 -(* The Booleans indicate whether all type arguments should be kept. *)
  16.745 -datatype type_arg_policy =
  16.746 -  Explicit_Type_Args of bool (* infer_from_term_args *) |
  16.747 -  Mangled_Type_Args |
  16.748 -  No_Type_Args
  16.749 -
  16.750 -fun type_arg_policy monom_constrs type_enc s =
  16.751 -  let val poly = polymorphism_of_type_enc type_enc in
  16.752 -    if s = type_tag_name then
  16.753 -      if poly = Mangled_Monomorphic then Mangled_Type_Args
  16.754 -      else Explicit_Type_Args false
  16.755 -    else case type_enc of
  16.756 -      Simple_Types (_, Polymorphic, _) => Explicit_Type_Args false
  16.757 -    | Tags (_, All_Types) => No_Type_Args
  16.758 -    | _ =>
  16.759 -      let val level = level_of_type_enc type_enc in
  16.760 -        if level = No_Types orelse s = @{const_name HOL.eq} orelse
  16.761 -           (s = app_op_name andalso level = Const_Arg_Types) then
  16.762 -          No_Type_Args
  16.763 -        else if poly = Mangled_Monomorphic then
  16.764 -          Mangled_Type_Args
  16.765 -        else if member (op =) monom_constrs s andalso
  16.766 -                granularity_of_type_level level = Positively_Naked_Vars then
  16.767 -          No_Type_Args
  16.768 -        else
  16.769 -          Explicit_Type_Args
  16.770 -              (level = All_Types orelse
  16.771 -               granularity_of_type_level level = Ghost_Type_Arg_Vars)
  16.772 -      end
  16.773 -  end
  16.774 -
  16.775 -(* Make atoms for sorted type variables. *)
  16.776 -fun generic_add_sorts_on_type (_, []) = I
  16.777 -  | generic_add_sorts_on_type ((x, i), s :: ss) =
  16.778 -    generic_add_sorts_on_type ((x, i), ss)
  16.779 -    #> (if s = the_single @{sort HOL.type} then
  16.780 -          I
  16.781 -        else if i = ~1 then
  16.782 -          insert (op =) (`make_type_class s, `make_fixed_type_var x)
  16.783 -        else
  16.784 -          insert (op =) (`make_type_class s,
  16.785 -                         (make_schematic_type_var (x, i), x)))
  16.786 -fun add_sorts_on_tfree (TFree (s, S)) = generic_add_sorts_on_type ((s, ~1), S)
  16.787 -  | add_sorts_on_tfree _ = I
  16.788 -fun add_sorts_on_tvar (TVar z) = generic_add_sorts_on_type z
  16.789 -  | add_sorts_on_tvar _ = I
  16.790 -
  16.791 -fun type_class_formula type_enc class arg =
  16.792 -  AAtom (ATerm (class, arg ::
  16.793 -      (case type_enc of
  16.794 -         Simple_Types (First_Order, Polymorphic, _) =>
  16.795 -         if avoid_first_order_ghost_type_vars then [ATerm (TYPE_name, [arg])]
  16.796 -         else []
  16.797 -       | _ => [])))
  16.798 -fun formulas_for_types type_enc add_sorts_on_typ Ts =
  16.799 -  [] |> level_of_type_enc type_enc <> No_Types ? fold add_sorts_on_typ Ts
  16.800 -     |> map (fn (class, name) =>
  16.801 -                type_class_formula type_enc class (ATerm (name, [])))
  16.802 -
  16.803 -fun mk_aconns c phis =
  16.804 -  let val (phis', phi') = split_last phis in
  16.805 -    fold_rev (mk_aconn c) phis' phi'
  16.806 -  end
  16.807 -fun mk_ahorn [] phi = phi
  16.808 -  | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi])
  16.809 -fun mk_aquant _ [] phi = phi
  16.810 -  | mk_aquant q xs (phi as AQuant (q', xs', phi')) =
  16.811 -    if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi)
  16.812 -  | mk_aquant q xs phi = AQuant (q, xs, phi)
  16.813 -
  16.814 -fun close_universally add_term_vars phi =
  16.815 -  let
  16.816 -    fun add_formula_vars bounds (AQuant (_, xs, phi)) =
  16.817 -        add_formula_vars (map fst xs @ bounds) phi
  16.818 -      | add_formula_vars bounds (AConn (_, phis)) =
  16.819 -        fold (add_formula_vars bounds) phis
  16.820 -      | add_formula_vars bounds (AAtom tm) = add_term_vars bounds tm
  16.821 -  in mk_aquant AForall (add_formula_vars [] phi []) phi end
  16.822 -
  16.823 -fun add_term_vars bounds (ATerm (name as (s, _), tms)) =
  16.824 -    (if is_tptp_variable s andalso
  16.825 -        not (String.isPrefix tvar_prefix s) andalso
  16.826 -        not (member (op =) bounds name) then
  16.827 -       insert (op =) (name, NONE)
  16.828 -     else
  16.829 -       I)
  16.830 -    #> fold (add_term_vars bounds) tms
  16.831 -  | add_term_vars bounds (AAbs ((name, _), tm)) =
  16.832 -    add_term_vars (name :: bounds) tm
  16.833 -fun close_formula_universally phi = close_universally add_term_vars phi
  16.834 -
  16.835 -fun add_iterm_vars bounds (IApp (tm1, tm2)) =
  16.836 -    fold (add_iterm_vars bounds) [tm1, tm2]
  16.837 -  | add_iterm_vars _ (IConst _) = I
  16.838 -  | add_iterm_vars bounds (IVar (name, T)) =
  16.839 -    not (member (op =) bounds name) ? insert (op =) (name, SOME T)
  16.840 -  | add_iterm_vars bounds (IAbs (_, tm)) = add_iterm_vars bounds tm
  16.841 -fun close_iformula_universally phi = close_universally add_iterm_vars phi
  16.842 -
  16.843 -val fused_infinite_type_name = @{type_name ind} (* any infinite type *)
  16.844 -val fused_infinite_type = Type (fused_infinite_type_name, [])
  16.845 -
  16.846 -fun tvar_name (x as (s, _)) = (make_schematic_type_var x, s)
  16.847 -
  16.848 -fun ho_term_from_typ format type_enc =
  16.849 -  let
  16.850 -    fun term (Type (s, Ts)) =
  16.851 -      ATerm (case (is_type_enc_higher_order type_enc, s) of
  16.852 -               (true, @{type_name bool}) => `I tptp_bool_type
  16.853 -             | (true, @{type_name fun}) => `I tptp_fun_type
  16.854 -             | _ => if s = fused_infinite_type_name andalso
  16.855 -                       is_format_typed format then
  16.856 -                      `I tptp_individual_type
  16.857 -                    else
  16.858 -                      `make_fixed_type_const s,
  16.859 -             map term Ts)
  16.860 -    | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, [])
  16.861 -    | term (TVar (x, _)) = ATerm (tvar_name x, [])
  16.862 -  in term end
  16.863 -
  16.864 -fun ho_term_for_type_arg format type_enc T =
  16.865 -  if T = dummyT then NONE else SOME (ho_term_from_typ format type_enc T)
  16.866 -
  16.867 -(* This shouldn't clash with anything else. *)
  16.868 -val mangled_type_sep = "\000"
  16.869 -
  16.870 -fun generic_mangled_type_name f (ATerm (name, [])) = f name
  16.871 -  | generic_mangled_type_name f (ATerm (name, tys)) =
  16.872 -    f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys)
  16.873 -    ^ ")"
  16.874 -  | generic_mangled_type_name _ _ = raise Fail "unexpected type abstraction"
  16.875 -
  16.876 -fun mangled_type format type_enc =
  16.877 -  generic_mangled_type_name fst o ho_term_from_typ format type_enc
  16.878 -
  16.879 -fun make_simple_type s =
  16.880 -  if s = tptp_bool_type orelse s = tptp_fun_type orelse
  16.881 -     s = tptp_individual_type then
  16.882 -    s
  16.883 -  else
  16.884 -    simple_type_prefix ^ ascii_of s
  16.885 -
  16.886 -fun ho_type_from_ho_term type_enc pred_sym ary =
  16.887 -  let
  16.888 -    fun to_mangled_atype ty =
  16.889 -      AType ((make_simple_type (generic_mangled_type_name fst ty),
  16.890 -              generic_mangled_type_name snd ty), [])
  16.891 -    fun to_poly_atype (ATerm (name, tys)) = AType (name, map to_poly_atype tys)
  16.892 -      | to_poly_atype _ = raise Fail "unexpected type abstraction"
  16.893 -    val to_atype =
  16.894 -      if polymorphism_of_type_enc type_enc = Polymorphic then to_poly_atype
  16.895 -      else to_mangled_atype
  16.896 -    fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1))
  16.897 -    fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty
  16.898 -      | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys
  16.899 -      | to_fo _ _ = raise Fail "unexpected type abstraction"
  16.900 -    fun to_ho (ty as ATerm ((s, _), tys)) =
  16.901 -        if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty
  16.902 -      | to_ho _ = raise Fail "unexpected type abstraction"
  16.903 -  in if is_type_enc_higher_order type_enc then to_ho else to_fo ary end
  16.904 -
  16.905 -fun ho_type_from_typ format type_enc pred_sym ary =
  16.906 -  ho_type_from_ho_term type_enc pred_sym ary
  16.907 -  o ho_term_from_typ format type_enc
  16.908 -
  16.909 -fun mangled_const_name format type_enc T_args (s, s') =
  16.910 -  let
  16.911 -    val ty_args = T_args |> map_filter (ho_term_for_type_arg format type_enc)
  16.912 -    fun type_suffix f g =
  16.913 -      fold_rev (curry (op ^) o g o prefix mangled_type_sep
  16.914 -                o generic_mangled_type_name f) ty_args ""
  16.915 -  in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end
  16.916 -
  16.917 -val parse_mangled_ident =
  16.918 -  Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode
  16.919 -
  16.920 -fun parse_mangled_type x =
  16.921 -  (parse_mangled_ident
  16.922 -   -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")")
  16.923 -                    [] >> ATerm) x
  16.924 -and parse_mangled_types x =
  16.925 -  (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x
  16.926 -
  16.927 -fun unmangled_type s =
  16.928 -  s |> suffix ")" |> raw_explode
  16.929 -    |> Scan.finite Symbol.stopper
  16.930 -           (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^
  16.931 -                                                quote s)) parse_mangled_type))
  16.932 -    |> fst
  16.933 -
  16.934 -val unmangled_const_name = space_explode mangled_type_sep #> hd
  16.935 -fun unmangled_const s =
  16.936 -  let val ss = space_explode mangled_type_sep s in
  16.937 -    (hd ss, map unmangled_type (tl ss))
  16.938 -  end
  16.939 -
  16.940 -fun introduce_proxies_in_iterm type_enc =
  16.941 -  let
  16.942 -    fun tweak_ho_quant ho_quant T [IAbs _] = IConst (`I ho_quant, T, [])
  16.943 -      | tweak_ho_quant ho_quant (T as Type (_, [p_T as Type (_, [x_T, _]), _]))
  16.944 -                       _ =
  16.945 -        (* Eta-expand "!!" and "??", to work around LEO-II 1.2.8 parser
  16.946 -           limitation. This works in conjuction with special code in
  16.947 -           "ATP_Problem" that uses the syntactic sugar "!" and "?" whenever
  16.948 -           possible. *)
  16.949 -        IAbs ((`I "P", p_T),
  16.950 -              IApp (IConst (`I ho_quant, T, []),
  16.951 -                    IAbs ((`I "X", x_T),
  16.952 -                          IApp (IConst (`I "P", p_T, []),
  16.953 -                                IConst (`I "X", x_T, [])))))
  16.954 -      | tweak_ho_quant _ _ _ = raise Fail "unexpected type for quantifier"
  16.955 -    fun intro top_level args (IApp (tm1, tm2)) =
  16.956 -        IApp (intro top_level (tm2 :: args) tm1, intro false [] tm2)
  16.957 -      | intro top_level args (IConst (name as (s, _), T, T_args)) =
  16.958 -        (case proxify_const s of
  16.959 -           SOME proxy_base =>
  16.960 -           if top_level orelse is_type_enc_higher_order type_enc then
  16.961 -             case (top_level, s) of
  16.962 -               (_, "c_False") => IConst (`I tptp_false, T, [])
  16.963 -             | (_, "c_True") => IConst (`I tptp_true, T, [])
  16.964 -             | (false, "c_Not") => IConst (`I tptp_not, T, [])
  16.965 -             | (false, "c_conj") => IConst (`I tptp_and, T, [])
  16.966 -             | (false, "c_disj") => IConst (`I tptp_or, T, [])
  16.967 -             | (false, "c_implies") => IConst (`I tptp_implies, T, [])
  16.968 -             | (false, "c_All") => tweak_ho_quant tptp_ho_forall T args
  16.969 -             | (false, "c_Ex") => tweak_ho_quant tptp_ho_exists T args
  16.970 -             | (false, s) =>
  16.971 -               if is_tptp_equal s andalso length args = 2 then
  16.972 -                 IConst (`I tptp_equal, T, [])
  16.973 -               else
  16.974 -                 (* Use a proxy even for partially applied THF0 equality,
  16.975 -                    because the LEO-II and Satallax parsers complain about not
  16.976 -                    being able to infer the type of "=". *)
  16.977 -                 IConst (proxy_base |>> prefix const_prefix, T, T_args)
  16.978 -             | _ => IConst (name, T, [])
  16.979 -           else
  16.980 -             IConst (proxy_base |>> prefix const_prefix, T, T_args)
  16.981 -          | NONE => if s = tptp_choice then tweak_ho_quant tptp_choice T args
  16.982 -                    else IConst (name, T, T_args))
  16.983 -      | intro _ _ (IAbs (bound, tm)) = IAbs (bound, intro false [] tm)
  16.984 -      | intro _ _ tm = tm
  16.985 -  in intro true [] end
  16.986 -
  16.987 -fun mangle_type_args_in_iterm format type_enc =
  16.988 -  if polymorphism_of_type_enc type_enc = Mangled_Monomorphic then
  16.989 -    let
  16.990 -      fun mangle (IApp (tm1, tm2)) = IApp (mangle tm1, mangle tm2)
  16.991 -        | mangle (tm as IConst (_, _, [])) = tm
  16.992 -        | mangle (tm as IConst (name as (s, _), T, T_args)) =
  16.993 -          (case unprefix_and_unascii const_prefix s of
  16.994 -             NONE => tm
  16.995 -           | SOME s'' =>
  16.996 -             case type_arg_policy [] type_enc (invert_const s'') of
  16.997 -               Mangled_Type_Args =>
  16.998 -               IConst (mangled_const_name format type_enc T_args name, T, [])
  16.999 -             | _ => tm)
 16.1000 -        | mangle (IAbs (bound, tm)) = IAbs (bound, mangle tm)
 16.1001 -        | mangle tm = tm
 16.1002 -    in mangle end
 16.1003 -  else
 16.1004 -    I
 16.1005 -
 16.1006 -fun chop_fun 0 T = ([], T)
 16.1007 -  | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) =
 16.1008 -    chop_fun (n - 1) ran_T |>> cons dom_T
 16.1009 -  | chop_fun _ T = ([], T)
 16.1010 -
 16.1011 -fun filter_const_type_args _ _ _ [] = []
 16.1012 -  | filter_const_type_args thy s ary T_args =
 16.1013 -    let
 16.1014 -      val U = robust_const_type thy s
 16.1015 -      val arg_U_vars = fold Term.add_tvarsT (U |> chop_fun ary |> fst) []
 16.1016 -      val U_args = (s, U) |> robust_const_typargs thy
 16.1017 -    in
 16.1018 -      U_args ~~ T_args
 16.1019 -      |> map (fn (U, T) =>
 16.1020 -                 if member (op =) arg_U_vars (dest_TVar U) then dummyT else T)
 16.1021 -    end
 16.1022 -    handle TYPE _ => T_args
 16.1023 -
 16.1024 -fun filter_type_args_in_iterm thy monom_constrs type_enc =
 16.1025 -  let
 16.1026 -    fun filt ary (IApp (tm1, tm2)) = IApp (filt (ary + 1) tm1, filt 0 tm2)
 16.1027 -      | filt _ (tm as IConst (_, _, [])) = tm
 16.1028 -      | filt ary (IConst (name as (s, _), T, T_args)) =
 16.1029 -        (case unprefix_and_unascii const_prefix s of
 16.1030 -           NONE =>
 16.1031 -           (name,
 16.1032 -            if level_of_type_enc type_enc = No_Types orelse s = tptp_choice then
 16.1033 -              []
 16.1034 -            else
 16.1035 -              T_args)
 16.1036 -         | SOME s'' =>
 16.1037 -           let
 16.1038 -             val s'' = invert_const s''
 16.1039 -             fun filter_T_args false = T_args
 16.1040 -               | filter_T_args true = filter_const_type_args thy s'' ary T_args
 16.1041 -           in
 16.1042 -             case type_arg_policy monom_constrs type_enc s'' of
 16.1043 -               Explicit_Type_Args infer_from_term_args =>
 16.1044 -               (name, filter_T_args infer_from_term_args)
 16.1045 -             | No_Type_Args => (name, [])
 16.1046 -             | Mangled_Type_Args => raise Fail "unexpected (un)mangled symbol"
 16.1047 -           end)
 16.1048 -        |> (fn (name, T_args) => IConst (name, T, T_args))
 16.1049 -      | filt _ (IAbs (bound, tm)) = IAbs (bound, filt 0 tm)
 16.1050 -      | filt _ tm = tm
 16.1051 -  in filt 0 end
 16.1052 -
 16.1053 -fun iformula_from_prop ctxt format type_enc eq_as_iff =
 16.1054 -  let
 16.1055 -    val thy = Proof_Context.theory_of ctxt
 16.1056 -    fun do_term bs t atomic_Ts =
 16.1057 -      iterm_from_term thy format bs (Envir.eta_contract t)
 16.1058 -      |>> (introduce_proxies_in_iterm type_enc
 16.1059 -           #> mangle_type_args_in_iterm format type_enc
 16.1060 -           #> AAtom)
 16.1061 -      ||> union (op =) atomic_Ts
 16.1062 -    fun do_quant bs q pos s T t' =
 16.1063 -      let
 16.1064 -        val s = singleton (Name.variant_list (map fst bs)) s
 16.1065 -        val universal = Option.map (q = AExists ? not) pos
 16.1066 -        val name =
 16.1067 -          s |> `(case universal of
 16.1068 -                   SOME true => make_all_bound_var
 16.1069 -                 | SOME false => make_exist_bound_var
 16.1070 -                 | NONE => make_bound_var)
 16.1071 -      in
 16.1072 -        do_formula ((s, (name, T)) :: bs) pos t'
 16.1073 -        #>> mk_aquant q [(name, SOME T)]
 16.1074 -        ##> union (op =) (atomic_types_of T)
 16.1075 -      end
 16.1076 -    and do_conn bs c pos1 t1 pos2 t2 =
 16.1077 -      do_formula bs pos1 t1 ##>> do_formula bs pos2 t2 #>> uncurry (mk_aconn c)
 16.1078 -    and do_formula bs pos t =
 16.1079 -      case t of
 16.1080 -        @{const Trueprop} $ t1 => do_formula bs pos t1
 16.1081 -      | @{const Not} $ t1 => do_formula bs (Option.map not pos) t1 #>> mk_anot
 16.1082 -      | Const (@{const_name All}, _) $ Abs (s, T, t') =>
 16.1083 -        do_quant bs AForall pos s T t'
 16.1084 -      | (t0 as Const (@{const_name All}, _)) $ t1 =>
 16.1085 -        do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1)
 16.1086 -      | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
 16.1087 -        do_quant bs AExists pos s T t'
 16.1088 -      | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
 16.1089 -        do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1)
 16.1090 -      | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd pos t1 pos t2
 16.1091 -      | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr pos t1 pos t2
 16.1092 -      | @{const HOL.implies} $ t1 $ t2 =>
 16.1093 -        do_conn bs AImplies (Option.map not pos) t1 pos t2
 16.1094 -      | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 =>
 16.1095 -        if eq_as_iff then do_conn bs AIff NONE t1 NONE t2 else do_term bs t
 16.1096 -      | _ => do_term bs t
 16.1097 -  in do_formula [] end
 16.1098 -
 16.1099 -fun presimplify_term ctxt t =
 16.1100 -  t |> exists_Const (member (op =) Meson.presimplified_consts o fst) t
 16.1101 -       ? (Skip_Proof.make_thm (Proof_Context.theory_of ctxt)
 16.1102 -          #> Meson.presimplify
 16.1103 -          #> prop_of)
 16.1104 -
 16.1105 -fun concealed_bound_name j = atp_weak_prefix ^ string_of_int j
 16.1106 -fun conceal_bounds Ts t =
 16.1107 -  subst_bounds (map (Free o apfst concealed_bound_name)
 16.1108 -                    (0 upto length Ts - 1 ~~ Ts), t)
 16.1109 -fun reveal_bounds Ts =
 16.1110 -  subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j))
 16.1111 -                    (0 upto length Ts - 1 ~~ Ts))
 16.1112 -
 16.1113 -fun is_fun_equality (@{const_name HOL.eq},
 16.1114 -                     Type (_, [Type (@{type_name fun}, _), _])) = true
 16.1115 -  | is_fun_equality _ = false
 16.1116 -
 16.1117 -fun extensionalize_term ctxt t =
 16.1118 -  if exists_Const is_fun_equality t then
 16.1119 -    let val thy = Proof_Context.theory_of ctxt in
 16.1120 -      t |> cterm_of thy |> Meson.extensionalize_conv ctxt
 16.1121 -        |> prop_of |> Logic.dest_equals |> snd
 16.1122 -    end
 16.1123 -  else
 16.1124 -    t
 16.1125 -
 16.1126 -fun simple_translate_lambdas do_lambdas ctxt t =
 16.1127 -  let val thy = Proof_Context.theory_of ctxt in
 16.1128 -    if Meson.is_fol_term thy t then
 16.1129 -      t
 16.1130 -    else
 16.1131 -      let
 16.1132 -        fun trans Ts t =
 16.1133 -          case t of
 16.1134 -            @{const Not} $ t1 => @{const Not} $ trans Ts t1
 16.1135 -          | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') =>
 16.1136 -            t0 $ Abs (s, T, trans (T :: Ts) t')
 16.1137 -          | (t0 as Const (@{const_name All}, _)) $ t1 =>
 16.1138 -            trans Ts (t0 $ eta_expand Ts t1 1)
 16.1139 -          | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') =>
 16.1140 -            t0 $ Abs (s, T, trans (T :: Ts) t')
 16.1141 -          | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
 16.1142 -            trans Ts (t0 $ eta_expand Ts t1 1)
 16.1143 -          | (t0 as @{const HOL.conj}) $ t1 $ t2 =>
 16.1144 -            t0 $ trans Ts t1 $ trans Ts t2
 16.1145 -          | (t0 as @{const HOL.disj}) $ t1 $ t2 =>
 16.1146 -            t0 $ trans Ts t1 $ trans Ts t2
 16.1147 -          | (t0 as @{const HOL.implies}) $ t1 $ t2 =>
 16.1148 -            t0 $ trans Ts t1 $ trans Ts t2
 16.1149 -          | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])))
 16.1150 -              $ t1 $ t2 =>
 16.1151 -            t0 $ trans Ts t1 $ trans Ts t2
 16.1152 -          | _ =>
 16.1153 -            if not (exists_subterm (fn Abs _ => true | _ => false) t) then t
 16.1154 -            else t |> Envir.eta_contract |> do_lambdas ctxt Ts
 16.1155 -        val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single
 16.1156 -      in t |> trans [] |> singleton (Variable.export_terms ctxt' ctxt) end
 16.1157 -  end
 16.1158 -
 16.1159 -fun do_cheaply_conceal_lambdas Ts (t1 $ t2) =
 16.1160 -    do_cheaply_conceal_lambdas Ts t1
 16.1161 -    $ do_cheaply_conceal_lambdas Ts t2
 16.1162 -  | do_cheaply_conceal_lambdas Ts (Abs (_, T, t)) =
 16.1163 -    Const (lam_lifted_poly_prefix ^ serial_string (),
 16.1164 -           T --> fastype_of1 (T :: Ts, t))
 16.1165 -  | do_cheaply_conceal_lambdas _ t = t
 16.1166 -
 16.1167 -fun do_introduce_combinators ctxt Ts t =
 16.1168 -  let val thy = Proof_Context.theory_of ctxt in
 16.1169 -    t |> conceal_bounds Ts
 16.1170 -      |> cterm_of thy
 16.1171 -      |> Meson_Clausify.introduce_combinators_in_cterm
 16.1172 -      |> prop_of |> Logic.dest_equals |> snd
 16.1173 -      |> reveal_bounds Ts
 16.1174 -  end
 16.1175 -  (* A type variable of sort "{}" will make abstraction fail. *)
 16.1176 -  handle THM _ => t |> do_cheaply_conceal_lambdas Ts
 16.1177 -val introduce_combinators = simple_translate_lambdas do_introduce_combinators
 16.1178 -
 16.1179 -fun preprocess_abstractions_in_terms trans_lams facts =
 16.1180 -  let
 16.1181 -    val (facts, lambda_ts) =
 16.1182 -      facts |> map (snd o snd) |> trans_lams
 16.1183 -            |>> map2 (fn (name, (kind, _)) => fn t => (name, (kind, t))) facts
 16.1184 -    val lam_facts =
 16.1185 -      map2 (fn t => fn j =>
 16.1186 -               ((lam_fact_prefix ^ Int.toString j, Helper), (Axiom, t)))
 16.1187 -           lambda_ts (1 upto length lambda_ts)
 16.1188 -  in (facts, lam_facts) end
 16.1189 -
 16.1190 -(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the
 16.1191 -   same in Sledgehammer to prevent the discovery of unreplayable proofs. *)
 16.1192 -fun freeze_term t =
 16.1193 -  let
 16.1194 -    fun freeze (t $ u) = freeze t $ freeze u
 16.1195 -      | freeze (Abs (s, T, t)) = Abs (s, T, freeze t)
 16.1196 -      | freeze (Var ((s, i), T)) =
 16.1197 -        Free (atp_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
 16.1198 -      | freeze t = t
 16.1199 -  in t |> exists_subterm is_Var t ? freeze end
 16.1200 -
 16.1201 -fun presimp_prop ctxt role t =
 16.1202 -  (let
 16.1203 -     val thy = Proof_Context.theory_of ctxt
 16.1204 -     val t = t |> Envir.beta_eta_contract
 16.1205 -               |> transform_elim_prop
 16.1206 -               |> Object_Logic.atomize_term thy
 16.1207 -     val need_trueprop = (fastype_of t = @{typ bool})
 16.1208 -   in
 16.1209 -     t |> need_trueprop ? HOLogic.mk_Trueprop
 16.1210 -       |> extensionalize_term ctxt
 16.1211 -       |> presimplify_term ctxt
 16.1212 -       |> HOLogic.dest_Trueprop
 16.1213 -   end
 16.1214 -   handle TERM _ => if role = Conjecture then @{term False} else @{term True})
 16.1215 -  |> pair role
 16.1216 -
 16.1217 -fun make_formula ctxt format type_enc eq_as_iff name loc kind t =
 16.1218 -  let
 16.1219 -    val (iformula, atomic_Ts) =
 16.1220 -      iformula_from_prop ctxt format type_enc eq_as_iff
 16.1221 -                         (SOME (kind <> Conjecture)) t []
 16.1222 -      |>> close_iformula_universally
 16.1223 -  in
 16.1224 -    {name = name, locality = loc, kind = kind, iformula = iformula,
 16.1225 -     atomic_types = atomic_Ts}
 16.1226 -  end
 16.1227 -
 16.1228 -fun make_fact ctxt format type_enc eq_as_iff ((name, loc), t) =
 16.1229 -  case t |> make_formula ctxt format type_enc (eq_as_iff andalso format <> CNF)
 16.1230 -                         name loc Axiom of
 16.1231 -    formula as {iformula = AAtom (IConst ((s, _), _, _)), ...} =>
 16.1232 -    if s = tptp_true then NONE else SOME formula
 16.1233 -  | formula => SOME formula
 16.1234 -
 16.1235 -fun s_not_trueprop (@{const Trueprop} $ t) = @{const Trueprop} $ s_not t
 16.1236 -  | s_not_trueprop t =
 16.1237 -    if fastype_of t = @{typ bool} then s_not t else @{prop False} (* too meta *)
 16.1238 -
 16.1239 -fun make_conjecture ctxt format type_enc =
 16.1240 -  map (fn ((name, loc), (kind, t)) =>
 16.1241 -          t |> kind = Conjecture ? s_not_trueprop
 16.1242 -            |> make_formula ctxt format type_enc (format <> CNF) name loc kind)
 16.1243 -
 16.1244 -(** Finite and infinite type inference **)
 16.1245 -
 16.1246 -fun tvar_footprint thy s ary =
 16.1247 -  (case unprefix_and_unascii const_prefix s of
 16.1248 -     SOME s =>
 16.1249 -     s |> invert_const |> robust_const_type thy |> chop_fun ary |> fst
 16.1250 -       |> map (fn T => Term.add_tvarsT T [] |> map fst)
 16.1251 -   | NONE => [])
 16.1252 -  handle TYPE _ => []
 16.1253 -
 16.1254 -fun ghost_type_args thy s ary =
 16.1255 -  if is_tptp_equal s then
 16.1256 -    0 upto ary - 1
 16.1257 -  else
 16.1258 -    let
 16.1259 -      val footprint = tvar_footprint thy s ary
 16.1260 -      val eq = (s = @{const_name HOL.eq})
 16.1261 -      fun ghosts _ [] = []
 16.1262 -        | ghosts seen ((i, tvars) :: args) =
 16.1263 -          ghosts (union (op =) seen tvars) args
 16.1264 -          |> (eq orelse exists (fn tvar => not (member (op =) seen tvar)) tvars)
 16.1265 -             ? cons i
 16.1266 -    in
 16.1267 -      if forall null footprint then
 16.1268 -        []
 16.1269 -      else
 16.1270 -        0 upto length footprint - 1 ~~ footprint
 16.1271 -        |> sort (rev_order o list_ord Term_Ord.indexname_ord o pairself snd)
 16.1272 -        |> ghosts []
 16.1273 -    end
 16.1274 -
 16.1275 -type monotonicity_info =
 16.1276 -  {maybe_finite_Ts : typ list,
 16.1277 -   surely_finite_Ts : typ list,
 16.1278 -   maybe_infinite_Ts : typ list,
 16.1279 -   surely_infinite_Ts : typ list,
 16.1280 -   maybe_nonmono_Ts : typ list}
 16.1281 -
 16.1282 -(* These types witness that the type classes they belong to allow infinite
 16.1283 -   models and hence that any types with these type classes is monotonic. *)
 16.1284 -val known_infinite_types =
 16.1285 -  [@{typ nat}, HOLogic.intT, HOLogic.realT, @{typ "nat => bool"}]
 16.1286 -
 16.1287 -fun is_type_kind_of_surely_infinite ctxt strictness cached_Ts T =
 16.1288 -  strictness <> Strict andalso is_type_surely_infinite ctxt true cached_Ts T
 16.1289 -
 16.1290 -(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are
 16.1291 -   dangerous because their "exhaust" properties can easily lead to unsound ATP
 16.1292 -   proofs. On the other hand, all HOL infinite types can be given the same
 16.1293 -   models in first-order logic (via Löwenheim-Skolem). *)
 16.1294 -
 16.1295 -fun should_encode_type _ (_ : monotonicity_info) All_Types _ = true
 16.1296 -  | should_encode_type ctxt {maybe_finite_Ts, surely_infinite_Ts,
 16.1297 -                             maybe_nonmono_Ts, ...}
 16.1298 -                       (Noninf_Nonmono_Types (strictness, grain)) T =
 16.1299 -    grain = Ghost_Type_Arg_Vars orelse
 16.1300 -    (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso
 16.1301 -     not (exists (type_instance ctxt T) surely_infinite_Ts orelse
 16.1302 -          (not (member (type_equiv ctxt) maybe_finite_Ts T) andalso
 16.1303 -           is_type_kind_of_surely_infinite ctxt strictness surely_infinite_Ts
 16.1304 -                                           T)))
 16.1305 -  | should_encode_type ctxt {surely_finite_Ts, maybe_infinite_Ts,
 16.1306 -                             maybe_nonmono_Ts, ...}
 16.1307 -                       (Fin_Nonmono_Types grain) T =
 16.1308 -    grain = Ghost_Type_Arg_Vars orelse
 16.1309 -    (exists (type_intersect ctxt T) maybe_nonmono_Ts andalso
 16.1310 -     (exists (type_generalization ctxt T) surely_finite_Ts orelse
 16.1311 -      (not (member (type_equiv ctxt) maybe_infinite_Ts T) andalso
 16.1312 -       is_type_surely_finite ctxt T)))
 16.1313 -  | should_encode_type _ _ _ _ = false
 16.1314 -
 16.1315 -fun should_guard_type ctxt mono (Guards (_, level)) should_guard_var T =
 16.1316 -    should_guard_var () andalso should_encode_type ctxt mono level T
 16.1317 -  | should_guard_type _ _ _ _ _ = false
 16.1318 -
 16.1319 -fun is_maybe_universal_var (IConst ((s, _), _, _)) =
 16.1320 -    String.isPrefix bound_var_prefix s orelse
 16.1321 -    String.isPrefix all_bound_var_prefix s
 16.1322 -  | is_maybe_universal_var (IVar _) = true
 16.1323 -  | is_maybe_universal_var _ = false
 16.1324 -
 16.1325 -datatype site =
 16.1326 -  Top_Level of bool option |
 16.1327 -  Eq_Arg of bool option |
 16.1328 -  Elsewhere
 16.1329 -
 16.1330 -fun should_tag_with_type _ _ _ (Top_Level _) _ _ = false
 16.1331 -  | should_tag_with_type ctxt mono (Tags (_, level)) site u T =
 16.1332 -    if granularity_of_type_level level = All_Vars then
 16.1333 -      should_encode_type ctxt mono level T
 16.1334 -    else
 16.1335 -      (case (site, is_maybe_universal_var u) of
 16.1336 -         (Eq_Arg _, true) => should_encode_type ctxt mono level T
 16.1337 -       | _ => false)
 16.1338 -  | should_tag_with_type _ _ _ _ _ _ = false
 16.1339 -
 16.1340 -fun fused_type ctxt mono level =
 16.1341 -  let
 16.1342 -    val should_encode = should_encode_type ctxt mono level
 16.1343 -    fun fuse 0 T = if should_encode T then T else fused_infinite_type
 16.1344 -      | fuse ary (Type (@{type_name fun}, [T1, T2])) =
 16.1345 -        fuse 0 T1 --> fuse (ary - 1) T2
 16.1346 -      | fuse _ _ = raise Fail "expected function type"
 16.1347 -  in fuse end
 16.1348 -
 16.1349 -(** predicators and application operators **)
 16.1350 -
 16.1351 -type sym_info =
 16.1352 -  {pred_sym : bool, min_ary : int, max_ary : int, types : typ list,
 16.1353 -   in_conj : bool}
 16.1354 -
 16.1355 -fun default_sym_tab_entries type_enc =
 16.1356 -  (make_fixed_const NONE @{const_name undefined},
 16.1357 -       {pred_sym = false, min_ary = 0, max_ary = 0, types = [],
 16.1358 -        in_conj = false}) ::
 16.1359 -  ([tptp_false, tptp_true]
 16.1360 -   |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = [],
 16.1361 -                  in_conj = false})) @
 16.1362 -  ([tptp_equal, tptp_old_equal]
 16.1363 -   |> map (rpair {pred_sym = true, min_ary = 2, max_ary = 2, types = [],
 16.1364 -                  in_conj = false}))
 16.1365 -  |> not (is_type_enc_higher_order type_enc)
 16.1366 -     ? cons (prefixed_predicator_name,
 16.1367 -             {pred_sym = true, min_ary = 1, max_ary = 1, types = [],
 16.1368 -              in_conj = false})
 16.1369 -
 16.1370 -fun sym_table_for_facts ctxt type_enc explicit_apply conjs facts =
 16.1371 -  let
 16.1372 -    fun consider_var_ary const_T var_T max_ary =
 16.1373 -      let
 16.1374 -        fun iter ary T =
 16.1375 -          if ary = max_ary orelse type_instance ctxt var_T T orelse
 16.1376 -             type_instance ctxt T var_T then
 16.1377 -            ary
 16.1378 -          else
 16.1379 -            iter (ary + 1) (range_type T)
 16.1380 -      in iter 0 const_T end
 16.1381 -    fun add_universal_var T (accum as ((bool_vars, fun_var_Ts), sym_tab)) =
 16.1382 -      if explicit_apply = NONE andalso
 16.1383 -         (can dest_funT T orelse T = @{typ bool}) then
 16.1384 -        let
 16.1385 -          val bool_vars' = bool_vars orelse body_type T = @{typ bool}
 16.1386 -          fun repair_min_ary {pred_sym, min_ary, max_ary, types, in_conj} =
 16.1387 -            {pred_sym = pred_sym andalso not bool_vars',
 16.1388 -             min_ary = fold (fn T' => consider_var_ary T' T) types min_ary,
 16.1389 -             max_ary = max_ary, types = types, in_conj = in_conj}
 16.1390 -          val fun_var_Ts' =
 16.1391 -            fun_var_Ts |> can dest_funT T ? insert_type ctxt I T
 16.1392 -        in
 16.1393 -          if bool_vars' = bool_vars andalso
 16.1394 -             pointer_eq (fun_var_Ts', fun_var_Ts) then
 16.1395 -            accum
 16.1396 -          else
 16.1397 -            ((bool_vars', fun_var_Ts'), Symtab.map (K repair_min_ary) sym_tab)
 16.1398 -        end
 16.1399 -      else
 16.1400 -        accum
 16.1401 -    fun add_fact_syms conj_fact =
 16.1402 -      let
 16.1403 -        fun add_iterm_syms top_level tm
 16.1404 -                           (accum as ((bool_vars, fun_var_Ts), sym_tab)) =
 16.1405 -          let val (head, args) = strip_iterm_comb tm in
 16.1406 -            (case head of
 16.1407 -               IConst ((s, _), T, _) =>
 16.1408 -               if String.isPrefix bound_var_prefix s orelse
 16.1409 -                  String.isPrefix all_bound_var_prefix s then
 16.1410 -                 add_universal_var T accum
 16.1411 -               else if String.isPrefix exist_bound_var_prefix s then
 16.1412 -                 accum
 16.1413 -               else
 16.1414 -                 let val ary = length args in
 16.1415 -                   ((bool_vars, fun_var_Ts),
 16.1416 -                    case Symtab.lookup sym_tab s of
 16.1417 -                      SOME {pred_sym, min_ary, max_ary, types, in_conj} =>
 16.1418 -                      let
 16.1419 -                        val pred_sym =
 16.1420 -                          pred_sym andalso top_level andalso not bool_vars
 16.1421 -                        val types' = types |> insert_type ctxt I T
 16.1422 -                        val in_conj = in_conj orelse conj_fact
 16.1423 -                        val min_ary =
 16.1424 -                          if is_some explicit_apply orelse
 16.1425 -                             pointer_eq (types', types) then
 16.1426 -                            min_ary
 16.1427 -                          else
 16.1428 -                            fold (consider_var_ary T) fun_var_Ts min_ary
 16.1429 -                      in
 16.1430 -                        Symtab.update (s, {pred_sym = pred_sym,
 16.1431 -                                           min_ary = Int.min (ary, min_ary),
 16.1432 -                                           max_ary = Int.max (ary, max_ary),
 16.1433 -                                           types = types', in_conj = in_conj})
 16.1434 -                                      sym_tab
 16.1435 -                      end
 16.1436 -                    | NONE =>
 16.1437 -                      let
 16.1438 -                        val pred_sym = top_level andalso not bool_vars
 16.1439 -                        val min_ary =
 16.1440 -                          case explicit_apply of
 16.1441 -                            SOME true => 0
 16.1442 -                          | SOME false => ary
 16.1443 -                          | NONE => fold (consider_var_ary T) fun_var_Ts ary
 16.1444 -                      in
 16.1445 -                        Symtab.update_new (s,
 16.1446 -                            {pred_sym = pred_sym, min_ary = min_ary,
 16.1447 -                             max_ary = ary, types = [T], in_conj = conj_fact})
 16.1448 -                            sym_tab
 16.1449 -                      end)
 16.1450 -                 end
 16.1451 -             | IVar (_, T) => add_universal_var T accum
 16.1452 -             | IAbs ((_, T), tm) =>
 16.1453 -               accum |> add_universal_var T |> add_iterm_syms false tm
 16.1454 -             | _ => accum)
 16.1455 -            |> fold (add_iterm_syms false) args
 16.1456 -          end
 16.1457 -      in K (add_iterm_syms true) |> formula_fold NONE |> fact_lift end
 16.1458 -  in
 16.1459 -    ((false, []), Symtab.empty)
 16.1460 -    |> fold (add_fact_syms true) conjs
 16.1461 -    |> fold (add_fact_syms false) facts
 16.1462 -    |> snd
 16.1463 -    |> fold Symtab.update (default_sym_tab_entries type_enc)
 16.1464 -  end
 16.1465 -
 16.1466 -fun min_ary_of sym_tab s =
 16.1467 -  case Symtab.lookup sym_tab s of
 16.1468 -    SOME ({min_ary, ...} : sym_info) => min_ary
 16.1469 -  | NONE =>
 16.1470 -    case unprefix_and_unascii const_prefix s of
 16.1471 -      SOME s =>
 16.1472 -      let val s = s |> unmangled_const_name |> invert_const in
 16.1473 -        if s = predicator_name then 1
 16.1474 -        else if s = app_op_name then 2
 16.1475 -        else if s = type_guard_name then 1
 16.1476 -        else 0
 16.1477 -      end
 16.1478 -    | NONE => 0
 16.1479 -
 16.1480 -(* True if the constant ever appears outside of the top-level position in
 16.1481 -   literals, or if it appears with different arities (e.g., because of different
 16.1482 -   type instantiations). If false, the constant always receives all of its
 16.1483 -   arguments and is used as a predicate. *)
 16.1484 -fun is_pred_sym sym_tab s =
 16.1485 -  case Symtab.lookup sym_tab s of
 16.1486 -    SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) =>
 16.1487 -    pred_sym andalso min_ary = max_ary
 16.1488 -  | NONE => false
 16.1489 -
 16.1490 -val app_op = `(make_fixed_const NONE) app_op_name
 16.1491 -val predicator_combconst =
 16.1492 -  IConst (`(make_fixed_const NONE) predicator_name, @{typ "bool => bool"}, [])
 16.1493 -
 16.1494 -fun list_app head args = fold (curry (IApp o swap)) args head
 16.1495 -fun predicator tm = IApp (predicator_combconst, tm)
 16.1496 -
 16.1497 -fun firstorderize_fact thy monom_constrs format type_enc sym_tab =
 16.1498 -  let
 16.1499 -    fun do_app arg head =
 16.1500 -      let
 16.1501 -        val head_T = ityp_of head
 16.1502 -        val (arg_T, res_T) = dest_funT head_T
 16.1503 -        val app =
 16.1504 -          IConst (app_op, head_T --> head_T, [arg_T, res_T])
 16.1505 -          |> mangle_type_args_in_iterm format type_enc
 16.1506 -      in list_app app [head, arg] end
 16.1507 -    fun list_app_ops head args = fold do_app args head
 16.1508 -    fun introduce_app_ops tm =
 16.1509 -      case strip_iterm_comb tm of
 16.1510 -        (head as IConst ((s, _), _, _), args) =>
 16.1511 -        args |> map introduce_app_ops
 16.1512 -             |> chop (min_ary_of sym_tab s)
 16.1513 -             |>> list_app head
 16.1514 -             |-> list_app_ops
 16.1515 -      | (head, args) => list_app_ops head (map introduce_app_ops args)
 16.1516 -    fun introduce_predicators tm =
 16.1517 -      case strip_iterm_comb tm of
 16.1518 -        (IConst ((s, _), _, _), _) =>
 16.1519 -        if is_pred_sym sym_tab s then tm else predicator tm
 16.1520 -      | _ => predicator tm
 16.1521 -    val do_iterm =
 16.1522 -      not (is_type_enc_higher_order type_enc)
 16.1523 -      ? (introduce_app_ops #> introduce_predicators)
 16.1524 -      #> filter_type_args_in_iterm thy monom_constrs type_enc
 16.1525 -  in update_iformula (formula_map do_iterm) end
 16.1526 -
 16.1527 -(** Helper facts **)
 16.1528 -
 16.1529 -val not_ffalse = @{lemma "~ fFalse" by (unfold fFalse_def) fast}
 16.1530 -val ftrue = @{lemma "fTrue" by (unfold fTrue_def) fast}
 16.1531 -
 16.1532 -(* The Boolean indicates that a fairly sound type encoding is needed. *)
 16.1533 -val helper_table =
 16.1534 -  [(("COMBI", false), @{thms Meson.COMBI_def}),
 16.1535 -   (("COMBK", false), @{thms Meson.COMBK_def}),
 16.1536 -   (("COMBB", false), @{thms Meson.COMBB_def}),
 16.1537 -   (("COMBC", false), @{thms Meson.COMBC_def}),
 16.1538 -   (("COMBS", false), @{thms Meson.COMBS_def}),
 16.1539 -   ((predicator_name, false), [not_ffalse, ftrue]),
 16.1540 -   (("fFalse", false), [not_ffalse]),
 16.1541 -   (("fFalse", true), @{thms True_or_False}),
 16.1542 -   (("fTrue", false), [ftrue]),
 16.1543 -   (("fTrue", true), @{thms True_or_False}),
 16.1544 -   (("fNot", false),
 16.1545 -    @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1]
 16.1546 -           fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]}),
 16.1547 -   (("fconj", false),
 16.1548 -    @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q"
 16.1549 -        by (unfold fconj_def) fast+}),
 16.1550 -   (("fdisj", false),
 16.1551 -    @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q"
 16.1552 -        by (unfold fdisj_def) fast+}),
 16.1553 -   (("fimplies", false),
 16.1554 -    @{lemma "P | fimplies P Q" "~ Q | fimplies P Q" "~ fimplies P Q | ~ P | Q"
 16.1555 -        by (unfold fimplies_def) fast+}),
 16.1556 -   (("fequal", true),
 16.1557 -    (* This is a lie: Higher-order equality doesn't need a sound type encoding.
 16.1558 -       However, this is done so for backward compatibility: Including the
 16.1559 -       equality helpers by default in Metis breaks a few existing proofs. *)
 16.1560 -    @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1]
 16.1561 -           fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]}),
 16.1562 -   (* Partial characterization of "fAll" and "fEx". A complete characterization
 16.1563 -      would require the axiom of choice for replay with Metis. *)
 16.1564 -   (("fAll", false), [@{lemma "~ fAll P | P x" by (auto simp: fAll_def)}]),
 16.1565 -   (("fEx", false), [@{lemma "~ P x | fEx P" by (auto simp: fEx_def)}]),
 16.1566 -   (("If", true), @{thms if_True if_False True_or_False})]
 16.1567 -  |> map (apsnd (map zero_var_indexes))
 16.1568 -
 16.1569 -fun atype_of_type_vars (Simple_Types (_, Polymorphic, _)) = SOME atype_of_types
 16.1570 -  | atype_of_type_vars _ = NONE
 16.1571 -
 16.1572 -fun bound_tvars type_enc sorts Ts =
 16.1573 -  (sorts ? mk_ahorn (formulas_for_types type_enc add_sorts_on_tvar Ts))
 16.1574 -  #> mk_aquant AForall
 16.1575 -        (map_filter (fn TVar (x as (s, _), _) =>
 16.1576 -                        SOME ((make_schematic_type_var x, s),
 16.1577 -                              atype_of_type_vars type_enc)
 16.1578 -                      | _ => NONE) Ts)
 16.1579 -
 16.1580 -fun eq_formula type_enc atomic_Ts pred_sym tm1 tm2 =
 16.1581 -  (if pred_sym then AConn (AIff, [AAtom tm1, AAtom tm2])
 16.1582 -   else AAtom (ATerm (`I tptp_equal, [tm1, tm2])))
 16.1583 -  |> close_formula_universally
 16.1584 -  |> bound_tvars type_enc true atomic_Ts
 16.1585 -
 16.1586 -val type_tag = `(make_fixed_const NONE) type_tag_name
 16.1587 -
 16.1588 -fun type_tag_idempotence_fact format type_enc =
 16.1589 -  let
 16.1590 -    fun var s = ATerm (`I s, [])
 16.1591 -    fun tag tm = ATerm (type_tag, [var "A", tm])
 16.1592 -    val tagged_var = tag (var "X")
 16.1593 -  in
 16.1594 -    Formula (type_tag_idempotence_helper_name, Axiom,
 16.1595 -             eq_formula type_enc [] false (tag tagged_var) tagged_var,
 16.1596 -             isabelle_info format simpN, NONE)
 16.1597 -  end
 16.1598 -
 16.1599 -fun should_specialize_helper type_enc t =
 16.1600 -  polymorphism_of_type_enc type_enc <> Polymorphic andalso
 16.1601 -  level_of_type_enc type_enc <> No_Types andalso
 16.1602 -  not (null (Term.hidden_polymorphism t))
 16.1603 -
 16.1604 -fun helper_facts_for_sym ctxt format type_enc (s, {types, ...} : sym_info) =
 16.1605 -  case unprefix_and_unascii const_prefix s of
 16.1606 -    SOME mangled_s =>
 16.1607 -    let
 16.1608 -      val thy = Proof_Context.theory_of ctxt
 16.1609 -      val unmangled_s = mangled_s |> unmangled_const_name
 16.1610 -      fun dub needs_fairly_sound j k =
 16.1611 -        (unmangled_s ^ "_" ^ string_of_int j ^ "_" ^ string_of_int k ^
 16.1612 -         (if mangled_s = unmangled_s then "" else "_" ^ ascii_of mangled_s) ^
 16.1613 -         (if needs_fairly_sound then typed_helper_suffix
 16.1614 -          else untyped_helper_suffix),
 16.1615 -         Helper)
 16.1616 -      fun dub_and_inst needs_fairly_sound (th, j) =
 16.1617 -        let val t = prop_of th in
 16.1618 -          if should_specialize_helper type_enc t then
 16.1619 -            map (fn T => specialize_type thy (invert_const unmangled_s, T) t)
 16.1620 -                types
 16.1621 -          else
 16.1622 -            [t]
 16.1623 -        end
 16.1624 -        |> map (fn (k, t) => (dub needs_fairly_sound j k, t)) o tag_list 1
 16.1625 -      val make_facts = map_filter (make_fact ctxt format type_enc false)
 16.1626 -      val fairly_sound = is_type_enc_fairly_sound type_enc
 16.1627 -    in
 16.1628 -      helper_table
 16.1629 -      |> maps (fn ((helper_s, needs_fairly_sound), ths) =>
 16.1630 -                  if helper_s <> unmangled_s orelse
 16.1631 -                     (needs_fairly_sound andalso not fairly_sound) then
 16.1632 -                    []
 16.1633 -                  else
 16.1634 -                    ths ~~ (1 upto length ths)
 16.1635 -                    |> maps (dub_and_inst needs_fairly_sound)
 16.1636 -                    |> make_facts)
 16.1637 -    end
 16.1638 -  | NONE => []
 16.1639 -fun helper_facts_for_sym_table ctxt format type_enc sym_tab =
 16.1640 -  Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_enc) sym_tab
 16.1641 -                  []
 16.1642 -
 16.1643 -(***************************************************************)
 16.1644 -(* Type Classes Present in the Axiom or Conjecture Clauses     *)
 16.1645 -(***************************************************************)
 16.1646 -
 16.1647 -fun set_insert (x, s) = Symtab.update (x, ()) s
 16.1648 -
 16.1649 -fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
 16.1650 -
 16.1651 -(* Remove this trivial type class (FIXME: similar code elsewhere) *)
 16.1652 -fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset
 16.1653 -
 16.1654 -fun classes_of_terms get_Ts =
 16.1655 -  map (map snd o get_Ts)
 16.1656 -  #> List.foldl add_classes Symtab.empty
 16.1657 -  #> delete_type #> Symtab.keys
 16.1658 -
 16.1659 -val tfree_classes_of_terms = classes_of_terms Misc_Legacy.term_tfrees
 16.1660 -val tvar_classes_of_terms = classes_of_terms Misc_Legacy.term_tvars
 16.1661 -
 16.1662 -fun fold_type_constrs f (Type (s, Ts)) x =
 16.1663 -    fold (fold_type_constrs f) Ts (f (s, x))
 16.1664 -  | fold_type_constrs _ _ x = x
 16.1665 -
 16.1666 -(* Type constructors used to instantiate overloaded constants are the only ones
 16.1667 -   needed. *)
 16.1668 -fun add_type_constrs_in_term thy =
 16.1669 -  let
 16.1670 -    fun add (Const (@{const_name Meson.skolem}, _) $ _) = I
 16.1671 -      | add (t $ u) = add t #> add u
 16.1672 -      | add (Const x) =
 16.1673 -        x |> robust_const_typargs thy |> fold (fold_type_constrs set_insert)
 16.1674 -      | add (Abs (_, _, u)) = add u
 16.1675 -      | add _ = I
 16.1676 -  in add end
 16.1677 -
 16.1678 -fun type_constrs_of_terms thy ts =
 16.1679 -  Symtab.keys (fold (add_type_constrs_in_term thy) ts Symtab.empty)
 16.1680 -
 16.1681 -fun extract_lambda_def (Const (@{const_name HOL.eq}, _) $ t $ u) =
 16.1682 -    let val (head, args) = strip_comb t in
 16.1683 -      (head |> dest_Const |> fst,
 16.1684 -       fold_rev (fn t as Var ((s, _), T) =>
 16.1685 -                    (fn u => Abs (s, T, abstract_over (t, u)))
 16.1686 -                  | _ => raise Fail "expected Var") args u)
 16.1687 -    end
 16.1688 -  | extract_lambda_def _ = raise Fail "malformed lifted lambda"
 16.1689 -
 16.1690 -fun trans_lams_from_string ctxt type_enc lam_trans =
 16.1691 -  if lam_trans = no_lamsN then
 16.1692 -    rpair []
 16.1693 -  else if lam_trans = hide_lamsN then
 16.1694 -    lift_lams ctxt type_enc ##> K []
 16.1695 -  else if lam_trans = lam_liftingN then
 16.1696 -    lift_lams ctxt type_enc
 16.1697 -  else if lam_trans = combinatorsN then
 16.1698 -    map (introduce_combinators ctxt) #> rpair []
 16.1699 -  else if lam_trans = hybrid_lamsN then
 16.1700 -    lift_lams_part_1 ctxt type_enc
 16.1701 -    ##> maps (fn t => [t, introduce_combinators ctxt (intentionalize_def t)])
 16.1702 -    #> lift_lams_part_2
 16.1703 -  else if lam_trans = keep_lamsN then
 16.1704 -    map (Envir.eta_contract) #> rpair []
 16.1705 -  else
 16.1706 -    error ("Unknown lambda translation scheme: " ^ quote lam_trans ^ ".")
 16.1707 -
 16.1708 -fun translate_formulas ctxt format prem_kind type_enc lam_trans presimp hyp_ts
 16.1709 -                       concl_t facts =
 16.1710 -  let
 16.1711 -    val thy = Proof_Context.theory_of ctxt
 16.1712 -    val trans_lams = trans_lams_from_string ctxt type_enc lam_trans
 16.1713 -    val fact_ts = facts |> map snd
 16.1714 -    (* Remove existing facts from the conjecture, as this can dramatically
 16.1715 -       boost an ATP's performance (for some reason). *)
 16.1716 -    val hyp_ts =
 16.1717 -      hyp_ts
 16.1718 -      |> map (fn t => if member (op aconv) fact_ts t then @{prop True} else t)
 16.1719 -    val facts = facts |> map (apsnd (pair Axiom))
 16.1720 -    val conjs =
 16.1721 -      map (pair prem_kind) hyp_ts @ [(Conjecture, s_not_trueprop concl_t)]
 16.1722 -      |> map (apsnd freeze_term)
 16.1723 -      |> map2 (pair o rpair Local o string_of_int) (0 upto length hyp_ts)
 16.1724 -    val ((conjs, facts), lam_facts) =
 16.1725 -      (conjs, facts)
 16.1726 -      |> presimp ? pairself (map (apsnd (uncurry (presimp_prop ctxt))))
 16.1727 -      |> (if lam_trans = no_lamsN then
 16.1728 -            rpair []
 16.1729 -          else
 16.1730 -            op @
 16.1731 -            #> preprocess_abstractions_in_terms trans_lams
 16.1732 -            #>> chop (length conjs))
 16.1733 -    val conjs = conjs |> make_conjecture ctxt format type_enc
 16.1734 -    val (fact_names, facts) =
 16.1735 -      facts
 16.1736 -      |> map_filter (fn (name, (_, t)) =>
 16.1737 -                        make_fact ctxt format type_enc true (name, t)
 16.1738 -                        |> Option.map (pair name))
 16.1739 -      |> ListPair.unzip
 16.1740 -    val lifted = lam_facts |> map (extract_lambda_def o snd o snd)
 16.1741 -    val lam_facts =
 16.1742 -      lam_facts |> map_filter (make_fact ctxt format type_enc true o apsnd snd)
 16.1743 -    val all_ts = concl_t :: hyp_ts @ fact_ts
 16.1744 -    val subs = tfree_classes_of_terms all_ts
 16.1745 -    val supers = tvar_classes_of_terms all_ts
 16.1746 -    val tycons = type_constrs_of_terms thy all_ts
 16.1747 -    val (supers, arity_clauses) =
 16.1748 -      if level_of_type_enc type_enc = No_Types then ([], [])
 16.1749 -      else make_arity_clauses thy tycons supers
 16.1750 -    val class_rel_clauses = make_class_rel_clauses thy subs supers
 16.1751 -  in
 16.1752 -    (fact_names |> map single, union (op =) subs supers, conjs,
 16.1753 -     facts @ lam_facts, class_rel_clauses, arity_clauses, lifted)
 16.1754 -  end
 16.1755 -
 16.1756 -val type_guard = `(make_fixed_const NONE) type_guard_name
 16.1757 -
 16.1758 -fun type_guard_iterm format type_enc T tm =
 16.1759 -  IApp (IConst (type_guard, T --> @{typ bool}, [T])
 16.1760 -        |> mangle_type_args_in_iterm format type_enc, tm)
 16.1761 -
 16.1762 -fun is_var_positively_naked_in_term _ (SOME false) _ accum = accum
 16.1763 -  | is_var_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum =
 16.1764 -    accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, [])))
 16.1765 -  | is_var_positively_naked_in_term _ _ _ _ = true
 16.1766 -
 16.1767 -fun is_var_ghost_type_arg_in_term thy polym_constrs name pos tm accum =
 16.1768 -  is_var_positively_naked_in_term name pos tm accum orelse
 16.1769 -  let
 16.1770 -    val var = ATerm (name, [])
 16.1771 -    fun is_nasty_in_term (ATerm (_, [])) = false
 16.1772 -      | is_nasty_in_term (ATerm ((s, _), tms)) =
 16.1773 -        let
 16.1774 -          val ary = length tms
 16.1775 -          val polym_constr = member (op =) polym_constrs s
 16.1776 -          val ghosts = ghost_type_args thy s ary
 16.1777 -        in
 16.1778 -          exists (fn (j, tm) =>
 16.1779 -                     if polym_constr then
 16.1780 -                       member (op =) ghosts j andalso
 16.1781 -                       (tm = var orelse is_nasty_in_term tm)
 16.1782 -                     else
 16.1783 -                       tm = var andalso member (op =) ghosts j)
 16.1784 -                 (0 upto ary - 1 ~~ tms)
 16.1785 -          orelse (not polym_constr andalso exists is_nasty_in_term tms)
 16.1786 -        end
 16.1787 -      | is_nasty_in_term _ = true
 16.1788 -  in is_nasty_in_term tm end
 16.1789 -
 16.1790 -fun should_guard_var_in_formula thy polym_constrs level pos phi (SOME true)
 16.1791 -                                name =
 16.1792 -    (case granularity_of_type_level level of
 16.1793 -       All_Vars => true
 16.1794 -     | Positively_Naked_Vars =>
 16.1795 -       formula_fold pos (is_var_positively_naked_in_term name) phi false
 16.1796 -     | Ghost_Type_Arg_Vars =>
 16.1797 -       formula_fold pos (is_var_ghost_type_arg_in_term thy polym_constrs name)
 16.1798 -                    phi false)
 16.1799 -  | should_guard_var_in_formula _ _ _ _ _ _ _ = true
 16.1800 -
 16.1801 -fun always_guard_var_in_formula _ _ _ _ _ _ _ = true
 16.1802 -
 16.1803 -fun should_generate_tag_bound_decl _ _ _ (SOME true) _ = false
 16.1804 -  | should_generate_tag_bound_decl ctxt mono (Tags (_, level)) _ T =
 16.1805 -    granularity_of_type_level level <> All_Vars andalso
 16.1806 -    should_encode_type ctxt mono level T
 16.1807 -  | should_generate_tag_bound_decl _ _ _ _ _ = false
 16.1808 -
 16.1809 -fun mk_aterm format type_enc name T_args args =
 16.1810 -  ATerm (name, map_filter (ho_term_for_type_arg format type_enc) T_args @ args)
 16.1811 -
 16.1812 -fun tag_with_type ctxt format mono type_enc pos T tm =
 16.1813 -  IConst (type_tag, T --> T, [T])
 16.1814 -  |> mangle_type_args_in_iterm format type_enc
 16.1815 -  |> ho_term_from_iterm ctxt format mono type_enc pos
 16.1816 -  |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm])
 16.1817 -       | _ => raise Fail "unexpected lambda-abstraction")
 16.1818 -and ho_term_from_iterm ctxt format mono type_enc =
 16.1819 -  let
 16.1820 -    fun term site u =
 16.1821 -      let
 16.1822 -        val (head, args) = strip_iterm_comb u
 16.1823 -        val pos =
 16.1824 -          case site of
 16.1825 -            Top_Level pos => pos
 16.1826 -          | Eq_Arg pos => pos
 16.1827 -          | _ => NONE
 16.1828 -        val t =
 16.1829 -          case head of
 16.1830 -            IConst (name as (s, _), _, T_args) =>
 16.1831 -            let
 16.1832 -              val arg_site = if is_tptp_equal s then Eq_Arg pos else Elsewhere
 16.1833 -            in
 16.1834 -              map (term arg_site) args |> mk_aterm format type_enc name T_args
 16.1835 -            end
 16.1836 -          | IVar (name, _) =>
 16.1837 -            map (term Elsewhere) args |> mk_aterm format type_enc name []
 16.1838 -          | IAbs ((name, T), tm) =>
 16.1839 -            AAbs ((name, ho_type_from_typ format type_enc true 0 T),
 16.1840 -                  term Elsewhere tm)
 16.1841 -          | IApp _ => raise Fail "impossible \"IApp\""
 16.1842 -        val T = ityp_of u
 16.1843 -      in
 16.1844 -        if should_tag_with_type ctxt mono type_enc site u T then
 16.1845 -          tag_with_type ctxt format mono type_enc pos T t
 16.1846 -        else
 16.1847 -          t
 16.1848 -      end
 16.1849 -  in term o Top_Level end
 16.1850 -and formula_from_iformula ctxt polym_constrs format mono type_enc
 16.1851 -                          should_guard_var =
 16.1852 -  let
 16.1853 -    val thy = Proof_Context.theory_of ctxt
 16.1854 -    val level = level_of_type_enc type_enc
 16.1855 -    val do_term = ho_term_from_iterm ctxt format mono type_enc
 16.1856 -    val do_bound_type =
 16.1857 -      case type_enc of
 16.1858 -        Simple_Types _ => fused_type ctxt mono level 0
 16.1859 -        #> ho_type_from_typ format type_enc false 0 #> SOME
 16.1860 -      | _ => K NONE
 16.1861 -    fun do_out_of_bound_type pos phi universal (name, T) =
 16.1862 -      if should_guard_type ctxt mono type_enc
 16.1863 -             (fn () => should_guard_var thy polym_constrs level pos phi
 16.1864 -                                        universal name) T then
 16.1865 -        IVar (name, T)
 16.1866 -        |> type_guard_iterm format type_enc T
 16.1867 -        |> do_term pos |> AAtom |> SOME
 16.1868 -      else if should_generate_tag_bound_decl ctxt mono type_enc universal T then
 16.1869 -        let
 16.1870 -          val var = ATerm (name, [])
 16.1871 -          val tagged_var = tag_with_type ctxt format mono type_enc pos T var
 16.1872 -        in SOME (AAtom (ATerm (`I tptp_equal, [tagged_var, var]))) end
 16.1873 -      else
 16.1874 -        NONE
 16.1875 -    fun do_formula pos (AQuant (q, xs, phi)) =
 16.1876 -        let
 16.1877 -          val phi = phi |> do_formula pos
 16.1878 -          val universal = Option.map (q = AExists ? not) pos
 16.1879 -        in
 16.1880 -          AQuant (q, xs |> map (apsnd (fn NONE => NONE
 16.1881 -                                        | SOME T => do_bound_type T)),
 16.1882 -                  (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd))
 16.1883 -                      (map_filter
 16.1884 -                           (fn (_, NONE) => NONE
 16.1885 -                             | (s, SOME T) =>
 16.1886 -                               do_out_of_bound_type pos phi universal (s, T))
 16.1887 -                           xs)
 16.1888 -                      phi)
 16.1889 -        end
 16.1890 -      | do_formula pos (AConn conn) = aconn_map pos do_formula conn
 16.1891 -      | do_formula pos (AAtom tm) = AAtom (do_term pos tm)
 16.1892 -  in do_formula end
 16.1893 -
 16.1894 -(* Each fact is given a unique fact number to avoid name clashes (e.g., because
 16.1895 -   of monomorphization). The TPTP explicitly forbids name clashes, and some of
 16.1896 -   the remote provers might care. *)
 16.1897 -fun formula_line_for_fact ctxt polym_constrs format prefix encode freshen pos
 16.1898 -        mono type_enc (j, {name, locality, kind, iformula, atomic_types}) =
 16.1899 -  (prefix ^ (if freshen then string_of_int j ^ "_" else "") ^ encode name, kind,
 16.1900 -   iformula
 16.1901 -   |> formula_from_iformula ctxt polym_constrs format mono type_enc
 16.1902 -          should_guard_var_in_formula (if pos then SOME true else NONE)
 16.1903 -   |> close_formula_universally
 16.1904 -   |> bound_tvars type_enc true atomic_types,
 16.1905 -   NONE,
 16.1906 -   case locality of
 16.1907 -     Intro => isabelle_info format introN
 16.1908 -   | Elim => isabelle_info format elimN
 16.1909 -   | Simp => isabelle_info format simpN
 16.1910 -   | _ => NONE)
 16.1911 -  |> Formula
 16.1912 -
 16.1913 -fun formula_line_for_class_rel_clause format type_enc
 16.1914 -        ({name, subclass, superclass, ...} : class_rel_clause) =
 16.1915 -  let val ty_arg = ATerm (tvar_a_name, []) in
 16.1916 -    Formula (class_rel_clause_prefix ^ ascii_of name, Axiom,
 16.1917 -             AConn (AImplies,
 16.1918 -                    [type_class_formula type_enc subclass ty_arg,
 16.1919 -                     type_class_formula type_enc superclass ty_arg])
 16.1920 -             |> mk_aquant AForall
 16.1921 -                          [(tvar_a_name, atype_of_type_vars type_enc)],
 16.1922 -             isabelle_info format introN, NONE)
 16.1923 -  end
 16.1924 -
 16.1925 -fun formula_from_arity_atom type_enc (class, t, args) =
 16.1926 -  ATerm (t, map (fn arg => ATerm (arg, [])) args)
 16.1927 -  |> type_class_formula type_enc class
 16.1928 -
 16.1929 -fun formula_line_for_arity_clause format type_enc
 16.1930 -        ({name, prem_atoms, concl_atom} : arity_clause) =
 16.1931 -  Formula (arity_clause_prefix ^ name, Axiom,
 16.1932 -           mk_ahorn (map (formula_from_arity_atom type_enc) prem_atoms)
 16.1933 -                    (formula_from_arity_atom type_enc concl_atom)
 16.1934 -           |> mk_aquant AForall
 16.1935 -                  (map (rpair (atype_of_type_vars type_enc)) (#3 concl_atom)),
 16.1936 -           isabelle_info format introN, NONE)
 16.1937 -
 16.1938 -fun formula_line_for_conjecture ctxt polym_constrs format mono type_enc
 16.1939 -        ({name, kind, iformula, atomic_types, ...} : translated_formula) =
 16.1940 -  Formula (conjecture_prefix ^ name, kind,
 16.1941 -           iformula
 16.1942 -           |> formula_from_iformula ctxt polym_constrs format mono type_enc
 16.1943 -                  should_guard_var_in_formula (SOME false)
 16.1944 -           |> close_formula_universally
 16.1945 -           |> bound_tvars type_enc true atomic_types, NONE, NONE)
 16.1946 -
 16.1947 -fun formula_line_for_free_type j phi =
 16.1948 -  Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, phi, NONE, NONE)
 16.1949 -fun formula_lines_for_free_types type_enc (facts : translated_formula list) =
 16.1950 -  let
 16.1951 -    val phis =
 16.1952 -      fold (union (op =)) (map #atomic_types facts) []
 16.1953 -      |> formulas_for_types type_enc add_sorts_on_tfree
 16.1954 -  in map2 formula_line_for_free_type (0 upto length phis - 1) phis end
 16.1955 -
 16.1956 -(** Symbol declarations **)
 16.1957 -
 16.1958 -fun decl_line_for_class order s =
 16.1959 -  let val name as (s, _) = `make_type_class s in
 16.1960 -    Decl (sym_decl_prefix ^ s, name,
 16.1961 -          if order = First_Order then
 16.1962 -            ATyAbs ([tvar_a_name],
 16.1963 -                    if avoid_first_order_ghost_type_vars then
 16.1964 -                      AFun (a_itself_atype, bool_atype)
 16.1965 -                    else
 16.1966 -                      bool_atype)
 16.1967 -          else
 16.1968 -            AFun (atype_of_types, bool_atype))
 16.1969 -  end
 16.1970 -
 16.1971 -fun decl_lines_for_classes type_enc classes =
 16.1972 -  case type_enc of
 16.1973 -    Simple_Types (order, Polymorphic, _) =>
 16.1974 -    map (decl_line_for_class order) classes
 16.1975 -  | _ => []
 16.1976 -
 16.1977 -fun sym_decl_table_for_facts ctxt format type_enc sym_tab (conjs, facts) =
 16.1978 -  let
 16.1979 -    fun add_iterm_syms tm =
 16.1980 -      let val (head, args) = strip_iterm_comb tm in
 16.1981 -        (case head of
 16.1982 -           IConst ((s, s'), T, T_args) =>
 16.1983 -           let
 16.1984 -             val (pred_sym, in_conj) =
 16.1985 -               case Symtab.lookup sym_tab s of
 16.1986 -                 SOME ({pred_sym, in_conj, ...} : sym_info) =>
 16.1987 -                 (pred_sym, in_conj)
 16.1988 -               | NONE => (false, false)
 16.1989 -             val decl_sym =
 16.1990 -               (case type_enc of
 16.1991 -                  Guards _ => not pred_sym
 16.1992 -                | _ => true) andalso
 16.1993 -               is_tptp_user_symbol s
 16.1994 -           in
 16.1995 -             if decl_sym then
 16.1996 -               Symtab.map_default (s, [])
 16.1997 -                   (insert_type ctxt #3 (s', T_args, T, pred_sym, length args,
 16.1998 -                                         in_conj))
 16.1999 -             else
 16.2000 -               I
 16.2001 -           end
 16.2002 -         | IAbs (_, tm) => add_iterm_syms tm
 16.2003 -         | _ => I)
 16.2004 -        #> fold add_iterm_syms args
 16.2005 -      end
 16.2006 -    val add_fact_syms = K add_iterm_syms |> formula_fold NONE |> fact_lift
 16.2007 -    fun add_formula_var_types (AQuant (_, xs, phi)) =
 16.2008 -        fold (fn (_, SOME T) => insert_type ctxt I T | _ => I) xs
 16.2009 -        #> add_formula_var_types phi
 16.2010 -      | add_formula_var_types (AConn (_, phis)) =
 16.2011 -        fold add_formula_var_types phis
 16.2012 -      | add_formula_var_types _ = I
 16.2013 -    fun var_types () =
 16.2014 -      if polymorphism_of_type_enc type_enc = Polymorphic then [tvar_a]
 16.2015 -      else fold (fact_lift add_formula_var_types) (conjs @ facts) []
 16.2016 -    fun add_undefined_const T =
 16.2017 -      let
 16.2018 -        val (s, s') =
 16.2019 -          `(make_fixed_const NONE) @{const_name undefined}
 16.2020 -          |> (case type_arg_policy [] type_enc @{const_name undefined} of
 16.2021 -                Mangled_Type_Args => mangled_const_name format type_enc [T]
 16.2022 -              | _ => I)
 16.2023 -      in
 16.2024 -        Symtab.map_default (s, [])
 16.2025 -                           (insert_type ctxt #3 (s', [T], T, false, 0, false))
 16.2026 -      end
 16.2027 -    fun add_TYPE_const () =
 16.2028 -      let val (s, s') = TYPE_name in
 16.2029 -        Symtab.map_default (s, [])
 16.2030 -            (insert_type ctxt #3
 16.2031 -                         (s', [tvar_a], @{typ "'a itself"}, false, 0, false))
 16.2032 -      end
 16.2033 -  in
 16.2034 -    Symtab.empty
 16.2035 -    |> is_type_enc_fairly_sound type_enc
 16.2036 -       ? (fold (fold add_fact_syms) [conjs, facts]
 16.2037 -          #> (case type_enc of
 16.2038 -                Simple_Types (First_Order, Polymorphic, _) =>
 16.2039 -                if avoid_first_order_ghost_type_vars then add_TYPE_const ()
 16.2040 -                else I
 16.2041 -              | Simple_Types _ => I
 16.2042 -              | _ => fold add_undefined_const (var_types ())))
 16.2043 -  end
 16.2044 -
 16.2045 -(* We add "bool" in case the helper "True_or_False" is included later. *)
 16.2046 -fun default_mono level =
 16.2047 -  {maybe_finite_Ts = [@{typ bool}],
 16.2048 -   surely_finite_Ts = [@{typ bool}],
 16.2049 -   maybe_infinite_Ts = known_infinite_types,
 16.2050 -   surely_infinite_Ts =
 16.2051 -     case level of
 16.2052 -       Noninf_Nonmono_Types (Strict, _) => []
 16.2053 -     | _ => known_infinite_types,
 16.2054 -   maybe_nonmono_Ts = [@{typ bool}]}
 16.2055 -
 16.2056 -(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it
 16.2057 -   out with monotonicity" paper presented at CADE 2011. *)
 16.2058 -fun add_iterm_mononotonicity_info _ _ (SOME false) _ mono = mono
 16.2059 -  | add_iterm_mononotonicity_info ctxt level _
 16.2060 -        (IApp (IApp (IConst ((s, _), Type (_, [T, _]), _), tm1), tm2))
 16.2061 -        (mono as {maybe_finite_Ts, surely_finite_Ts, maybe_infinite_Ts,
 16.2062 -                  surely_infinite_Ts, maybe_nonmono_Ts}) =
 16.2063 -    if is_tptp_equal s andalso exists is_maybe_universal_var [tm1, tm2] then
 16.2064 -      case level of
 16.2065 -        Noninf_Nonmono_Types (strictness, _) =>
 16.2066 -        if exists (type_instance ctxt T) surely_infinite_Ts orelse
 16.2067 -           member (type_equiv ctxt) maybe_finite_Ts T then
 16.2068 -          mono
 16.2069 -        else if is_type_kind_of_surely_infinite ctxt strictness
 16.2070 -                                                surely_infinite_Ts T then
 16.2071 -          {maybe_finite_Ts = maybe_finite_Ts,
 16.2072 -           surely_finite_Ts = surely_finite_Ts,
 16.2073 -           maybe_infinite_Ts = maybe_infinite_Ts,
 16.2074 -           surely_infinite_Ts = surely_infinite_Ts |> insert_type ctxt I T,
 16.2075 -           maybe_nonmono_Ts = maybe_nonmono_Ts}
 16.2076 -        else
 16.2077 -          {maybe_finite_Ts = maybe_finite_Ts |> insert (type_equiv ctxt) T,
 16.2078 -           surely_finite_Ts = surely_finite_Ts,
 16.2079 -           maybe_infinite_Ts = maybe_infinite_Ts,
 16.2080 -           surely_infinite_Ts = surely_infinite_Ts,
 16.2081 -           maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T}
 16.2082 -      | Fin_Nonmono_Types _ =>
 16.2083 -        if exists (type_instance ctxt T) surely_finite_Ts orelse
 16.2084 -           member (type_equiv ctxt) maybe_infinite_Ts T then
 16.2085 -          mono
 16.2086 -        else if is_type_surely_finite ctxt T then
 16.2087 -          {maybe_finite_Ts = maybe_finite_Ts,
 16.2088 -           surely_finite_Ts = surely_finite_Ts |> insert_type ctxt I T,
 16.2089 -           maybe_infinite_Ts = maybe_infinite_Ts,
 16.2090 -           surely_infinite_Ts = surely_infinite_Ts,
 16.2091 -           maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type ctxt I T}
 16.2092 -        else
 16.2093 -          {maybe_finite_Ts = maybe_finite_Ts,
 16.2094 -           surely_finite_Ts = surely_finite_Ts,
 16.2095 -           maybe_infinite_Ts = maybe_infinite_Ts |> insert (type_equiv ctxt) T,
 16.2096 -           surely_infinite_Ts = surely_infinite_Ts,
 16.2097 -           maybe_nonmono_Ts = maybe_nonmono_Ts}
 16.2098 -      | _ => mono
 16.2099 -    else
 16.2100 -      mono
 16.2101 -  | add_iterm_mononotonicity_info _ _ _ _ mono = mono
 16.2102 -fun add_fact_mononotonicity_info ctxt level
 16.2103 -        ({kind, iformula, ...} : translated_formula) =
 16.2104 -  formula_fold (SOME (kind <> Conjecture))
 16.2105 -               (add_iterm_mononotonicity_info ctxt level) iformula
 16.2106 -fun mononotonicity_info_for_facts ctxt type_enc facts =
 16.2107 -  let val level = level_of_type_enc type_enc in
 16.2108 -    default_mono level
 16.2109 -    |> is_type_level_monotonicity_based level
 16.2110 -       ? fold (add_fact_mononotonicity_info ctxt level) facts
 16.2111 -  end
 16.2112 -
 16.2113 -fun add_iformula_monotonic_types ctxt mono type_enc =
 16.2114 -  let
 16.2115 -    val level = level_of_type_enc type_enc
 16.2116 -    val should_encode = should_encode_type ctxt mono level
 16.2117 -    fun add_type T = not (should_encode T) ? insert_type ctxt I T
 16.2118 -    fun add_args (IApp (tm1, tm2)) = add_args tm1 #> add_term tm2
 16.2119 -      | add_args _ = I
 16.2120 -    and add_term tm = add_type (ityp_of tm) #> add_args tm
 16.2121 -  in formula_fold NONE (K add_term) end
 16.2122 -fun add_fact_monotonic_types ctxt mono type_enc =
 16.2123 -  add_iformula_monotonic_types ctxt mono type_enc |> fact_lift
 16.2124 -fun monotonic_types_for_facts ctxt mono type_enc facts =
 16.2125 -  let val level = level_of_type_enc type_enc in
 16.2126 -    [] |> (polymorphism_of_type_enc type_enc = Polymorphic andalso
 16.2127 -           is_type_level_monotonicity_based level andalso
 16.2128 -           granularity_of_type_level level <> Ghost_Type_Arg_Vars)
 16.2129 -          ? fold (add_fact_monotonic_types ctxt mono type_enc) facts
 16.2130 -  end
 16.2131 -
 16.2132 -fun formula_line_for_guards_mono_type ctxt format mono type_enc T =
 16.2133 -  Formula (guards_sym_formula_prefix ^
 16.2134 -           ascii_of (mangled_type format type_enc T),
 16.2135 -           Axiom,
 16.2136 -           IConst (`make_bound_var "X", T, [])
 16.2137 -           |> type_guard_iterm format type_enc T
 16.2138 -           |> AAtom
 16.2139 -           |> formula_from_iformula ctxt [] format mono type_enc
 16.2140 -                                    always_guard_var_in_formula (SOME true)
 16.2141 -           |> close_formula_universally
 16.2142 -           |> bound_tvars type_enc true (atomic_types_of T),
 16.2143 -           isabelle_info format introN, NONE)
 16.2144 -
 16.2145 -fun formula_line_for_tags_mono_type ctxt format mono type_enc T =
 16.2146 -  let val x_var = ATerm (`make_bound_var "X", []) in
 16.2147 -    Formula (tags_sym_formula_prefix ^
 16.2148 -             ascii_of (mangled_type format type_enc T),
 16.2149 -             Axiom,
 16.2150 -             eq_formula type_enc (atomic_types_of T) false
 16.2151 -                  (tag_with_type ctxt format mono type_enc NONE T x_var) x_var,
 16.2152 -             isabelle_info format simpN, NONE)
 16.2153 -  end
 16.2154 -
 16.2155 -fun problem_lines_for_mono_types ctxt format mono type_enc Ts =
 16.2156 -  case type_enc of
 16.2157 -    Simple_Types _ => []
 16.2158 -  | Guards _ =>
 16.2159 -    map (formula_line_for_guards_mono_type ctxt format mono type_enc) Ts
 16.2160 -  | Tags _ => map (formula_line_for_tags_mono_type ctxt format mono type_enc) Ts
 16.2161 -
 16.2162 -fun decl_line_for_sym ctxt format mono type_enc s
 16.2163 -                      (s', T_args, T, pred_sym, ary, _) =
 16.2164 -  let
 16.2165 -    val thy = Proof_Context.theory_of ctxt
 16.2166 -    val (T, T_args) =
 16.2167 -      if null T_args then
 16.2168 -        (T, [])
 16.2169 -      else case unprefix_and_unascii const_prefix s of
 16.2170 -        SOME s' =>
 16.2171 -        let
 16.2172 -          val s' = s' |> invert_const
 16.2173 -          val T = s' |> robust_const_type thy
 16.2174 -        in (T, robust_const_typargs thy (s', T)) end
 16.2175 -      | NONE => raise Fail "unexpected type arguments"
 16.2176 -  in
 16.2177 -    Decl (sym_decl_prefix ^ s, (s, s'),
 16.2178 -          T |> fused_type ctxt mono (level_of_type_enc type_enc) ary
 16.2179 -            |> ho_type_from_typ format type_enc pred_sym ary
 16.2180 -            |> not (null T_args)
 16.2181 -               ? curry ATyAbs (map (tvar_name o fst o dest_TVar) T_args))
 16.2182 -  end
 16.2183 -
 16.2184 -fun formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono type_enc n s
 16.2185 -                                     j (s', T_args, T, _, ary, in_conj) =
 16.2186 -  let
 16.2187 -    val thy = Proof_Context.theory_of ctxt
 16.2188 -    val (kind, maybe_negate) =
 16.2189 -      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 16.2190 -      else (Axiom, I)
 16.2191 -    val (arg_Ts, res_T) = chop_fun ary T
 16.2192 -    val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int)
 16.2193 -    val bounds =
 16.2194 -      bound_names ~~ arg_Ts |> map (fn (name, T) => IConst (name, T, []))
 16.2195 -    val bound_Ts =
 16.2196 -      if exists (curry (op =) dummyT) T_args then
 16.2197 -        case level_of_type_enc type_enc of
 16.2198 -          All_Types => map SOME arg_Ts
 16.2199 -        | level =>
 16.2200 -          if granularity_of_type_level level = Ghost_Type_Arg_Vars then
 16.2201 -            let val ghosts = ghost_type_args thy s ary in
 16.2202 -              map2 (fn j => if member (op =) ghosts j then SOME else K NONE)
 16.2203 -                   (0 upto ary - 1) arg_Ts
 16.2204 -            end
 16.2205 -          else
 16.2206 -            replicate ary NONE
 16.2207 -      else
 16.2208 -        replicate ary NONE
 16.2209 -  in
 16.2210 -    Formula (guards_sym_formula_prefix ^ s ^
 16.2211 -             (if n > 1 then "_" ^ string_of_int j else ""), kind,
 16.2212 -             IConst ((s, s'), T, T_args)
 16.2213 -             |> fold (curry (IApp o swap)) bounds
 16.2214 -             |> type_guard_iterm format type_enc res_T
 16.2215 -             |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts)
 16.2216 -             |> formula_from_iformula ctxt [] format mono type_enc
 16.2217 -                                      always_guard_var_in_formula (SOME true)
 16.2218 -             |> close_formula_universally
 16.2219 -             |> bound_tvars type_enc (n > 1) (atomic_types_of T)
 16.2220 -             |> maybe_negate,
 16.2221 -             isabelle_info format introN, NONE)
 16.2222 -  end
 16.2223 -
 16.2224 -fun formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono type_enc n s
 16.2225 -        (j, (s', T_args, T, pred_sym, ary, in_conj)) =
 16.2226 -  let
 16.2227 -    val thy = Proof_Context.theory_of ctxt
 16.2228 -    val level = level_of_type_enc type_enc
 16.2229 -    val grain = granularity_of_type_level level
 16.2230 -    val ident_base =
 16.2231 -      tags_sym_formula_prefix ^ s ^
 16.2232 -      (if n > 1 then "_" ^ string_of_int j else "")
 16.2233 -    val (kind, maybe_negate) =
 16.2234 -      if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
 16.2235 -      else (Axiom, I)
 16.2236 -    val (arg_Ts, res_T) = chop_fun ary T
 16.2237 -    val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int)
 16.2238 -    val bounds = bound_names |> map (fn name => ATerm (name, []))
 16.2239 -    val cst = mk_aterm format type_enc (s, s') T_args
 16.2240 -    val eq = maybe_negate oo eq_formula type_enc (atomic_types_of T) pred_sym
 16.2241 -    val should_encode = should_encode_type ctxt mono level
 16.2242 -    val tag_with = tag_with_type ctxt format mono type_enc NONE
 16.2243 -    val add_formula_for_res =
 16.2244 -      if should_encode res_T then
 16.2245 -        let
 16.2246 -          val tagged_bounds =
 16.2247 -            if grain = Ghost_Type_Arg_Vars then
 16.2248 -              let val ghosts = ghost_type_args thy s ary in
 16.2249 -                map2 (fn (j, arg_T) => member (op =) ghosts j ? tag_with arg_T)
 16.2250 -                     (0 upto ary - 1 ~~ arg_Ts) bounds
 16.2251 -              end
 16.2252 -            else
 16.2253 -              bounds
 16.2254 -        in
 16.2255 -          cons (Formula (ident_base ^ "_res", kind,
 16.2256 -                         eq (tag_with res_T (cst bounds)) (cst tagged_bounds),
 16.2257 -                         isabelle_info format simpN, NONE))
 16.2258 -        end
 16.2259 -      else
 16.2260 -        I
 16.2261 -    fun add_formula_for_arg k =
 16.2262 -      let val arg_T = nth arg_Ts k in
 16.2263 -        if should_encode arg_T then
 16.2264 -          case chop k bounds of
 16.2265 -            (bounds1, bound :: bounds2) =>
 16.2266 -            cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind,
 16.2267 -                           eq (cst (bounds1 @ tag_with arg_T bound :: bounds2))
 16.2268 -                              (cst bounds),
 16.2269 -                           isabelle_info format simpN, NONE))
 16.2270 -          | _ => raise Fail "expected nonempty tail"
 16.2271 -        else
 16.2272 -          I
 16.2273 -      end
 16.2274 -  in
 16.2275 -    [] |> not pred_sym ? add_formula_for_res
 16.2276 -       |> (Config.get ctxt type_tag_arguments andalso
 16.2277 -           grain = Positively_Naked_Vars)
 16.2278 -          ? fold add_formula_for_arg (ary - 1 downto 0)
 16.2279 -  end
 16.2280 -
 16.2281 -fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
 16.2282 -
 16.2283 -fun rationalize_decls ctxt (decls as decl :: (decls' as _ :: _)) =
 16.2284 -    let
 16.2285 -      val T = result_type_of_decl decl
 16.2286 -              |> map_type_tvar (fn (z, _) => TVar (z, HOLogic.typeS))
 16.2287 -    in
 16.2288 -      if forall (type_generalization ctxt T o result_type_of_decl) decls' then
 16.2289 -        [decl]
 16.2290 -      else
 16.2291 -        decls
 16.2292 -    end
 16.2293 -  | rationalize_decls _ decls = decls
 16.2294 -
 16.2295 -fun problem_lines_for_sym_decls ctxt format conj_sym_kind mono type_enc
 16.2296 -                                (s, decls) =
 16.2297 -  case type_enc of
 16.2298 -    Simple_Types _ => [decl_line_for_sym ctxt format mono type_enc s (hd decls)]
 16.2299 -  | Guards (_, level) =>
 16.2300 -    let
 16.2301 -      val decls = decls |> rationalize_decls ctxt
 16.2302 -      val n = length decls
 16.2303 -      val decls =
 16.2304 -        decls |> filter (should_encode_type ctxt mono level
 16.2305 -                         o result_type_of_decl)
 16.2306 -    in
 16.2307 -      (0 upto length decls - 1, decls)
 16.2308 -      |-> map2 (formula_line_for_guards_sym_decl ctxt format conj_sym_kind mono
 16.2309 -                                                 type_enc n s)
 16.2310 -    end
 16.2311 -  | Tags (_, level) =>
 16.2312 -    if granularity_of_type_level level = All_Vars then
 16.2313 -      []
 16.2314 -    else
 16.2315 -      let val n = length decls in
 16.2316 -        (0 upto n - 1 ~~ decls)
 16.2317 -        |> maps (formula_lines_for_tags_sym_decl ctxt format conj_sym_kind mono
 16.2318 -                                                 type_enc n s)
 16.2319 -      end
 16.2320 -
 16.2321 -fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono type_enc
 16.2322 -                                     mono_Ts sym_decl_tab =