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 =
16.2323 - let
16.2324 - val syms = sym_decl_tab |> Symtab.dest |> sort_wrt fst
16.2325 - val mono_lines =
16.2326 - problem_lines_for_mono_types ctxt format mono type_enc mono_Ts
16.2327 - val decl_lines =
16.2328 - fold_rev (append o problem_lines_for_sym_decls ctxt format conj_sym_kind
16.2329 - mono type_enc)
16.2330 - syms []
16.2331 - in mono_lines @ decl_lines end
16.2332 -
16.2333 -fun needs_type_tag_idempotence ctxt (Tags (poly, level)) =
16.2334 - Config.get ctxt type_tag_idempotence andalso
16.2335 - is_type_level_monotonicity_based level andalso
16.2336 - poly <> Mangled_Monomorphic
16.2337 - | needs_type_tag_idempotence _ _ = false
16.2338 -
16.2339 -val implicit_declsN = "Should-be-implicit typings"
16.2340 -val explicit_declsN = "Explicit typings"
16.2341 -val factsN = "Relevant facts"
16.2342 -val class_relsN = "Class relationships"
16.2343 -val aritiesN = "Arities"
16.2344 -val helpersN = "Helper facts"
16.2345 -val conjsN = "Conjectures"
16.2346 -val free_typesN = "Type variables"
16.2347 -
16.2348 -(* TFF allows implicit declarations of types, function symbols, and predicate
16.2349 - symbols (with "$i" as the type of individuals), but some provers (e.g.,
16.2350 - SNARK) require explicit declarations. The situation is similar for THF. *)
16.2351 -
16.2352 -fun default_type type_enc pred_sym s =
16.2353 - let
16.2354 - val ind =
16.2355 - case type_enc of
16.2356 - Simple_Types _ =>
16.2357 - if String.isPrefix type_const_prefix s then atype_of_types
16.2358 - else individual_atype
16.2359 - | _ => individual_atype
16.2360 - fun typ 0 = if pred_sym then bool_atype else ind
16.2361 - | typ ary = AFun (ind, typ (ary - 1))
16.2362 - in typ end
16.2363 -
16.2364 -fun nary_type_constr_type n =
16.2365 - funpow n (curry AFun atype_of_types) atype_of_types
16.2366 -
16.2367 -fun undeclared_syms_in_problem type_enc problem =
16.2368 - let
16.2369 - val declared = declared_syms_in_problem problem
16.2370 - fun do_sym name ty =
16.2371 - if member (op =) declared name then I else AList.default (op =) (name, ty)
16.2372 - fun do_type (AType (name as (s, _), tys)) =
16.2373 - is_tptp_user_symbol s
16.2374 - ? do_sym name (fn () => nary_type_constr_type (length tys))
16.2375 - #> fold do_type tys
16.2376 - | do_type (AFun (ty1, ty2)) = do_type ty1 #> do_type ty2
16.2377 - | do_type (ATyAbs (_, ty)) = do_type ty
16.2378 - fun do_term pred_sym (ATerm (name as (s, _), tms)) =
16.2379 - is_tptp_user_symbol s
16.2380 - ? do_sym name (fn _ => default_type type_enc pred_sym s (length tms))
16.2381 - #> fold (do_term false) tms
16.2382 - | do_term _ (AAbs ((_, ty), tm)) = do_type ty #> do_term false tm
16.2383 - fun do_formula (AQuant (_, xs, phi)) =
16.2384 - fold do_type (map_filter snd xs) #> do_formula phi
16.2385 - | do_formula (AConn (_, phis)) = fold do_formula phis
16.2386 - | do_formula (AAtom tm) = do_term true tm
16.2387 - fun do_problem_line (Decl (_, _, ty)) = do_type ty
16.2388 - | do_problem_line (Formula (_, _, phi, _, _)) = do_formula phi
16.2389 - in
16.2390 - fold (fold do_problem_line o snd) problem []
16.2391 - |> filter_out (is_built_in_tptp_symbol o fst o fst)
16.2392 - end
16.2393 -
16.2394 -fun declare_undeclared_syms_in_atp_problem type_enc problem =
16.2395 - let
16.2396 - val decls =
16.2397 - problem
16.2398 - |> undeclared_syms_in_problem type_enc
16.2399 - |> sort_wrt (fst o fst)
16.2400 - |> map (fn (x as (s, _), ty) => Decl (type_decl_prefix ^ s, x, ty ()))
16.2401 - in (implicit_declsN, decls) :: problem end
16.2402 -
16.2403 -fun exists_subdtype P =
16.2404 - let
16.2405 - fun ex U = P U orelse
16.2406 - (case U of Datatype.DtType (_, Us) => exists ex Us | _ => false)
16.2407 - in ex end
16.2408 -
16.2409 -fun is_poly_constr (_, Us) =
16.2410 - exists (exists_subdtype (fn Datatype.DtTFree _ => true | _ => false)) Us
16.2411 -
16.2412 -fun all_constrs_of_polymorphic_datatypes thy =
16.2413 - Symtab.fold (snd
16.2414 - #> #descr
16.2415 - #> maps (snd #> #3)
16.2416 - #> (fn cs => exists is_poly_constr cs ? append cs))
16.2417 - (Datatype.get_all thy) []
16.2418 - |> List.partition is_poly_constr
16.2419 - |> pairself (map fst)
16.2420 -
16.2421 -(* Forcing explicit applications is expensive for polymorphic encodings, because
16.2422 - it takes only one existential variable ranging over "'a => 'b" to ruin
16.2423 - everything. Hence we do it only if there are few facts (is normally the case
16.2424 - for "metis" and the minimizer. *)
16.2425 -val explicit_apply_threshold = 50
16.2426 -
16.2427 -fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_enc exporter
16.2428 - lam_trans readable_names preproc hyp_ts concl_t facts =
16.2429 - let
16.2430 - val thy = Proof_Context.theory_of ctxt
16.2431 - val type_enc = type_enc |> adjust_type_enc format
16.2432 - val explicit_apply =
16.2433 - if polymorphism_of_type_enc type_enc <> Polymorphic orelse
16.2434 - length facts <= explicit_apply_threshold then
16.2435 - NONE
16.2436 - else
16.2437 - SOME false
16.2438 - val lam_trans =
16.2439 - if lam_trans = keep_lamsN andalso
16.2440 - not (is_type_enc_higher_order type_enc) then
16.2441 - error ("Lambda translation scheme incompatible with first-order \
16.2442 - \encoding.")
16.2443 - else
16.2444 - lam_trans
16.2445 - val (fact_names, classes, conjs, facts, class_rel_clauses, arity_clauses,
16.2446 - lifted) =
16.2447 - translate_formulas ctxt format prem_kind type_enc lam_trans preproc hyp_ts
16.2448 - concl_t facts
16.2449 - val sym_tab = sym_table_for_facts ctxt type_enc explicit_apply conjs facts
16.2450 - val mono = conjs @ facts |> mononotonicity_info_for_facts ctxt type_enc
16.2451 - val (polym_constrs, monom_constrs) =
16.2452 - all_constrs_of_polymorphic_datatypes thy
16.2453 - |>> map (make_fixed_const (SOME format))
16.2454 - val firstorderize =
16.2455 - firstorderize_fact thy monom_constrs format type_enc sym_tab
16.2456 - val (conjs, facts) = (conjs, facts) |> pairself (map firstorderize)
16.2457 - val sym_tab = sym_table_for_facts ctxt type_enc (SOME false) conjs facts
16.2458 - val helpers =
16.2459 - sym_tab |> helper_facts_for_sym_table ctxt format type_enc
16.2460 - |> map firstorderize
16.2461 - val mono_Ts =
16.2462 - helpers @ conjs @ facts |> monotonic_types_for_facts ctxt mono type_enc
16.2463 - val class_decl_lines = decl_lines_for_classes type_enc classes
16.2464 - val sym_decl_lines =
16.2465 - (conjs, helpers @ facts)
16.2466 - |> sym_decl_table_for_facts ctxt format type_enc sym_tab
16.2467 - |> problem_lines_for_sym_decl_table ctxt format conj_sym_kind mono
16.2468 - type_enc mono_Ts
16.2469 - val helper_lines =
16.2470 - 0 upto length helpers - 1 ~~ helpers
16.2471 - |> map (formula_line_for_fact ctxt polym_constrs format helper_prefix I
16.2472 - false true mono type_enc)
16.2473 - |> (if needs_type_tag_idempotence ctxt type_enc then
16.2474 - cons (type_tag_idempotence_fact format type_enc)
16.2475 - else
16.2476 - I)
16.2477 - (* Reordering these might confuse the proof reconstruction code or the SPASS
16.2478 - FLOTTER hack. *)
16.2479 - val problem =
16.2480 - [(explicit_declsN, class_decl_lines @ sym_decl_lines),
16.2481 - (factsN,
16.2482 - map (formula_line_for_fact ctxt polym_constrs format fact_prefix
16.2483 - ascii_of (not exporter) (not exporter) mono type_enc)
16.2484 - (0 upto length facts - 1 ~~ facts)),
16.2485 - (class_relsN,
16.2486 - map (formula_line_for_class_rel_clause format type_enc)
16.2487 - class_rel_clauses),
16.2488 - (aritiesN,
16.2489 - map (formula_line_for_arity_clause format type_enc) arity_clauses),
16.2490 - (helpersN, helper_lines),
16.2491 - (conjsN,
16.2492 - map (formula_line_for_conjecture ctxt polym_constrs format mono
16.2493 - type_enc) conjs),
16.2494 - (free_typesN, formula_lines_for_free_types type_enc (facts @ conjs))]
16.2495 - val problem =
16.2496 - problem
16.2497 - |> (case format of
16.2498 - CNF => ensure_cnf_problem
16.2499 - | CNF_UEQ => filter_cnf_ueq_problem
16.2500 - | FOF => I
16.2501 - | TFF (_, TPTP_Implicit) => I
16.2502 - | THF (_, TPTP_Implicit, _) => I
16.2503 - | _ => declare_undeclared_syms_in_atp_problem type_enc)
16.2504 - val (problem, pool) = problem |> nice_atp_problem readable_names format
16.2505 - fun add_sym_ary (s, {min_ary, ...} : sym_info) =
16.2506 - min_ary > 0 ? Symtab.insert (op =) (s, min_ary)
16.2507 - in
16.2508 - (problem,
16.2509 - case pool of SOME the_pool => snd the_pool | NONE => Symtab.empty,
16.2510 - fact_names |> Vector.fromList,
16.2511 - lifted,
16.2512 - Symtab.empty |> Symtab.fold add_sym_ary sym_tab)
16.2513 - end
16.2514 -
16.2515 -(* FUDGE *)
16.2516 -val conj_weight = 0.0
16.2517 -val hyp_weight = 0.1
16.2518 -val fact_min_weight = 0.2
16.2519 -val fact_max_weight = 1.0
16.2520 -val type_info_default_weight = 0.8
16.2521 -
16.2522 -fun add_term_weights weight (ATerm (s, tms)) =
16.2523 - is_tptp_user_symbol s ? Symtab.default (s, weight)
16.2524 - #> fold (add_term_weights weight) tms
16.2525 - | add_term_weights weight (AAbs (_, tm)) = add_term_weights weight tm
16.2526 -fun add_problem_line_weights weight (Formula (_, _, phi, _, _)) =
16.2527 - formula_fold NONE (K (add_term_weights weight)) phi
16.2528 - | add_problem_line_weights _ _ = I
16.2529 -
16.2530 -fun add_conjectures_weights [] = I
16.2531 - | add_conjectures_weights conjs =
16.2532 - let val (hyps, conj) = split_last conjs in
16.2533 - add_problem_line_weights conj_weight conj
16.2534 - #> fold (add_problem_line_weights hyp_weight) hyps
16.2535 - end
16.2536 -
16.2537 -fun add_facts_weights facts =
16.2538 - let
16.2539 - val num_facts = length facts
16.2540 - fun weight_of j =
16.2541 - fact_min_weight + (fact_max_weight - fact_min_weight) * Real.fromInt j
16.2542 - / Real.fromInt num_facts
16.2543 - in
16.2544 - map weight_of (0 upto num_facts - 1) ~~ facts
16.2545 - |> fold (uncurry add_problem_line_weights)
16.2546 - end
16.2547 -
16.2548 -(* Weights are from 0.0 (most important) to 1.0 (least important). *)
16.2549 -fun atp_problem_weights problem =
16.2550 - let val get = these o AList.lookup (op =) problem in
16.2551 - Symtab.empty
16.2552 - |> add_conjectures_weights (get free_typesN @ get conjsN)
16.2553 - |> add_facts_weights (get factsN)
16.2554 - |> fold (fold (add_problem_line_weights type_info_default_weight) o get)
16.2555 - [explicit_declsN, class_relsN, aritiesN]
16.2556 - |> Symtab.dest
16.2557 - |> sort (prod_ord Real.compare string_ord o pairself swap)
16.2558 - end
16.2559 -
16.2560 -end;
17.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2 +++ b/src/HOL/Tools/Metis/metis_generate.ML Mon Jan 23 17:40:32 2012 +0100
17.3 @@ -0,0 +1,256 @@
17.4 +(* Title: HOL/Tools/Metis/metis_generate.ML
17.5 + Author: Jia Meng, Cambridge University Computer Laboratory and NICTA
17.6 + Author: Kong W. Susanto, Cambridge University Computer Laboratory
17.7 + Author: Lawrence C. Paulson, Cambridge University Computer Laboratory
17.8 + Author: Jasmin Blanchette, TU Muenchen
17.9 +
17.10 +Translation of HOL to FOL for Metis.
17.11 +*)
17.12 +
17.13 +signature METIS_GENERATE =
17.14 +sig
17.15 + type type_enc = ATP_Problem_Generate.type_enc
17.16 +
17.17 + datatype isa_thm =
17.18 + Isa_Reflexive_or_Trivial |
17.19 + Isa_Lambda_Lifted |
17.20 + Isa_Raw of thm
17.21 +
17.22 + val metis_equal : string
17.23 + val metis_predicator : string
17.24 + val metis_app_op : string
17.25 + val metis_systematic_type_tag : string
17.26 + val metis_ad_hoc_type_tag : string
17.27 + val metis_generated_var_prefix : string
17.28 + val trace : bool Config.T
17.29 + val verbose : bool Config.T
17.30 + val trace_msg : Proof.context -> (unit -> string) -> unit
17.31 + val verbose_warning : Proof.context -> string -> unit
17.32 + val metis_name_table : ((string * int) * ((type_enc -> string) * bool)) list
17.33 + val reveal_old_skolem_terms : (string * term) list -> term -> term
17.34 + val reveal_lam_lifted : (string * term) list -> term -> term
17.35 + val prepare_metis_problem :
17.36 + Proof.context -> type_enc -> string -> thm list -> thm list
17.37 + -> int Symtab.table * (Metis_Thm.thm * isa_thm) list
17.38 + * ((string * term) list * (string * term) list)
17.39 +end
17.40 +
17.41 +structure Metis_Generate : METIS_GENERATE =
17.42 +struct
17.43 +
17.44 +open ATP_Problem
17.45 +open ATP_Problem_Generate
17.46 +
17.47 +val metis_equal = "="
17.48 +val metis_predicator = "{}"
17.49 +val metis_app_op = Metis_Name.toString Metis_Term.appName
17.50 +val metis_systematic_type_tag =
17.51 + Metis_Name.toString Metis_Term.hasTypeFunctionName
17.52 +val metis_ad_hoc_type_tag = "**"
17.53 +val metis_generated_var_prefix = "_"
17.54 +
17.55 +val trace = Attrib.setup_config_bool @{binding metis_trace} (K false)
17.56 +val verbose = Attrib.setup_config_bool @{binding metis_verbose} (K true)
17.57 +
17.58 +fun trace_msg ctxt msg = if Config.get ctxt trace then tracing (msg ()) else ()
17.59 +fun verbose_warning ctxt msg =
17.60 + if Config.get ctxt verbose then warning ("Metis: " ^ msg) else ()
17.61 +
17.62 +val metis_name_table =
17.63 + [((tptp_equal, 2), (K metis_equal, false)),
17.64 + ((tptp_old_equal, 2), (K metis_equal, false)),
17.65 + ((prefixed_predicator_name, 1), (K metis_predicator, false)),
17.66 + ((prefixed_app_op_name, 2), (K metis_app_op, false)),
17.67 + ((prefixed_type_tag_name, 2),
17.68 + (fn type_enc =>
17.69 + if level_of_type_enc type_enc = All_Types then metis_systematic_type_tag
17.70 + else metis_ad_hoc_type_tag, true))]
17.71 +
17.72 +fun old_skolem_const_name i j num_T_args =
17.73 + old_skolem_const_prefix ^ Long_Name.separator ^
17.74 + (space_implode Long_Name.separator (map string_of_int [i, j, num_T_args]))
17.75 +
17.76 +fun conceal_old_skolem_terms i old_skolems t =
17.77 + if exists_Const (curry (op =) @{const_name Meson.skolem} o fst) t then
17.78 + let
17.79 + fun aux old_skolems
17.80 + (t as (Const (@{const_name Meson.skolem}, Type (_, [_, T])) $ _)) =
17.81 + let
17.82 + val (old_skolems, s) =
17.83 + if i = ~1 then
17.84 + (old_skolems, @{const_name undefined})
17.85 + else case AList.find (op aconv) old_skolems t of
17.86 + s :: _ => (old_skolems, s)
17.87 + | [] =>
17.88 + let
17.89 + val s = old_skolem_const_name i (length old_skolems)
17.90 + (length (Term.add_tvarsT T []))
17.91 + in ((s, t) :: old_skolems, s) end
17.92 + in (old_skolems, Const (s, T)) end
17.93 + | aux old_skolems (t1 $ t2) =
17.94 + let
17.95 + val (old_skolems, t1) = aux old_skolems t1
17.96 + val (old_skolems, t2) = aux old_skolems t2
17.97 + in (old_skolems, t1 $ t2) end
17.98 + | aux old_skolems (Abs (s, T, t')) =
17.99 + let val (old_skolems, t') = aux old_skolems t' in
17.100 + (old_skolems, Abs (s, T, t'))
17.101 + end
17.102 + | aux old_skolems t = (old_skolems, t)
17.103 + in aux old_skolems t end
17.104 + else
17.105 + (old_skolems, t)
17.106 +
17.107 +fun reveal_old_skolem_terms old_skolems =
17.108 + map_aterms (fn t as Const (s, _) =>
17.109 + if String.isPrefix old_skolem_const_prefix s then
17.110 + AList.lookup (op =) old_skolems s |> the
17.111 + |> map_types (map_type_tvar (K dummyT))
17.112 + else
17.113 + t
17.114 + | t => t)
17.115 +
17.116 +fun reveal_lam_lifted lambdas =
17.117 + map_aterms (fn t as Const (s, _) =>
17.118 + if String.isPrefix lam_lifted_prefix s then
17.119 + case AList.lookup (op =) lambdas s of
17.120 + SOME t =>
17.121 + Const (@{const_name Metis.lambda}, dummyT)
17.122 + $ map_types (map_type_tvar (K dummyT))
17.123 + (reveal_lam_lifted lambdas t)
17.124 + | NONE => t
17.125 + else
17.126 + t
17.127 + | t => t)
17.128 +
17.129 +
17.130 +(* ------------------------------------------------------------------------- *)
17.131 +(* Logic maps manage the interface between HOL and first-order logic. *)
17.132 +(* ------------------------------------------------------------------------- *)
17.133 +
17.134 +datatype isa_thm =
17.135 + Isa_Reflexive_or_Trivial |
17.136 + Isa_Lambda_Lifted |
17.137 + Isa_Raw of thm
17.138 +
17.139 +val proxy_defs = map (fst o snd o snd) proxy_table
17.140 +val prepare_helper =
17.141 + Meson.make_meta_clause #> rewrite_rule (map safe_mk_meta_eq proxy_defs)
17.142 +
17.143 +fun metis_term_from_atp type_enc (ATerm (s, tms)) =
17.144 + if is_tptp_variable s then
17.145 + Metis_Term.Var (Metis_Name.fromString s)
17.146 + else
17.147 + (case AList.lookup (op =) metis_name_table (s, length tms) of
17.148 + SOME (f, swap) => (f type_enc, swap)
17.149 + | NONE => (s, false))
17.150 + |> (fn (s, swap) =>
17.151 + Metis_Term.Fn (Metis_Name.fromString s,
17.152 + tms |> map (metis_term_from_atp type_enc)
17.153 + |> swap ? rev))
17.154 +fun metis_atom_from_atp type_enc (AAtom tm) =
17.155 + (case metis_term_from_atp type_enc tm of
17.156 + Metis_Term.Fn x => x
17.157 + | _ => raise Fail "non CNF -- expected function")
17.158 + | metis_atom_from_atp _ _ = raise Fail "not CNF -- expected atom"
17.159 +fun metis_literal_from_atp type_enc (AConn (ANot, [phi])) =
17.160 + (false, metis_atom_from_atp type_enc phi)
17.161 + | metis_literal_from_atp type_enc phi =
17.162 + (true, metis_atom_from_atp type_enc phi)
17.163 +fun metis_literals_from_atp type_enc (AConn (AOr, phis)) =
17.164 + maps (metis_literals_from_atp type_enc) phis
17.165 + | metis_literals_from_atp type_enc phi = [metis_literal_from_atp type_enc phi]
17.166 +fun metis_axiom_from_atp type_enc clauses (Formula (ident, _, phi, _, _)) =
17.167 + let
17.168 + fun some isa =
17.169 + SOME (phi |> metis_literals_from_atp type_enc
17.170 + |> Metis_LiteralSet.fromList
17.171 + |> Metis_Thm.axiom, isa)
17.172 + in
17.173 + if ident = type_tag_idempotence_helper_name orelse
17.174 + String.isPrefix tags_sym_formula_prefix ident then
17.175 + Isa_Reflexive_or_Trivial |> some
17.176 + else if String.isPrefix conjecture_prefix ident then
17.177 + NONE
17.178 + else if String.isPrefix helper_prefix ident then
17.179 + case (String.isSuffix typed_helper_suffix ident,
17.180 + space_explode "_" ident) of
17.181 + (needs_fairly_sound, _ :: const :: j :: _) =>
17.182 + nth ((const, needs_fairly_sound)
17.183 + |> AList.lookup (op =) helper_table |> the)
17.184 + (the (Int.fromString j) - 1)
17.185 + |> prepare_helper
17.186 + |> Isa_Raw |> some
17.187 + | _ => raise Fail ("malformed helper identifier " ^ quote ident)
17.188 + else case try (unprefix fact_prefix) ident of
17.189 + SOME s =>
17.190 + let val s = s |> space_explode "_" |> tl |> space_implode "_"
17.191 + in
17.192 + case Int.fromString s of
17.193 + SOME j =>
17.194 + Meson.make_meta_clause (snd (nth clauses j)) |> Isa_Raw |> some
17.195 + | NONE =>
17.196 + if String.isPrefix lam_fact_prefix (unascii_of s) then
17.197 + Isa_Lambda_Lifted |> some
17.198 + else
17.199 + raise Fail ("malformed fact identifier " ^ quote ident)
17.200 + end
17.201 + | NONE => TrueI |> Isa_Raw |> some
17.202 + end
17.203 + | metis_axiom_from_atp _ _ _ = raise Fail "not CNF -- expected formula"
17.204 +
17.205 +fun eliminate_lam_wrappers (Const (@{const_name Metis.lambda}, _) $ t) =
17.206 + eliminate_lam_wrappers t
17.207 + | eliminate_lam_wrappers (t $ u) =
17.208 + eliminate_lam_wrappers t $ eliminate_lam_wrappers u
17.209 + | eliminate_lam_wrappers (Abs (s, T, t)) =
17.210 + Abs (s, T, eliminate_lam_wrappers t)
17.211 + | eliminate_lam_wrappers t = t
17.212 +
17.213 +(* Function to generate metis clauses, including comb and type clauses *)
17.214 +fun prepare_metis_problem ctxt type_enc lam_trans conj_clauses fact_clauses =
17.215 + let
17.216 + val (conj_clauses, fact_clauses) =
17.217 + if polymorphism_of_type_enc type_enc = Polymorphic then
17.218 + (conj_clauses, fact_clauses)
17.219 + else
17.220 + conj_clauses @ fact_clauses
17.221 + |> map (pair 0)
17.222 + |> rpair (ctxt |> Config.put Monomorph.keep_partial_instances false)
17.223 + |-> Monomorph.monomorph atp_schematic_consts_of
17.224 + |> fst |> chop (length conj_clauses)
17.225 + |> pairself (maps (map (zero_var_indexes o snd)))
17.226 + val num_conjs = length conj_clauses
17.227 + val clauses =
17.228 + map2 (fn j => pair (Int.toString j, Local))
17.229 + (0 upto num_conjs - 1) conj_clauses @
17.230 + (* "General" below isn't quite correct; the fact could be local. *)
17.231 + map2 (fn j => pair (Int.toString (num_conjs + j), General))
17.232 + (0 upto length fact_clauses - 1) fact_clauses
17.233 + val (old_skolems, props) =
17.234 + fold_rev (fn (name, th) => fn (old_skolems, props) =>
17.235 + th |> prop_of |> Logic.strip_imp_concl
17.236 + |> conceal_old_skolem_terms (length clauses) old_skolems
17.237 + ||> lam_trans = lam_liftingN ? eliminate_lam_wrappers
17.238 + ||> (fn prop => (name, prop) :: props))
17.239 + clauses ([], [])
17.240 + (*
17.241 + val _ =
17.242 + tracing ("PROPS:\n" ^
17.243 + cat_lines (map (Syntax.string_of_term ctxt o snd) props))
17.244 + *)
17.245 + val lam_trans = if lam_trans = combinatorsN then no_lamsN else lam_trans
17.246 + val (atp_problem, _, _, lifted, sym_tab) =
17.247 + prepare_atp_problem ctxt CNF Hypothesis Axiom type_enc false lam_trans
17.248 + false false [] @{prop False} props
17.249 + (*
17.250 + val _ = tracing ("ATP PROBLEM: " ^
17.251 + cat_lines (lines_for_atp_problem CNF atp_problem))
17.252 + *)
17.253 + (* "rev" is for compatibility with existing proof scripts. *)
17.254 + val axioms =
17.255 + atp_problem
17.256 + |> maps (map_filter (metis_axiom_from_atp type_enc clauses) o snd) |> rev
17.257 + in (sym_tab, axioms, (lifted, old_skolems)) end
17.258 +
17.259 +end;
18.1 --- a/src/HOL/Tools/Metis/metis_reconstruct.ML Mon Jan 23 17:40:31 2012 +0100
18.2 +++ b/src/HOL/Tools/Metis/metis_reconstruct.ML Mon Jan 23 17:40:32 2012 +0100
18.3 @@ -9,7 +9,7 @@
18.4
18.5 signature METIS_RECONSTRUCT =
18.6 sig
18.7 - type type_enc = ATP_Translate.type_enc
18.8 + type type_enc = ATP_Problem_Generate.type_enc
18.9
18.10 exception METIS of string * string
18.11
18.12 @@ -30,9 +30,9 @@
18.13 struct
18.14
18.15 open ATP_Problem
18.16 -open ATP_Translate
18.17 -open ATP_Reconstruct
18.18 -open Metis_Translate
18.19 +open ATP_Problem_Generate
18.20 +open ATP_Proof_Reconstruct
18.21 +open Metis_Generate
18.22
18.23 exception METIS of string * string
18.24
18.25 @@ -101,7 +101,7 @@
18.26 (* INFERENCE RULE: AXIOM *)
18.27
18.28 (* This causes variables to have an index of 1 by default. See also
18.29 - "term_from_atp" in "ATP_Reconstruct". *)
18.30 + "term_from_atp" in "ATP_Proof_Reconstruct". *)
18.31 val axiom_inference = Thm.incr_indexes 1 oo lookth
18.32
18.33 (* INFERENCE RULE: ASSUME *)
19.1 --- a/src/HOL/Tools/Metis/metis_tactic.ML Mon Jan 23 17:40:31 2012 +0100
19.2 +++ b/src/HOL/Tools/Metis/metis_tactic.ML Mon Jan 23 17:40:32 2012 +0100
19.3 @@ -23,9 +23,9 @@
19.4 structure Metis_Tactic : METIS_TACTIC =
19.5 struct
19.6
19.7 -open ATP_Translate
19.8 -open ATP_Reconstruct
19.9 -open Metis_Translate
19.10 +open ATP_Problem_Generate
19.11 +open ATP_Proof_Reconstruct
19.12 +open Metis_Generate
19.13 open Metis_Reconstruct
19.14
19.15 val new_skolemizer =
20.1 --- a/src/HOL/Tools/Metis/metis_translate.ML Mon Jan 23 17:40:31 2012 +0100
20.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
20.3 @@ -1,256 +0,0 @@
20.4 -(* Title: HOL/Tools/Metis/metis_translate.ML
20.5 - Author: Jia Meng, Cambridge University Computer Laboratory and NICTA
20.6 - Author: Kong W. Susanto, Cambridge University Computer Laboratory
20.7 - Author: Lawrence C. Paulson, Cambridge University Computer Laboratory
20.8 - Author: Jasmin Blanchette, TU Muenchen
20.9 -
20.10 -Translation of HOL to FOL for Metis.
20.11 -*)
20.12 -
20.13 -signature METIS_TRANSLATE =
20.14 -sig
20.15 - type type_enc = ATP_Translate.type_enc
20.16 -
20.17 - datatype isa_thm =
20.18 - Isa_Reflexive_or_Trivial |
20.19 - Isa_Lambda_Lifted |
20.20 - Isa_Raw of thm
20.21 -
20.22 - val metis_equal : string
20.23 - val metis_predicator : string
20.24 - val metis_app_op : string
20.25 - val metis_systematic_type_tag : string
20.26 - val metis_ad_hoc_type_tag : string
20.27 - val metis_generated_var_prefix : string
20.28 - val trace : bool Config.T
20.29 - val verbose : bool Config.T
20.30 - val trace_msg : Proof.context -> (unit -> string) -> unit
20.31 - val verbose_warning : Proof.context -> string -> unit
20.32 - val metis_name_table : ((string * int) * ((type_enc -> string) * bool)) list
20.33 - val reveal_old_skolem_terms : (string * term) list -> term -> term
20.34 - val reveal_lam_lifted : (string * term) list -> term -> term
20.35 - val prepare_metis_problem :
20.36 - Proof.context -> type_enc -> string -> thm list -> thm list
20.37 - -> int Symtab.table * (Metis_Thm.thm * isa_thm) list
20.38 - * ((string * term) list * (string * term) list)
20.39 -end
20.40 -
20.41 -structure Metis_Translate : METIS_TRANSLATE =
20.42 -struct
20.43 -
20.44 -open ATP_Problem
20.45 -open ATP_Translate
20.46 -
20.47 -val metis_equal = "="
20.48 -val metis_predicator = "{}"
20.49 -val metis_app_op = Metis_Name.toString Metis_Term.appName
20.50 -val metis_systematic_type_tag =
20.51 - Metis_Name.toString Metis_Term.hasTypeFunctionName
20.52 -val metis_ad_hoc_type_tag = "**"
20.53 -val metis_generated_var_prefix = "_"
20.54 -
20.55 -val trace = Attrib.setup_config_bool @{binding metis_trace} (K false)
20.56 -val verbose = Attrib.setup_config_bool @{binding metis_verbose} (K true)
20.57 -
20.58 -fun trace_msg ctxt msg = if Config.get ctxt trace then tracing (msg ()) else ()
20.59 -fun verbose_warning ctxt msg =
20.60 - if Config.get ctxt verbose then warning ("Metis: " ^ msg) else ()
20.61 -
20.62 -val metis_name_table =
20.63 - [((tptp_equal, 2), (K metis_equal, false)),
20.64 - ((tptp_old_equal, 2), (K metis_equal, false)),
20.65 - ((prefixed_predicator_name, 1), (K metis_predicator, false)),
20.66 - ((prefixed_app_op_name, 2), (K metis_app_op, false)),
20.67 - ((prefixed_type_tag_name, 2),
20.68 - (fn type_enc =>
20.69 - if level_of_type_enc type_enc = All_Types then metis_systematic_type_tag
20.70 - else metis_ad_hoc_type_tag, true))]
20.71 -
20.72 -fun old_skolem_const_name i j num_T_args =
20.73 - old_skolem_const_prefix ^ Long_Name.separator ^
20.74 - (space_implode Long_Name.separator (map string_of_int [i, j, num_T_args]))
20.75 -
20.76 -fun conceal_old_skolem_terms i old_skolems t =
20.77 - if exists_Const (curry (op =) @{const_name Meson.skolem} o fst) t then
20.78 - let
20.79 - fun aux old_skolems
20.80 - (t as (Const (@{const_name Meson.skolem}, Type (_, [_, T])) $ _)) =
20.81 - let
20.82 - val (old_skolems, s) =
20.83 - if i = ~1 then
20.84 - (old_skolems, @{const_name undefined})
20.85 - else case AList.find (op aconv) old_skolems t of
20.86 - s :: _ => (old_skolems, s)
20.87 - | [] =>
20.88 - let
20.89 - val s = old_skolem_const_name i (length old_skolems)
20.90 - (length (Term.add_tvarsT T []))
20.91 - in ((s, t) :: old_skolems, s) end
20.92 - in (old_skolems, Const (s, T)) end
20.93 - | aux old_skolems (t1 $ t2) =
20.94 - let
20.95 - val (old_skolems, t1) = aux old_skolems t1
20.96 - val (old_skolems, t2) = aux old_skolems t2
20.97 - in (old_skolems, t1 $ t2) end
20.98 - | aux old_skolems (Abs (s, T, t')) =
20.99 - let val (old_skolems, t') = aux old_skolems t' in
20.100 - (old_skolems, Abs (s, T, t'))
20.101 - end
20.102 - | aux old_skolems t = (old_skolems, t)
20.103 - in aux old_skolems t end
20.104 - else
20.105 - (old_skolems, t)
20.106 -
20.107 -fun reveal_old_skolem_terms old_skolems =
20.108 - map_aterms (fn t as Const (s, _) =>
20.109 - if String.isPrefix old_skolem_const_prefix s then
20.110 - AList.lookup (op =) old_skolems s |> the
20.111 - |> map_types (map_type_tvar (K dummyT))
20.112 - else
20.113 - t
20.114 - | t => t)
20.115 -
20.116 -fun reveal_lam_lifted lambdas =
20.117 - map_aterms (fn t as Const (s, _) =>
20.118 - if String.isPrefix lam_lifted_prefix s then
20.119 - case AList.lookup (op =) lambdas s of
20.120 - SOME t =>
20.121 - Const (@{const_name Metis.lambda}, dummyT)
20.122 - $ map_types (map_type_tvar (K dummyT))
20.123 - (reveal_lam_lifted lambdas t)
20.124 - | NONE => t
20.125 - else
20.126 - t
20.127 - | t => t)
20.128 -
20.129 -
20.130 -(* ------------------------------------------------------------------------- *)
20.131 -(* Logic maps manage the interface between HOL and first-order logic. *)
20.132 -(* ------------------------------------------------------------------------- *)
20.133 -
20.134 -datatype isa_thm =
20.135 - Isa_Reflexive_or_Trivial |
20.136 - Isa_Lambda_Lifted |
20.137 - Isa_Raw of thm
20.138 -
20.139 -val proxy_defs = map (fst o snd o snd) proxy_table
20.140 -val prepare_helper =
20.141 - Meson.make_meta_clause #> rewrite_rule (map safe_mk_meta_eq proxy_defs)
20.142 -
20.143 -fun metis_term_from_atp type_enc (ATerm (s, tms)) =
20.144 - if is_tptp_variable s then
20.145 - Metis_Term.Var (Metis_Name.fromString s)
20.146 - else
20.147 - (case AList.lookup (op =) metis_name_table (s, length tms) of
20.148 - SOME (f, swap) => (f type_enc, swap)
20.149 - | NONE => (s, false))
20.150 - |> (fn (s, swap) =>
20.151 - Metis_Term.Fn (Metis_Name.fromString s,
20.152 - tms |> map (metis_term_from_atp type_enc)
20.153 - |> swap ? rev))
20.154 -fun metis_atom_from_atp type_enc (AAtom tm) =
20.155 - (case metis_term_from_atp type_enc tm of
20.156 - Metis_Term.Fn x => x
20.157 - | _ => raise Fail "non CNF -- expected function")
20.158 - | metis_atom_from_atp _ _ = raise Fail "not CNF -- expected atom"
20.159 -fun metis_literal_from_atp type_enc (AConn (ANot, [phi])) =
20.160 - (false, metis_atom_from_atp type_enc phi)
20.161 - | metis_literal_from_atp type_enc phi =
20.162 - (true, metis_atom_from_atp type_enc phi)
20.163 -fun metis_literals_from_atp type_enc (AConn (AOr, phis)) =
20.164 - maps (metis_literals_from_atp type_enc) phis
20.165 - | metis_literals_from_atp type_enc phi = [metis_literal_from_atp type_enc phi]
20.166 -fun metis_axiom_from_atp type_enc clauses (Formula (ident, _, phi, _, _)) =
20.167 - let
20.168 - fun some isa =
20.169 - SOME (phi |> metis_literals_from_atp type_enc
20.170 - |> Metis_LiteralSet.fromList
20.171 - |> Metis_Thm.axiom, isa)
20.172 - in
20.173 - if ident = type_tag_idempotence_helper_name orelse
20.174 - String.isPrefix tags_sym_formula_prefix ident then
20.175 - Isa_Reflexive_or_Trivial |> some
20.176 - else if String.isPrefix conjecture_prefix ident then
20.177 - NONE
20.178 - else if String.isPrefix helper_prefix ident then
20.179 - case (String.isSuffix typed_helper_suffix ident,
20.180 - space_explode "_" ident) of
20.181 - (needs_fairly_sound, _ :: const :: j :: _) =>
20.182 - nth ((const, needs_fairly_sound)
20.183 - |> AList.lookup (op =) helper_table |> the)
20.184 - (the (Int.fromString j) - 1)
20.185 - |> prepare_helper
20.186 - |> Isa_Raw |> some
20.187 - | _ => raise Fail ("malformed helper identifier " ^ quote ident)
20.188 - else case try (unprefix fact_prefix) ident of
20.189 - SOME s =>
20.190 - let val s = s |> space_explode "_" |> tl |> space_implode "_"
20.191 - in
20.192 - case Int.fromString s of
20.193 - SOME j =>
20.194 - Meson.make_meta_clause (snd (nth clauses j)) |> Isa_Raw |> some
20.195 - | NONE =>
20.196 - if String.isPrefix lam_fact_prefix (unascii_of s) then
20.197 - Isa_Lambda_Lifted |> some
20.198 - else
20.199 - raise Fail ("malformed fact identifier " ^ quote ident)
20.200 - end
20.201 - | NONE => TrueI |> Isa_Raw |> some
20.202 - end
20.203 - | metis_axiom_from_atp _ _ _ = raise Fail "not CNF -- expected formula"
20.204 -
20.205 -fun eliminate_lam_wrappers (Const (@{const_name Metis.lambda}, _) $ t) =
20.206 - eliminate_lam_wrappers t
20.207 - | eliminate_lam_wrappers (t $ u) =
20.208 - eliminate_lam_wrappers t $ eliminate_lam_wrappers u
20.209 - | eliminate_lam_wrappers (Abs (s, T, t)) =
20.210 - Abs (s, T, eliminate_lam_wrappers t)
20.211 - | eliminate_lam_wrappers t = t
20.212 -
20.213 -(* Function to generate metis clauses, including comb and type clauses *)
20.214 -fun prepare_metis_problem ctxt type_enc lam_trans conj_clauses fact_clauses =
20.215 - let
20.216 - val (conj_clauses, fact_clauses) =
20.217 - if polymorphism_of_type_enc type_enc = Polymorphic then
20.218 - (conj_clauses, fact_clauses)
20.219 - else
20.220 - conj_clauses @ fact_clauses
20.221 - |> map (pair 0)
20.222 - |> rpair (ctxt |> Config.put Monomorph.keep_partial_instances false)
20.223 - |-> Monomorph.monomorph atp_schematic_consts_of
20.224 - |> fst |> chop (length conj_clauses)
20.225 - |> pairself (maps (map (zero_var_indexes o snd)))
20.226 - val num_conjs = length conj_clauses
20.227 - val clauses =
20.228 - map2 (fn j => pair (Int.toString j, Local))
20.229 - (0 upto num_conjs - 1) conj_clauses @
20.230 - (* "General" below isn't quite correct; the fact could be local. *)
20.231 - map2 (fn j => pair (Int.toString (num_conjs + j), General))
20.232 - (0 upto length fact_clauses - 1) fact_clauses
20.233 - val (old_skolems, props) =
20.234 - fold_rev (fn (name, th) => fn (old_skolems, props) =>
20.235 - th |> prop_of |> Logic.strip_imp_concl
20.236 - |> conceal_old_skolem_terms (length clauses) old_skolems
20.237 - ||> lam_trans = lam_liftingN ? eliminate_lam_wrappers
20.238 - ||> (fn prop => (name, prop) :: props))
20.239 - clauses ([], [])
20.240 - (*
20.241 - val _ =
20.242 - tracing ("PROPS:\n" ^
20.243 - cat_lines (map (Syntax.string_of_term ctxt o snd) props))
20.244 - *)
20.245 - val lam_trans = if lam_trans = combinatorsN then no_lamsN else lam_trans
20.246 - val (atp_problem, _, _, lifted, sym_tab) =
20.247 - prepare_atp_problem ctxt CNF Hypothesis Axiom type_enc false lam_trans
20.248 - false false [] @{prop False} props
20.249 - (*
20.250 - val _ = tracing ("ATP PROBLEM: " ^
20.251 - cat_lines (lines_for_atp_problem CNF atp_problem))
20.252 - *)
20.253 - (* "rev" is for compatibility with existing proof scripts. *)
20.254 - val axioms =
20.255 - atp_problem
20.256 - |> maps (map_filter (metis_axiom_from_atp type_enc clauses) o snd) |> rev
20.257 - in (sym_tab, axioms, (lifted, old_skolems)) end
20.258 -
20.259 -end;
21.1 --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Mon Jan 23 17:40:31 2012 +0100
21.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Mon Jan 23 17:40:32 2012 +0100
21.3 @@ -1012,7 +1012,7 @@
21.4 handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
21.5 default_card)
21.6
21.7 -(* Similar to "ATP_Translate.tiny_card_of_type". *)
21.8 +(* Similar to "ATP_Util.tiny_card_of_type". *)
21.9 fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card
21.10 assigns T =
21.11 let
22.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML Mon Jan 23 17:40:31 2012 +0100
22.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML Mon Jan 23 17:40:32 2012 +0100
22.3 @@ -7,7 +7,7 @@
22.4
22.5 signature SLEDGEHAMMER_FILTER =
22.6 sig
22.7 - type locality = ATP_Translate.locality
22.8 + type locality = ATP_Problem_Generate.locality
22.9
22.10 type relevance_fudge =
22.11 {local_const_multiplier : real,
22.12 @@ -62,7 +62,7 @@
22.13 structure Sledgehammer_Filter : SLEDGEHAMMER_FILTER =
22.14 struct
22.15
22.16 -open ATP_Translate
22.17 +open ATP_Problem_Generate
22.18 open Metis_Tactic
22.19 open Sledgehammer_Util
22.20
23.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Mon Jan 23 17:40:31 2012 +0100
23.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Mon Jan 23 17:40:32 2012 +0100
23.3 @@ -21,8 +21,8 @@
23.4
23.5 open ATP_Util
23.6 open ATP_Systems
23.7 -open ATP_Translate
23.8 -open ATP_Reconstruct
23.9 +open ATP_Problem_Generate
23.10 +open ATP_Proof_Reconstruct
23.11 open Sledgehammer_Util
23.12 open Sledgehammer_Filter
23.13 open Sledgehammer_Provers
24.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML Mon Jan 23 17:40:31 2012 +0100
24.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML Mon Jan 23 17:40:32 2012 +0100
24.3 @@ -7,8 +7,8 @@
24.4
24.5 signature SLEDGEHAMMER_MINIMIZE =
24.6 sig
24.7 - type locality = ATP_Translate.locality
24.8 - type play = ATP_Reconstruct.play
24.9 + type locality = ATP_Problem_Generate.locality
24.10 + type play = ATP_Proof_Reconstruct.play
24.11 type params = Sledgehammer_Provers.params
24.12
24.13 val binary_min_facts : int Config.T
24.14 @@ -26,8 +26,8 @@
24.15
24.16 open ATP_Util
24.17 open ATP_Proof
24.18 -open ATP_Translate
24.19 -open ATP_Reconstruct
24.20 +open ATP_Problem_Generate
24.21 +open ATP_Proof_Reconstruct
24.22 open Sledgehammer_Util
24.23 open Sledgehammer_Filter
24.24 open Sledgehammer_Provers
25.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML Mon Jan 23 17:40:31 2012 +0100
25.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML Mon Jan 23 17:40:32 2012 +0100
25.3 @@ -9,11 +9,11 @@
25.4 signature SLEDGEHAMMER_PROVERS =
25.5 sig
25.6 type failure = ATP_Proof.failure
25.7 - type locality = ATP_Translate.locality
25.8 - type type_enc = ATP_Translate.type_enc
25.9 - type reconstructor = ATP_Reconstruct.reconstructor
25.10 - type play = ATP_Reconstruct.play
25.11 - type minimize_command = ATP_Reconstruct.minimize_command
25.12 + type locality = ATP_Problem_Generate.locality
25.13 + type type_enc = ATP_Problem_Generate.type_enc
25.14 + type reconstructor = ATP_Proof_Reconstruct.reconstructor
25.15 + type play = ATP_Proof_Reconstruct.play
25.16 + type minimize_command = ATP_Proof_Reconstruct.minimize_command
25.17 type relevance_fudge = Sledgehammer_Filter.relevance_fudge
25.18
25.19 datatype mode = Auto_Try | Try | Normal | Auto_Minimize | Minimize
25.20 @@ -119,8 +119,8 @@
25.21 open ATP_Problem
25.22 open ATP_Proof
25.23 open ATP_Systems
25.24 -open ATP_Translate
25.25 -open ATP_Reconstruct
25.26 +open ATP_Problem_Generate
25.27 +open ATP_Proof_Reconstruct
25.28 open Metis_Tactic
25.29 open Sledgehammer_Util
25.30 open Sledgehammer_Filter
26.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_run.ML Mon Jan 23 17:40:31 2012 +0100
26.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_run.ML Mon Jan 23 17:40:32 2012 +0100
26.3 @@ -8,7 +8,7 @@
26.4
26.5 signature SLEDGEHAMMER_RUN =
26.6 sig
26.7 - type minimize_command = ATP_Reconstruct.minimize_command
26.8 + type minimize_command = ATP_Proof_Reconstruct.minimize_command
26.9 type relevance_override = Sledgehammer_Filter.relevance_override
26.10 type mode = Sledgehammer_Provers.mode
26.11 type params = Sledgehammer_Provers.params
26.12 @@ -31,8 +31,8 @@
26.13 struct
26.14
26.15 open ATP_Util
26.16 -open ATP_Translate
26.17 -open ATP_Reconstruct
26.18 +open ATP_Problem_Generate
26.19 +open ATP_Proof_Reconstruct
26.20 open Sledgehammer_Util
26.21 open Sledgehammer_Filter
26.22 open Sledgehammer_Provers
27.1 --- a/src/HOL/ex/sledgehammer_tactics.ML Mon Jan 23 17:40:31 2012 +0100
27.2 +++ b/src/HOL/ex/sledgehammer_tactics.ML Mon Jan 23 17:40:32 2012 +0100
27.3 @@ -71,7 +71,7 @@
27.4 fun sledgehammer_with_metis_tac ctxt override_params relevance_override i th =
27.5 case run_atp override_params relevance_override i i ctxt th of
27.6 SOME facts =>
27.7 - Metis_Tactic.metis_tac [] ATP_Translate.combinatorsN ctxt
27.8 + Metis_Tactic.metis_tac [] ATP_Problem_Generate.combinatorsN ctxt
27.9 (maps (thms_of_name ctxt) facts) i th
27.10 | NONE => Seq.empty
27.11