src/HOL/Tools/ATP/atp_problem_generate.ML
author blanchet
Thu, 10 May 2012 16:56:23 +0200
changeset 47905 9b6afe0eb69c
parent 47810 9579464d00f9
child 47911 2168126446bb
permissions -rw-r--r--
cleaner handling of bi-implication for THF output of first-order type encodings
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
46320
0b8b73b49848 renamed two files to make room for a new file
blanchet
parents: 46301
diff changeset
     1
(*  Title:      HOL/Tools/ATP/atp_problem_generate.ML
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
     2
    Author:     Fabian Immler, TU Muenchen
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
     3
    Author:     Makarius
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
     4
    Author:     Jasmin Blanchette, TU Muenchen
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
     5
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
     6
Translation of HOL to FOL for Metis and Sledgehammer.
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
     7
*)
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
     8
46320
0b8b73b49848 renamed two files to make room for a new file
blanchet
parents: 46301
diff changeset
     9
signature ATP_PROBLEM_GENERATE =
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
    10
sig
43676
3b0b448b4d69 add support for lambdas in TPTP THF generator + killed an unsound type encoding (because the monotonicity calculus assumes first-order)
nik
parents: 43628
diff changeset
    11
  type ('a, 'b) ho_term = ('a, 'b) ATP_Problem.ho_term
43136
cf5cda219058 handle lightweight tags sym theorems gracefully in the presence of TVars with interesting type classes
blanchet
parents: 43130
diff changeset
    12
  type connective = ATP_Problem.connective
cf5cda219058 handle lightweight tags sym theorems gracefully in the presence of TVars with interesting type classes
blanchet
parents: 43130
diff changeset
    13
  type ('a, 'b, 'c) formula = ('a, 'b, 'c) ATP_Problem.formula
45301
866b075aa99b added sorted DFG output for coming version of SPASS
blanchet
parents: 45299
diff changeset
    14
  type atp_format = ATP_Problem.atp_format
42709
e7af132d48fe allow each prover to specify its own formula kind for symbols occurring in the conjecture
blanchet
parents: 42701
diff changeset
    15
  type formula_kind = ATP_Problem.formula_kind
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
    16
  type 'a problem = 'a ATP_Problem.problem
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
    17
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
    18
  datatype scope = Global | Local | Assum | Chained
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
    19
  datatype status =
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
    20
    General | Induction | Intro | Inductive | Elim | Simp | Def
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
    21
  type stature = scope * status
42613
23b13b1bd565 use strings to encode type systems in ATP module, to reduce the amount of out-of-place information and also to make it easier to print the type system used
blanchet
parents: 42612
diff changeset
    22
44494
a77901b3774e rationalized option names -- mono becomes raw_mono and mangled becomes mono
blanchet
parents: 44493
diff changeset
    23
  datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
    24
  datatype strictness = Strict | Non_Strict
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
    25
  datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars
42613
23b13b1bd565 use strings to encode type systems in ATP module, to reduce the amount of out-of-place information and also to make it easier to print the type system used
blanchet
parents: 42612
diff changeset
    26
  datatype type_level =
44397
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
    27
    All_Types |
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
    28
    Noninf_Nonmono_Types of strictness * granularity |
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
    29
    Fin_Nonmono_Types of granularity |
44397
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
    30
    Const_Arg_Types |
43362
8d3a5b7b9a00 name tuning
blanchet
parents: 43361
diff changeset
    31
    No_Types
44782
blanchet
parents: 44774
diff changeset
    32
  type type_enc
42613
23b13b1bd565 use strings to encode type systems in ATP module, to reduce the amount of out-of-place information and also to make it easier to print the type system used
blanchet
parents: 42612
diff changeset
    33
45513
25388cf06437 rename the lambda translation schemes, so that they are understandable out of context
blanchet
parents: 45511
diff changeset
    34
  val no_lamsN : string
25388cf06437 rename the lambda translation schemes, so that they are understandable out of context
blanchet
parents: 45511
diff changeset
    35
  val hide_lamsN : string
46365
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
    36
  val liftingN : string
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
    37
  val combsN : string
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
    38
  val combs_and_liftingN : string
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
    39
  val combs_or_liftingN : string
45513
25388cf06437 rename the lambda translation schemes, so that they are understandable out of context
blanchet
parents: 45511
diff changeset
    40
  val lam_liftingN : string
25388cf06437 rename the lambda translation schemes, so that they are understandable out of context
blanchet
parents: 45511
diff changeset
    41
  val keep_lamsN : string
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    42
  val schematic_var_prefix : string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    43
  val fixed_var_prefix : string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    44
  val tvar_prefix : string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    45
  val tfree_prefix : string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    46
  val const_prefix : string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    47
  val type_const_prefix : string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    48
  val class_prefix : string
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
    49
  val lam_lifted_prefix : string
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
    50
  val lam_lifted_mono_prefix : string
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
    51
  val lam_lifted_poly_prefix : string
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
    52
  val skolem_const_prefix : string
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
    53
  val old_skolem_const_prefix : string
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
    54
  val new_skolem_const_prefix : string
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
    55
  val combinator_prefix : string
43125
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
    56
  val type_decl_prefix : string
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
    57
  val sym_decl_prefix : string
43989
eb763b3ff9ed renamed "preds" encodings to "guards"
blanchet
parents: 43987
diff changeset
    58
  val guards_sym_formula_prefix : string
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
    59
  val tags_sym_formula_prefix : string
40204
da97d75e20e6 standardize on "fact" terminology (vs. "axiom" or "theorem") in Sledgehammer -- but keep "Axiom" in the lower-level "ATP_Problem" module
blanchet
parents: 40145
diff changeset
    60
  val fact_prefix : string
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
    61
  val conjecture_prefix : string
42881
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
    62
  val helper_prefix : string
43125
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
    63
  val class_rel_clause_prefix : string
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
    64
  val arity_clause_prefix : string
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
    65
  val tfree_clause_prefix : string
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
    66
  val lam_fact_prefix : string
42881
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
    67
  val typed_helper_suffix : string
43125
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
    68
  val untyped_helper_suffix : string
42966
4e2d6c1e5392 more work on parsing LEO-II proofs without lambdas
blanchet
parents: 42963
diff changeset
    69
  val predicator_name : string
4e2d6c1e5392 more work on parsing LEO-II proofs without lambdas
blanchet
parents: 42963
diff changeset
    70
  val app_op_name : string
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
    71
  val type_guard_name : string
43104
81d1b15aa0ae use ":" for type information (looks good in Metis's output) and handle it in new path finder
blanchet
parents: 43102
diff changeset
    72
  val type_tag_name : string
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
    73
  val native_type_prefix : string
43174
f497a1e97d37 skip "hBOOL" in new Metis path finder
blanchet
parents: 43167
diff changeset
    74
  val prefixed_predicator_name : string
43130
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
    75
  val prefixed_app_op_name : string
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
    76
  val prefixed_type_tag_name : string
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    77
  val ascii_of : string -> string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    78
  val unascii_of : string -> string
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
    79
  val unprefix_and_unascii : string -> string -> string option
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
    80
  val proxy_table : (string * (string * (thm * (string * string)))) list
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
    81
  val proxify_const : string -> (string * string) option
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    82
  val invert_const : string -> string
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
    83
  val unproxify_const : string -> string
43093
blanchet
parents: 43092
diff changeset
    84
  val new_skolem_var_name_from_const : string -> string
43248
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
    85
  val atp_irrelevant_consts : string list
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
    86
  val atp_schematic_consts_of : term -> typ list Symtab.table
43828
e07a2c4cbad8 move lambda translation option from ATP to Sledgehammer, to avoid accidentally breaking Metis (its reconstruction code can only deal with combinators)
blanchet
parents: 43827
diff changeset
    87
  val is_type_enc_higher_order : type_enc -> bool
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
    88
  val polymorphism_of_type_enc : type_enc -> polymorphism
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
    89
  val level_of_type_enc : type_enc -> type_level
44397
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
    90
  val is_type_enc_quasi_sound : type_enc -> bool
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
    91
  val is_type_enc_fairly_sound : type_enc -> bool
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
    92
  val type_enc_from_string : strictness -> string -> type_enc
45301
866b075aa99b added sorted DFG output for coming version of SPASS
blanchet
parents: 45299
diff changeset
    93
  val adjust_type_enc : atp_format -> type_enc -> type_enc
43136
cf5cda219058 handle lightweight tags sym theorems gracefully in the presence of TVars with interesting type classes
blanchet
parents: 43130
diff changeset
    94
  val mk_aconns :
cf5cda219058 handle lightweight tags sym theorems gracefully in the presence of TVars with interesting type classes
blanchet
parents: 43130
diff changeset
    95
    connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula
43676
3b0b448b4d69 add support for lambdas in TPTP THF generator + killed an unsound type encoding (because the monotonicity calculus assumes first-order)
nik
parents: 43628
diff changeset
    96
  val unmangled_const : string -> string * (string, 'b) ho_term list
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
    97
  val unmangled_const_name : string -> string list
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
    98
  val helper_table : ((string * bool) * thm list) list
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
    99
  val trans_lams_from_string :
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
   100
    Proof.context -> type_enc -> string -> term list -> term list * term list
43501
0e422a84d0b2 don't change the way helpers are generated for the exporter's sake
blanchet
parents: 43496
diff changeset
   101
  val factsN : string
40059
6ad9081665db use consistent terminology in Sledgehammer: "prover = ATP or SMT solver or ..."
blanchet
parents: 39975
diff changeset
   102
  val prepare_atp_problem :
45301
866b075aa99b added sorted DFG output for coming version of SPASS
blanchet
parents: 45299
diff changeset
   103
    Proof.context -> atp_format -> formula_kind -> formula_kind -> type_enc
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
   104
    -> bool -> string -> bool -> bool -> bool -> term list -> term
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
   105
    -> ((string * stature) * term) list
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
   106
    -> string problem * string Symtab.table * (string * stature) list vector
45551
a62c7a21f4ab removed needless baggage
blanchet
parents: 45520
diff changeset
   107
       * (string * term) list * int Symtab.table
47030
7e80e14247fc internal renamings
blanchet
parents: 46818
diff changeset
   108
  val atp_problem_selection_weights : string problem -> (string * real) list
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
   109
  val atp_problem_term_order_info : string problem -> (string * int) list
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   110
end;
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   111
46320
0b8b73b49848 renamed two files to make room for a new file
blanchet
parents: 46301
diff changeset
   112
structure ATP_Problem_Generate : ATP_PROBLEM_GENERATE =
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   113
struct
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   114
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   115
open ATP_Util
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   116
open ATP_Problem
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   117
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   118
type name = string * string
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   119
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   120
datatype scope = Global | Local | Assum | Chained
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   121
datatype status = General | Induction | Intro | Inductive | Elim | Simp | Def
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   122
type stature = scope * status
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   123
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   124
datatype order =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   125
  First_Order |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   126
  Higher_Order of thf_flavor
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   127
datatype polymorphism = Polymorphic | Raw_Monomorphic | Mangled_Monomorphic
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   128
datatype strictness = Strict | Non_Strict
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   129
datatype granularity = All_Vars | Positively_Naked_Vars | Ghost_Type_Arg_Vars
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   130
datatype type_level =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   131
  All_Types |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   132
  Noninf_Nonmono_Types of strictness * granularity |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   133
  Fin_Nonmono_Types of granularity |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   134
  Const_Arg_Types |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   135
  No_Types
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   136
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   137
datatype type_enc =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   138
  Native of order * polymorphism * type_level |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   139
  Guards of polymorphism * type_level |
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   140
  Tags of polymorphism * type_level
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   141
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   142
fun is_type_enc_native (Native _) = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   143
  | is_type_enc_native _ = false
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   144
fun is_type_enc_higher_order (Native (Higher_Order _, _, _)) = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   145
  | is_type_enc_higher_order _ = false
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   146
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   147
fun polymorphism_of_type_enc (Native (_, poly, _)) = poly
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   148
  | polymorphism_of_type_enc (Guards (poly, _)) = poly
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   149
  | polymorphism_of_type_enc (Tags (poly, _)) = poly
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   150
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   151
fun level_of_type_enc (Native (_, _, level)) = level
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   152
  | level_of_type_enc (Guards (_, level)) = level
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   153
  | level_of_type_enc (Tags (_, level)) = level
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   154
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   155
fun granularity_of_type_level (Noninf_Nonmono_Types (_, grain)) = grain
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   156
  | granularity_of_type_level (Fin_Nonmono_Types grain) = grain
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   157
  | granularity_of_type_level _ = All_Vars
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   158
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   159
fun is_type_level_quasi_sound All_Types = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   160
  | is_type_level_quasi_sound (Noninf_Nonmono_Types _) = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   161
  | is_type_level_quasi_sound _ = false
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   162
val is_type_enc_quasi_sound = is_type_level_quasi_sound o level_of_type_enc
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   163
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   164
fun is_type_level_fairly_sound (Fin_Nonmono_Types _) = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   165
  | is_type_level_fairly_sound level = is_type_level_quasi_sound level
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   166
val is_type_enc_fairly_sound = is_type_level_fairly_sound o level_of_type_enc
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   167
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   168
fun is_type_level_monotonicity_based (Noninf_Nonmono_Types _) = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   169
  | is_type_level_monotonicity_based (Fin_Nonmono_Types _) = true
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   170
  | is_type_level_monotonicity_based _ = false
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   171
45516
b2c8422833da document "lam_trans" option
blanchet
parents: 45514
diff changeset
   172
val no_lamsN = "no_lams" (* used internally; undocumented *)
45513
25388cf06437 rename the lambda translation schemes, so that they are understandable out of context
blanchet
parents: 45511
diff changeset
   173
val hide_lamsN = "hide_lams"
46365
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
   174
val liftingN = "lifting"
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
   175
val combsN = "combs"
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
   176
val combs_and_liftingN = "combs_and_lifting"
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
   177
val combs_or_liftingN = "combs_or_lifting"
45513
25388cf06437 rename the lambda translation schemes, so that they are understandable out of context
blanchet
parents: 45511
diff changeset
   178
val keep_lamsN = "keep_lams"
46365
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
   179
val lam_liftingN = "lam_lifting" (* legacy *)
44088
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   180
45779
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
   181
(* It's still unclear whether all TFF1 implementations will support type
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
   182
   signatures such as "!>[A : $tType] : $o", with ghost type variables. *)
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
   183
val avoid_first_order_ghost_type_vars = false
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
   184
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   185
val bound_var_prefix = "B_"
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
   186
val all_bound_var_prefix = "A_"
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
   187
val exist_bound_var_prefix = "E_"
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   188
val schematic_var_prefix = "V_"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   189
val fixed_var_prefix = "v_"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   190
val tvar_prefix = "T_"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   191
val tfree_prefix = "t_"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   192
val const_prefix = "c_"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   193
val type_const_prefix = "tc_"
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
   194
val native_type_prefix = "n_"
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   195
val class_prefix = "cl_"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   196
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   197
(* Freshness almost guaranteed! *)
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
   198
val atp_prefix = "ATP" ^ Long_Name.separator
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   199
val atp_weak_prefix = "ATP:"
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   200
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   201
val lam_lifted_prefix = atp_weak_prefix ^ "Lam"
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   202
val lam_lifted_mono_prefix = lam_lifted_prefix ^ "m"
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   203
val lam_lifted_poly_prefix = lam_lifted_prefix ^ "p"
43907
073ab5379842 pass type arguments to lambda-lifted Frees, to account for polymorphism
blanchet
parents: 43906
diff changeset
   204
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
   205
val skolem_const_prefix = atp_prefix ^ "Sko"
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   206
val old_skolem_const_prefix = skolem_const_prefix ^ "o"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   207
val new_skolem_const_prefix = skolem_const_prefix ^ "n"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   208
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   209
val combinator_prefix = "COMB"
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   210
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
   211
val type_decl_prefix = "ty_"
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
   212
val sym_decl_prefix = "sy_"
43989
eb763b3ff9ed renamed "preds" encodings to "guards"
blanchet
parents: 43987
diff changeset
   213
val guards_sym_formula_prefix = "gsy_"
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
   214
val tags_sym_formula_prefix = "tsy_"
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
   215
val uncurried_alias_eq_prefix = "unc_"
40204
da97d75e20e6 standardize on "fact" terminology (vs. "axiom" or "theorem") in Sledgehammer -- but keep "Axiom" in the lower-level "ATP_Problem" module
blanchet
parents: 40145
diff changeset
   216
val fact_prefix = "fact_"
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   217
val conjecture_prefix = "conj_"
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   218
val helper_prefix = "help_"
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   219
val class_rel_clause_prefix = "clar_"
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   220
val arity_clause_prefix = "arity_"
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   221
val tfree_clause_prefix = "tfree_"
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   222
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   223
val lam_fact_prefix = "ATP.lambda_"
42881
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
   224
val typed_helper_suffix = "_T"
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
   225
val untyped_helper_suffix = "_U"
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
   226
44491
ba22ed224b20 fixed bang encoding detection of which types to encode
blanchet
parents: 44463
diff changeset
   227
val predicator_name = "pp"
ba22ed224b20 fixed bang encoding detection of which types to encode
blanchet
parents: 44463
diff changeset
   228
val app_op_name = "aa"
ba22ed224b20 fixed bang encoding detection of which types to encode
blanchet
parents: 44463
diff changeset
   229
val type_guard_name = "gg"
ba22ed224b20 fixed bang encoding detection of which types to encode
blanchet
parents: 44463
diff changeset
   230
val type_tag_name = "tt"
42531
a462dbaa584f added more rudimentary type support to Sledgehammer's ATP encoding
blanchet
parents: 42530
diff changeset
   231
43174
f497a1e97d37 skip "hBOOL" in new Metis path finder
blanchet
parents: 43167
diff changeset
   232
val prefixed_predicator_name = const_prefix ^ predicator_name
43130
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
   233
val prefixed_app_op_name = const_prefix ^ app_op_name
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
   234
val prefixed_type_tag_name = const_prefix ^ type_tag_name
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
   235
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   236
(*Escaping of special characters.
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   237
  Alphanumeric characters are left unchanged.
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   238
  The character _ goes to __
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   239
  Characters in the range ASCII space to / go to _A to _P, respectively.
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   240
  Other characters go to _nnn where nnn is the decimal ASCII code.*)
43093
blanchet
parents: 43092
diff changeset
   241
val upper_a_minus_space = Char.ord #"A" - Char.ord #" "
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   242
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   243
fun stringN_of_int 0 _ = ""
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   244
  | stringN_of_int k n =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   245
    stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   246
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   247
fun ascii_of_char c =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   248
  if Char.isAlphaNum c then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   249
    String.str c
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   250
  else if c = #"_" then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   251
    "__"
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   252
  else if #" " <= c andalso c <= #"/" then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   253
    "_" ^ String.str (Char.chr (Char.ord c + upper_a_minus_space))
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   254
  else
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   255
    (* fixed width, in case more digits follow *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   256
    "_" ^ stringN_of_int 3 (Char.ord c)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   257
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   258
val ascii_of = String.translate ascii_of_char
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   259
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   260
(** Remove ASCII armoring from names in proof files **)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   261
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   262
(* We don't raise error exceptions because this code can run inside a worker
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   263
   thread. Also, the errors are impossible. *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   264
val unascii_of =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   265
  let
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   266
    fun un rcs [] = String.implode(rev rcs)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   267
      | un rcs [#"_"] = un (#"_" :: rcs) [] (* ERROR *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   268
        (* Three types of _ escapes: __, _A to _P, _nnn *)
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   269
      | un rcs (#"_" :: #"_" :: cs) = un (#"_" :: rcs) cs
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   270
      | un rcs (#"_" :: c :: cs) =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   271
        if #"A" <= c andalso c<= #"P" then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   272
          (* translation of #" " to #"/" *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   273
          un (Char.chr (Char.ord c - upper_a_minus_space) :: rcs) cs
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   274
        else
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   275
          let val digits = List.take (c :: cs, 3) handle General.Subscript => [] in
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   276
            case Int.fromString (String.implode digits) of
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   277
              SOME n => un (Char.chr n :: rcs) (List.drop (cs, 2))
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   278
            | NONE => un (c :: #"_" :: rcs) cs (* ERROR *)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   279
          end
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   280
      | un rcs (c :: cs) = un (c :: rcs) cs
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   281
  in un [] o String.explode end
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   282
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   283
(* If string s has the prefix s1, return the result of deleting it,
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   284
   un-ASCII'd. *)
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
   285
fun unprefix_and_unascii s1 s =
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   286
  if String.isPrefix s1 s then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   287
    SOME (unascii_of (String.extract (s, size s1, NONE)))
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   288
  else
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   289
    NONE
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   290
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   291
val proxy_table =
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   292
  [("c_False", (@{const_name False}, (@{thm fFalse_def},
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   293
       ("fFalse", @{const_name ATP.fFalse})))),
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   294
   ("c_True", (@{const_name True}, (@{thm fTrue_def},
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   295
       ("fTrue", @{const_name ATP.fTrue})))),
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   296
   ("c_Not", (@{const_name Not}, (@{thm fNot_def},
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   297
       ("fNot", @{const_name ATP.fNot})))),
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   298
   ("c_conj", (@{const_name conj}, (@{thm fconj_def},
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   299
       ("fconj", @{const_name ATP.fconj})))),
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   300
   ("c_disj", (@{const_name disj}, (@{thm fdisj_def},
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   301
       ("fdisj", @{const_name ATP.fdisj})))),
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   302
   ("c_implies", (@{const_name implies}, (@{thm fimplies_def},
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   303
       ("fimplies", @{const_name ATP.fimplies})))),
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   304
   ("equal", (@{const_name HOL.eq}, (@{thm fequal_def},
43678
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   305
       ("fequal", @{const_name ATP.fequal})))),
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   306
   ("c_All", (@{const_name All}, (@{thm fAll_def},
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   307
       ("fAll", @{const_name ATP.fAll})))),
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   308
   ("c_Ex", (@{const_name Ex}, (@{thm fEx_def},
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   309
       ("fEx", @{const_name ATP.fEx}))))]
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   310
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   311
val proxify_const = AList.lookup (op =) proxy_table #> Option.map (snd o snd)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   312
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   313
(* Readable names for the more common symbolic functions. Do not mess with the
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   314
   table unless you know what you are doing. *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   315
val const_trans_table =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   316
  [(@{type_name Product_Type.prod}, "prod"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   317
   (@{type_name Sum_Type.sum}, "sum"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   318
   (@{const_name False}, "False"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   319
   (@{const_name True}, "True"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   320
   (@{const_name Not}, "Not"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   321
   (@{const_name conj}, "conj"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   322
   (@{const_name disj}, "disj"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   323
   (@{const_name implies}, "implies"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   324
   (@{const_name HOL.eq}, "equal"),
43678
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   325
   (@{const_name All}, "All"),
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   326
   (@{const_name Ex}, "Ex"),
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   327
   (@{const_name If}, "If"),
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   328
   (@{const_name Set.member}, "member"),
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   329
   (@{const_name Meson.COMBI}, combinator_prefix ^ "I"),
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   330
   (@{const_name Meson.COMBK}, combinator_prefix ^ "K"),
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   331
   (@{const_name Meson.COMBB}, combinator_prefix ^ "B"),
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   332
   (@{const_name Meson.COMBC}, combinator_prefix ^ "C"),
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   333
   (@{const_name Meson.COMBS}, combinator_prefix ^ "S")]
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   334
  |> Symtab.make
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   335
  |> fold (Symtab.update o swap o snd o snd o snd) proxy_table
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   336
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   337
(* Invert the table of translations between Isabelle and ATPs. *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   338
val const_trans_table_inv =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   339
  const_trans_table |> Symtab.dest |> map swap |> Symtab.make
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   340
val const_trans_table_unprox =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   341
  Symtab.empty
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
   342
  |> fold (fn (_, (isa, (_, (_, atp)))) => Symtab.update (atp, isa)) proxy_table
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   343
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   344
val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   345
val unproxify_const = perhaps (Symtab.lookup const_trans_table_unprox)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   346
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   347
fun lookup_const c =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   348
  case Symtab.lookup const_trans_table c of
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   349
    SOME c' => c'
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   350
  | NONE => ascii_of c
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   351
43622
blanchet
parents: 43572
diff changeset
   352
fun ascii_of_indexname (v, 0) = ascii_of v
blanchet
parents: 43572
diff changeset
   353
  | ascii_of_indexname (v, i) = ascii_of v ^ "_" ^ string_of_int i
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   354
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   355
fun make_bound_var x = bound_var_prefix ^ ascii_of x
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
   356
fun make_all_bound_var x = all_bound_var_prefix ^ ascii_of x
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
   357
fun make_exist_bound_var x = exist_bound_var_prefix ^ ascii_of x
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   358
fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   359
fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   360
43622
blanchet
parents: 43572
diff changeset
   361
fun make_schematic_type_var (x, i) =
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
   362
  tvar_prefix ^ (ascii_of_indexname (unprefix "'" x, i))
43622
blanchet
parents: 43572
diff changeset
   363
fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (unprefix "'" x))
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   364
45301
866b075aa99b added sorted DFG output for coming version of SPASS
blanchet
parents: 45299
diff changeset
   365
(* "HOL.eq" and choice are mapped to the ATP's equivalents *)
44587
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   366
local
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   367
  val choice_const = (fst o dest_Const o HOLogic.choice_const) Term.dummyT
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   368
  fun default c = const_prefix ^ lookup_const c
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   369
in
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   370
  fun make_fixed_const _ @{const_name HOL.eq} = tptp_old_equal
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   371
    | make_fixed_const (SOME (Native (Higher_Order THF_With_Choice, _, _))) c =
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
   372
      if c = choice_const then tptp_choice else default c
44587
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   373
    | make_fixed_const _ c = default c
0f50f158eb57 removed explicit reliance on Hilbert_Choice.Eps
nik
parents: 44586
diff changeset
   374
end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   375
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   376
fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   377
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   378
fun make_type_class clas = class_prefix ^ ascii_of clas
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   379
43093
blanchet
parents: 43092
diff changeset
   380
fun new_skolem_var_name_from_const s =
blanchet
parents: 43092
diff changeset
   381
  let val ss = s |> space_explode Long_Name.separator in
blanchet
parents: 43092
diff changeset
   382
    nth ss (length ss - 2)
blanchet
parents: 43092
diff changeset
   383
  end
blanchet
parents: 43092
diff changeset
   384
43248
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   385
(* These are either simplified away by "Meson.presimplify" (most of the time) or
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   386
   handled specially via "fFalse", "fTrue", ..., "fequal". *)
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   387
val atp_irrelevant_consts =
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   388
  [@{const_name False}, @{const_name True}, @{const_name Not},
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   389
   @{const_name conj}, @{const_name disj}, @{const_name implies},
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   390
   @{const_name HOL.eq}, @{const_name If}, @{const_name Let}]
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   391
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   392
val atp_monomorph_bad_consts =
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   393
  atp_irrelevant_consts @
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   394
  (* These are ignored anyway by the relevance filter (unless they appear in
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   395
     higher-order places) but not by the monomorphizer. *)
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   396
  [@{const_name all}, @{const_name "==>"}, @{const_name "=="},
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   397
   @{const_name Trueprop}, @{const_name All}, @{const_name Ex},
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   398
   @{const_name Ex1}, @{const_name Ball}, @{const_name Bex}]
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   399
43258
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   400
fun add_schematic_const (x as (_, T)) =
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   401
  Monomorph.typ_has_tvars T ? Symtab.insert_list (op =) x
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   402
val add_schematic_consts_of =
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   403
  Term.fold_aterms (fn Const (x as (s, _)) =>
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   404
                       not (member (op =) atp_monomorph_bad_consts s)
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   405
                       ? add_schematic_const x
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   406
                      | _ => I)
956895f99904 slightly faster/cleaner accumulation of polymorphic consts
blanchet
parents: 43248
diff changeset
   407
fun atp_schematic_consts_of t = add_schematic_consts_of t Symtab.empty
43248
69375eaa9016 more suitable implementation of "schematic_consts_of" for monomorphizer, for ATPs
blanchet
parents: 43222
diff changeset
   408
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   409
(** Definitions and functions for FOL clauses and formulas for TPTP **)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   410
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   411
(** Isabelle arities **)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   412
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   413
type arity_atom = name * name * name list
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   414
43263
blanchet
parents: 43259
diff changeset
   415
val type_class = the_single @{sort type}
blanchet
parents: 43259
diff changeset
   416
43086
blanchet
parents: 43085
diff changeset
   417
type arity_clause =
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   418
  {name : string,
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   419
   prem_atoms : arity_atom list,
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   420
   concl_atom : arity_atom}
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   421
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   422
fun add_prem_atom tvar =
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   423
  fold (fn s => s <> type_class ? cons (`make_type_class s, `I tvar, []))
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   424
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   425
(* Arity of type constructor "tcon :: (arg1, ..., argN) res" *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   426
fun make_axiom_arity_clause (tcons, name, (cls, args)) =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   427
  let
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
   428
    val tvars = map (prefix tvar_prefix o string_of_int) (1 upto length args)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   429
    val tvars_srts = ListPair.zip (tvars, args)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   430
  in
43086
blanchet
parents: 43085
diff changeset
   431
    {name = name,
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   432
     prem_atoms = [] |> fold (uncurry add_prem_atom) tvars_srts,
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   433
     concl_atom = (`make_type_class cls, `make_fixed_type_const tcons,
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   434
                   tvars ~~ tvars)}
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   435
  end
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   436
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   437
fun arity_clause _ _ (_, []) = []
43495
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   438
  | arity_clause seen n (tcons, ("HOL.type", _) :: ars) =  (* ignore *)
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   439
    arity_clause seen n (tcons, ars)
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   440
  | arity_clause seen n (tcons, (ar as (class, _)) :: ars) =
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   441
    if member (op =) seen class then
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   442
      (* multiple arities for the same (tycon, class) pair *)
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   443
      make_axiom_arity_clause (tcons,
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   444
          lookup_const tcons ^ "___" ^ ascii_of class ^ "_" ^ string_of_int n,
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   445
          ar) ::
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   446
      arity_clause seen (n + 1) (tcons, ars)
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   447
    else
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   448
      make_axiom_arity_clause (tcons, lookup_const tcons ^ "___" ^
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   449
                               ascii_of class, ar) ::
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
   450
      arity_clause (class :: seen) n (tcons, ars)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   451
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   452
fun multi_arity_clause [] = []
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   453
  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
44772
blanchet
parents: 44771
diff changeset
   454
    arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   455
43622
blanchet
parents: 43572
diff changeset
   456
(* Generate all pairs (tycon, class, sorts) such that tycon belongs to class in
blanchet
parents: 43572
diff changeset
   457
   theory thy provided its arguments have the corresponding sorts. *)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   458
fun type_class_pairs thy tycons classes =
43093
blanchet
parents: 43092
diff changeset
   459
  let
blanchet
parents: 43092
diff changeset
   460
    val alg = Sign.classes_of thy
blanchet
parents: 43092
diff changeset
   461
    fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
blanchet
parents: 43092
diff changeset
   462
    fun add_class tycon class =
blanchet
parents: 43092
diff changeset
   463
      cons (class, domain_sorts tycon class)
blanchet
parents: 43092
diff changeset
   464
      handle Sorts.CLASS_ERROR _ => I
blanchet
parents: 43092
diff changeset
   465
    fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
blanchet
parents: 43092
diff changeset
   466
  in map try_classes tycons end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   467
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   468
(*Proving one (tycon, class) membership may require proving others, so iterate.*)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   469
fun iter_type_class_pairs _ _ [] = ([], [])
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   470
  | iter_type_class_pairs thy tycons classes =
43263
blanchet
parents: 43259
diff changeset
   471
      let
blanchet
parents: 43259
diff changeset
   472
        fun maybe_insert_class s =
blanchet
parents: 43259
diff changeset
   473
          (s <> type_class andalso not (member (op =) classes s))
blanchet
parents: 43259
diff changeset
   474
          ? insert (op =) s
blanchet
parents: 43259
diff changeset
   475
        val cpairs = type_class_pairs thy tycons classes
blanchet
parents: 43259
diff changeset
   476
        val newclasses =
blanchet
parents: 43259
diff changeset
   477
          [] |> fold (fold (fold (fold maybe_insert_class) o snd) o snd) cpairs
blanchet
parents: 43259
diff changeset
   478
        val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
43266
3baf384e2b99 minor optimization
blanchet
parents: 43265
diff changeset
   479
      in (classes' @ classes, union (op =) cpairs' cpairs) end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   480
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   481
fun make_arity_clauses thy tycons =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   482
  iter_type_class_pairs thy tycons ##> multi_arity_clause
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   483
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   484
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   485
(** Isabelle class relations **)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   486
43086
blanchet
parents: 43085
diff changeset
   487
type class_rel_clause =
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   488
  {name : string,
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   489
   subclass : name,
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   490
   superclass : name}
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   491
43622
blanchet
parents: 43572
diff changeset
   492
(* Generate all pairs (sub, super) such that sub is a proper subclass of super
blanchet
parents: 43572
diff changeset
   493
   in theory "thy". *)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   494
fun class_pairs _ [] _ = []
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   495
  | class_pairs thy subs supers =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   496
      let
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   497
        val class_less = Sorts.class_less (Sign.classes_of thy)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   498
        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   499
        fun add_supers sub = fold (add_super sub) supers
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   500
      in fold add_supers subs [] end
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   501
43622
blanchet
parents: 43572
diff changeset
   502
fun make_class_rel_clause (sub, super) =
blanchet
parents: 43572
diff changeset
   503
  {name = sub ^ "_" ^ super, subclass = `make_type_class sub,
43086
blanchet
parents: 43085
diff changeset
   504
   superclass = `make_type_class super}
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   505
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   506
fun make_class_rel_clauses thy subs supers =
43093
blanchet
parents: 43092
diff changeset
   507
  map make_class_rel_clause (class_pairs thy subs supers)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   508
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   509
(* intermediate terms *)
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   510
datatype iterm =
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   511
  IConst of name * typ * typ list |
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   512
  IVar of name * typ |
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   513
  IApp of iterm * iterm |
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   514
  IAbs of (name * typ) * iterm
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   515
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   516
fun ityp_of (IConst (_, T, _)) = T
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   517
  | ityp_of (IVar (_, T)) = T
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   518
  | ityp_of (IApp (t1, _)) = snd (dest_funT (ityp_of t1))
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   519
  | ityp_of (IAbs ((_, T), tm)) = T --> ityp_of tm
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   520
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   521
(*gets the head of a combinator application, along with the list of arguments*)
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   522
fun strip_iterm_comb u =
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   523
  let
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   524
    fun stripc (IApp (t, u), ts) = stripc (t, u :: ts)
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   525
      | stripc x = x
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   526
  in stripc (u, []) end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   527
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
   528
fun atomic_types_of T = fold_atyps (insert (op =)) T []
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   529
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   530
val tvar_a_str = "'a"
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   531
val tvar_a = TVar ((tvar_a_str, 0), HOLogic.typeS)
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   532
val tvar_a_name = (make_schematic_type_var (tvar_a_str, 0), tvar_a_str)
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   533
val itself_name = `make_fixed_type_const @{type_name itself}
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   534
val TYPE_name = `(make_fixed_const NONE) @{const_name TYPE}
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   535
val tvar_a_atype = AType (tvar_a_name, [])
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   536
val a_itself_atype = AType (itself_name, [tvar_a_atype])
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   537
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   538
fun new_skolem_const_name s num_T_args =
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   539
  [new_skolem_const_prefix, s, string_of_int num_T_args]
46711
f745bcc4a1e5 more explicit Long_Name operations (NB: analyzing qualifiers is inherently fragile);
wenzelm
parents: 46643
diff changeset
   540
  |> Long_Name.implode
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   541
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   542
fun robust_const_type thy s =
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   543
  if s = app_op_name then
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   544
    Logic.varifyT_global @{typ "('a => 'b) => 'a => 'b"}
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   545
  else if String.isPrefix lam_lifted_prefix s then
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   546
    Logic.varifyT_global @{typ "'a => 'b"}
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   547
  else
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   548
    (* Old Skolems throw a "TYPE" exception here, which will be caught. *)
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   549
    s |> Sign.the_const_type thy
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   550
46642
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
   551
val robust_const_ary =
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
   552
  let
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
   553
    fun ary (Type (@{type_name fun}, [_, T])) = 1 + ary T
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
   554
      | ary _ = 0
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
   555
  in ary oo robust_const_type end
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
   556
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   557
(* This function only makes sense if "T" is as general as possible. *)
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   558
fun robust_const_typargs thy (s, T) =
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   559
  if s = app_op_name then
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   560
    let val (T1, T2) = T |> domain_type |> dest_funT in [T1, T2] end
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   561
  else if String.isPrefix old_skolem_const_prefix s then
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   562
    [] |> Term.add_tvarsT T |> rev |> map TVar
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   563
  else if String.isPrefix lam_lifted_prefix s then
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   564
    if String.isPrefix lam_lifted_poly_prefix s then
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
   565
      let val (T1, T2) = T |> dest_funT in [T1, T2] end
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
   566
    else
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
   567
      []
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   568
  else
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   569
    (s, T) |> Sign.const_typargs thy
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   570
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   571
(* Converts an Isabelle/HOL term (with combinators) into an intermediate term.
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   572
   Also accumulates sort infomation. *)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   573
fun iterm_from_term thy type_enc bs (P $ Q) =
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   574
    let
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   575
      val (P', P_atomics_Ts) = iterm_from_term thy type_enc bs P
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   576
      val (Q', Q_atomics_Ts) = iterm_from_term thy type_enc bs Q
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   577
    in (IApp (P', Q'), union (op =) P_atomics_Ts Q_atomics_Ts) end
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   578
  | iterm_from_term thy type_enc _ (Const (c, T)) =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   579
    (IConst (`(make_fixed_const (SOME type_enc)) c, T,
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   580
             robust_const_typargs thy (c, T)),
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
   581
     atomic_types_of T)
44495
4c2242c8a96c added choice operator output for
nik
parents: 44494
diff changeset
   582
  | iterm_from_term _ _ _ (Free (s, T)) =
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   583
    (IConst (`make_fixed_var s, T, []), atomic_types_of T)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   584
  | iterm_from_term _ type_enc _ (Var (v as (s, _), T)) =
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   585
    (if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   586
       let
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   587
         val Ts = T |> strip_type |> swap |> op ::
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   588
         val s' = new_skolem_const_name s (length Ts)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   589
       in IConst (`(make_fixed_const (SOME type_enc)) s', T, Ts) end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   590
     else
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
   591
       IVar ((make_schematic_var v, s), T), atomic_types_of T)
44495
4c2242c8a96c added choice operator output for
nik
parents: 44494
diff changeset
   592
  | iterm_from_term _ _ bs (Bound j) =
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
   593
    nth bs j |> (fn (_, (name, T)) => (IConst (name, T, []), atomic_types_of T))
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   594
  | iterm_from_term thy type_enc bs (Abs (s, T, t)) =
43678
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   595
    let
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   596
      fun vary s = s |> AList.defined (op =) bs s ? vary o Symbol.bump_string
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
   597
      val s = vary s
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
   598
      val name = `make_bound_var s
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   599
      val (tm, atomic_Ts) =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   600
        iterm_from_term thy type_enc ((s, (name, T)) :: bs) t
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
   601
    in (IAbs ((name, T), tm), union (op =) atomic_Ts (atomic_types_of T)) end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   602
44785
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   603
(* "_query", "_bang", and "_at" are for the ASCII-challenged Metis and
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   604
   Mirabelle. *)
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   605
val queries = ["?", "_query"]
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   606
val bangs = ["!", "_bang"]
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   607
val ats = ["@", "_at"]
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   608
42689
e38590764c34 versions of ! and ? for the ASCII-challenged Mirabelle
blanchet
parents: 42688
diff changeset
   609
fun try_unsuffixes ss s =
e38590764c34 versions of ! and ? for the ASCII-challenged Mirabelle
blanchet
parents: 42688
diff changeset
   610
  fold (fn s' => fn NONE => try (unsuffix s') s | some => some) ss NONE
e38590764c34 versions of ! and ? for the ASCII-challenged Mirabelle
blanchet
parents: 42688
diff changeset
   611
44785
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   612
fun try_nonmono constr suffixes fallback s =
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   613
  case try_unsuffixes suffixes s of
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   614
    SOME s =>
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   615
    (case try_unsuffixes suffixes s of
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   616
       SOME s => (constr Positively_Naked_Vars, s)
44785
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   617
     | NONE =>
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   618
       case try_unsuffixes ats s of
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   619
         SOME s => (constr Ghost_Type_Arg_Vars, s)
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   620
       | NONE => (constr All_Vars, s))
44785
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   621
  | NONE => fallback s
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   622
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
   623
fun type_enc_from_string strictness s =
42722
626e292d22a7 renamed type systems for more consistency
blanchet
parents: 42709
diff changeset
   624
  (case try (unprefix "poly_") s of
626e292d22a7 renamed type systems for more consistency
blanchet
parents: 42709
diff changeset
   625
     SOME s => (SOME Polymorphic, s)
42613
23b13b1bd565 use strings to encode type systems in ATP module, to reduce the amount of out-of-place information and also to make it easier to print the type system used
blanchet
parents: 42612
diff changeset
   626
   | NONE =>
44494
a77901b3774e rationalized option names -- mono becomes raw_mono and mangled becomes mono
blanchet
parents: 44493
diff changeset
   627
     case try (unprefix "raw_mono_") s of
a77901b3774e rationalized option names -- mono becomes raw_mono and mangled becomes mono
blanchet
parents: 44493
diff changeset
   628
       SOME s => (SOME Raw_Monomorphic, s)
42722
626e292d22a7 renamed type systems for more consistency
blanchet
parents: 42709
diff changeset
   629
     | NONE =>
44494
a77901b3774e rationalized option names -- mono becomes raw_mono and mangled becomes mono
blanchet
parents: 44493
diff changeset
   630
       case try (unprefix "mono_") s of
42722
626e292d22a7 renamed type systems for more consistency
blanchet
parents: 42709
diff changeset
   631
         SOME s => (SOME Mangled_Monomorphic, s)
626e292d22a7 renamed type systems for more consistency
blanchet
parents: 42709
diff changeset
   632
       | NONE => (NONE, s))
44785
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   633
  ||> (pair All_Types
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   634
       |> try_nonmono Fin_Nonmono_Types bangs
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
   635
       |> try_nonmono (curry Noninf_Nonmono_Types strictness) queries)
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   636
  |> (fn (poly, (level, core)) =>
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   637
         case (core, (poly, level)) of
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
   638
           ("native", (SOME poly, _)) =>
44742
68e34e7f01ab cleanup "simple" type encodings
blanchet
parents: 44738
diff changeset
   639
           (case (poly, level) of
68e34e7f01ab cleanup "simple" type encodings
blanchet
parents: 44738
diff changeset
   640
              (Polymorphic, All_Types) =>
47767
blanchet
parents: 47718
diff changeset
   641
              Native (First_Order, Polymorphic, All_Types)
44742
68e34e7f01ab cleanup "simple" type encodings
blanchet
parents: 44738
diff changeset
   642
            | (Mangled_Monomorphic, _) =>
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   643
              if granularity_of_type_level level = All_Vars then
47767
blanchet
parents: 47718
diff changeset
   644
                Native (First_Order, Mangled_Monomorphic, level)
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   645
              else
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   646
                raise Same.SAME
44742
68e34e7f01ab cleanup "simple" type encodings
blanchet
parents: 44738
diff changeset
   647
            | _ => raise Same.SAME)
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
   648
         | ("native_higher", (SOME poly, _)) =>
44591
0b107d11f634 extended simple types with polymorphism -- the implementation still needs some work though
blanchet
parents: 44589
diff changeset
   649
           (case (poly, level) of
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
   650
              (Polymorphic, All_Types) =>
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   651
              Native (Higher_Order THF_With_Choice, Polymorphic, All_Types)
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
   652
            | (_, Noninf_Nonmono_Types _) => raise Same.SAME
44742
68e34e7f01ab cleanup "simple" type encodings
blanchet
parents: 44738
diff changeset
   653
            | (Mangled_Monomorphic, _) =>
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   654
              if granularity_of_type_level level = All_Vars then
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   655
                Native (Higher_Order THF_With_Choice, Mangled_Monomorphic,
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   656
                        level)
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   657
              else
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   658
                raise Same.SAME
44742
68e34e7f01ab cleanup "simple" type encodings
blanchet
parents: 44738
diff changeset
   659
            | _ => raise Same.SAME)
44810
c1c05a578c1a stricted type encoding parsing
blanchet
parents: 44786
diff changeset
   660
         | ("guards", (SOME poly, _)) =>
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   661
           if poly = Mangled_Monomorphic andalso
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   662
              granularity_of_type_level level = Ghost_Type_Arg_Vars then
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   663
             raise Same.SAME
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   664
           else
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   665
             Guards (poly, level)
44810
c1c05a578c1a stricted type encoding parsing
blanchet
parents: 44786
diff changeset
   666
         | ("tags", (SOME poly, _)) =>
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   667
           if granularity_of_type_level level = Ghost_Type_Arg_Vars then
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   668
             raise Same.SAME
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   669
           else
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
   670
             Tags (poly, level)
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   671
         | ("args", (SOME poly, All_Types (* naja *))) =>
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   672
           Guards (poly, Const_Arg_Types)
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   673
         | ("erased", (NONE, All_Types (* naja *))) =>
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   674
           Guards (Polymorphic, No_Types)
42753
c9552e617acc drop some type arguments to constants in unsound type systems + remove a few type systems that make no sense from the circulation
blanchet
parents: 42750
diff changeset
   675
         | _ => raise Same.SAME)
44785
f4975fa4a2f8 parse new experimental '@' encodings
blanchet
parents: 44783
diff changeset
   676
  handle Same.SAME => error ("Unknown type encoding: " ^ quote s ^ ".")
42613
23b13b1bd565 use strings to encode type systems in ATP module, to reduce the amount of out-of-place information and also to make it easier to print the type system used
blanchet
parents: 42612
diff changeset
   677
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   678
fun adjust_order THF_Without_Choice (Higher_Order _) =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   679
    Higher_Order THF_Without_Choice
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   680
  | adjust_order _ type_enc = type_enc
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   681
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   682
fun adjust_type_enc (THF (TPTP_Polymorphic, _, flavor))
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   683
                    (Native (order, poly, level)) =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   684
    Native (adjust_order flavor order, poly, level)
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   685
  | adjust_type_enc (THF (TPTP_Monomorphic, _, flavor))
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   686
                         (Native (order, _, level)) =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   687
    Native (adjust_order flavor order, Mangled_Monomorphic, level)
47767
blanchet
parents: 47718
diff changeset
   688
  | adjust_type_enc (TFF (TPTP_Monomorphic, _)) (Native (_, _, level)) =
blanchet
parents: 47718
diff changeset
   689
    Native (First_Order, Mangled_Monomorphic, level)
blanchet
parents: 47718
diff changeset
   690
  | adjust_type_enc (DFG DFG_Sorted) (Native (_, _, level)) =
blanchet
parents: 47718
diff changeset
   691
    Native (First_Order, Mangled_Monomorphic, level)
blanchet
parents: 47718
diff changeset
   692
  | adjust_type_enc (TFF _) (Native (_, poly, level)) =
blanchet
parents: 47718
diff changeset
   693
    Native (First_Order, poly, level)
blanchet
parents: 47718
diff changeset
   694
  | adjust_type_enc format (Native (_, poly, level)) =
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
   695
    adjust_type_enc format (Guards (poly, level))
44416
cabd06b69c18 added formats to the slice and use TFF for remote Vampire
blanchet
parents: 44410
diff changeset
   696
  | adjust_type_enc CNF_UEQ (type_enc as Guards stuff) =
cabd06b69c18 added formats to the slice and use TFF for remote Vampire
blanchet
parents: 44410
diff changeset
   697
    (if is_type_enc_fairly_sound type_enc then Tags else Guards) stuff
cabd06b69c18 added formats to the slice and use TFF for remote Vampire
blanchet
parents: 44410
diff changeset
   698
  | adjust_type_enc _ type_enc = type_enc
43101
1d46d85cd78b make "prepare_atp_problem" more robust w.r.t. choice of type system
blanchet
parents: 43098
diff changeset
   699
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   700
fun is_fol_term t =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   701
  case t of
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   702
    @{const Not} $ t1 => is_fol_term t1
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   703
  | Const (@{const_name All}, _) $ Abs (_, _, t') => is_fol_term t'
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   704
  | Const (@{const_name All}, _) $ t1 => is_fol_term t1
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   705
  | Const (@{const_name Ex}, _) $ Abs (_, _, t') => is_fol_term t'
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   706
  | Const (@{const_name Ex}, _) $ t1 => is_fol_term t1
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   707
  | @{const HOL.conj} $ t1 $ t2 => is_fol_term t1 andalso is_fol_term t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   708
  | @{const HOL.disj} $ t1 $ t2 => is_fol_term t1 andalso is_fol_term t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   709
  | @{const HOL.implies} $ t1 $ t2 => is_fol_term t1 andalso is_fol_term t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   710
  | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   711
    is_fol_term t1 andalso is_fol_term t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   712
  | _ => not (exists_subterm (fn Abs _ => true | _ => false) t)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   713
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   714
fun simple_translate_lambdas do_lambdas ctxt t =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   715
  if is_fol_term t then
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   716
    t
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   717
  else
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   718
    let
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   719
      fun trans Ts t =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   720
        case t of
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   721
          @{const Not} $ t1 => @{const Not} $ trans Ts t1
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   722
        | (t0 as Const (@{const_name All}, _)) $ Abs (s, T, t') =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   723
          t0 $ Abs (s, T, trans (T :: Ts) t')
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   724
        | (t0 as Const (@{const_name All}, _)) $ t1 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   725
          trans Ts (t0 $ eta_expand Ts t1 1)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   726
        | (t0 as Const (@{const_name Ex}, _)) $ Abs (s, T, t') =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   727
          t0 $ Abs (s, T, trans (T :: Ts) t')
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   728
        | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   729
          trans Ts (t0 $ eta_expand Ts t1 1)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   730
        | (t0 as @{const HOL.conj}) $ t1 $ t2 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   731
          t0 $ trans Ts t1 $ trans Ts t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   732
        | (t0 as @{const HOL.disj}) $ t1 $ t2 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   733
          t0 $ trans Ts t1 $ trans Ts t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   734
        | (t0 as @{const HOL.implies}) $ t1 $ t2 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   735
          t0 $ trans Ts t1 $ trans Ts t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   736
        | (t0 as Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])))
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   737
            $ t1 $ t2 =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   738
          t0 $ trans Ts t1 $ trans Ts t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   739
        | _ =>
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   740
          if not (exists_subterm (fn Abs _ => true | _ => false) t) then t
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   741
          else t |> Envir.eta_contract |> do_lambdas ctxt Ts
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   742
      val (t, ctxt') = Variable.import_terms true [t] ctxt |>> the_single
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   743
    in t |> trans [] |> singleton (Variable.export_terms ctxt' ctxt) end
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   744
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   745
fun do_cheaply_conceal_lambdas Ts (t1 $ t2) =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   746
    do_cheaply_conceal_lambdas Ts t1
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   747
    $ do_cheaply_conceal_lambdas Ts t2
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   748
  | do_cheaply_conceal_lambdas Ts (Abs (_, T, t)) =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   749
    Const (lam_lifted_poly_prefix ^ serial_string (),
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   750
           T --> fastype_of1 (T :: Ts, t))
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   751
  | do_cheaply_conceal_lambdas _ t = t
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   752
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   753
fun concealed_bound_name j = atp_weak_prefix ^ string_of_int j
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   754
fun conceal_bounds Ts t =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   755
  subst_bounds (map (Free o apfst concealed_bound_name)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   756
                    (0 upto length Ts - 1 ~~ Ts), t)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   757
fun reveal_bounds Ts =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   758
  subst_atomic (map (fn (j, T) => (Free (concealed_bound_name j, T), Bound j))
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   759
                    (0 upto length Ts - 1 ~~ Ts))
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   760
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   761
fun do_introduce_combinators ctxt Ts t =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   762
  let val thy = Proof_Context.theory_of ctxt in
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   763
    t |> conceal_bounds Ts
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   764
      |> cterm_of thy
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   765
      |> Meson_Clausify.introduce_combinators_in_cterm
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   766
      |> prop_of |> Logic.dest_equals |> snd
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   767
      |> reveal_bounds Ts
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   768
  end
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   769
  (* A type variable of sort "{}" will make abstraction fail. *)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   770
  handle THM _ => t |> do_cheaply_conceal_lambdas Ts
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   771
val introduce_combinators = simple_translate_lambdas do_introduce_combinators
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   772
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   773
fun constify_lifted (t $ u) = constify_lifted t $ constify_lifted u
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   774
  | constify_lifted (Abs (s, T, t)) = Abs (s, T, constify_lifted t)
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   775
  | constify_lifted (Free (x as (s, _))) =
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   776
    (if String.isPrefix lam_lifted_prefix s then Const else Free) x
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   777
  | constify_lifted t = t
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
   778
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   779
fun lift_lams_part_1 ctxt type_enc =
45568
211a6e6cbc04 move eta-contraction to before translation to Metis, to ensure everything stays in sync
blanchet
parents: 45565
diff changeset
   780
  map close_form #> rpair ctxt
44088
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   781
  #-> Lambda_Lifting.lift_lambdas
45564
2231a151db59 protect prefix against variant mutations
blanchet
parents: 45554
diff changeset
   782
          (SOME ((if polymorphism_of_type_enc type_enc = Polymorphic then
2231a151db59 protect prefix against variant mutations
blanchet
parents: 45554
diff changeset
   783
                    lam_lifted_poly_prefix
2231a151db59 protect prefix against variant mutations
blanchet
parents: 45554
diff changeset
   784
                  else
2231a151db59 protect prefix against variant mutations
blanchet
parents: 45554
diff changeset
   785
                    lam_lifted_mono_prefix) ^ "_a"))
44088
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   786
          Lambda_Lifting.is_quantifier
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
   787
  #> fst
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   788
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   789
fun lift_lams_part_2 ctxt (facts, lifted) =
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   790
  (facts, lifted)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   791
  (* Lambda-lifting sometimes leaves some lambdas around; we need some way to get rid
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   792
     of them *)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   793
  |> pairself (map (introduce_combinators ctxt))
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   794
  |> pairself (map constify_lifted)
47718
39229c760636 smoother handling of conjecture, so that its Skolem constants get displayed in countermodels
blanchet
parents: 47715
diff changeset
   795
  (* Requires bound variables not to clash with any schematic variables (as
39229c760636 smoother handling of conjecture, so that its Skolem constants get displayed in countermodels
blanchet
parents: 47715
diff changeset
   796
     should be the case right after lambda-lifting). *)
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   797
  |>> map (open_form (unprefix close_form_prefix))
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   798
  ||> map (open_form I)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   799
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
   800
fun lift_lams ctxt = lift_lams_part_2 ctxt oo lift_lams_part_1 ctxt
44088
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   801
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   802
fun intentionalize_def (Const (@{const_name All}, _) $ Abs (_, _, t)) =
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   803
    intentionalize_def t
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   804
  | intentionalize_def (Const (@{const_name HOL.eq}, _) $ t $ u) =
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   805
    let
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   806
      fun lam T t = Abs (Name.uu, T, t)
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   807
      val (head, args) = strip_comb t ||> rev
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   808
      val head_T = fastype_of head
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   809
      val n = length args
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   810
      val arg_Ts = head_T |> binder_types |> take n |> rev
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   811
      val u = u |> subst_atomic (args ~~ map Bound (0 upto n - 1))
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   812
    in HOLogic.eq_const head_T $ head $ fold lam arg_Ts u end
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   813
  | intentionalize_def t = t
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
   814
40114
blanchet
parents: 40069
diff changeset
   815
type translated_formula =
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   816
  {name : string,
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
   817
   stature : stature,
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   818
   kind : formula_kind,
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   819
   iformula : (name, typ, iterm) formula,
43496
92f5a4c78b37 remove historical bloat -- another benefit of merging Metis's and Sledgehammer's translations
blanchet
parents: 43495
diff changeset
   820
   atomic_types : typ list}
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   821
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
   822
fun update_iformula f ({name, stature, kind, iformula, atomic_types}
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   823
                       : translated_formula) =
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
   824
  {name = name, stature = stature, kind = kind, iformula = f iformula,
42562
f1d903f789b1 killed needless datatype "combtyp" in Metis
blanchet
parents: 42561
diff changeset
   825
   atomic_types = atomic_types} : translated_formula
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
   826
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
   827
fun fact_lift f ({iformula, ...} : translated_formula) = f iformula
42558
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
   828
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
   829
fun insert_type thy get_T x xs =
43064
b6e61d22fa61 made "explicit_apply" smarter -- no need to force explicit applications in minimizer on all constants, better do it more fine granularly
blanchet
parents: 43039
diff changeset
   830
  let val T = get_T x in
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
   831
    if exists (type_instance thy T o get_T) xs then xs
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
   832
    else x :: filter_out (type_generalization thy T o get_T) xs
43064
b6e61d22fa61 made "explicit_apply" smarter -- no need to force explicit applications in minimizer on all constants, better do it more fine granularly
blanchet
parents: 43039
diff changeset
   833
  end
42677
25496cd3c199 monotonic type inference in ATP Sledgehammer problems -- based on Claessen & al.'s CADE 2011 paper, Sect. 2.3.
blanchet
parents: 42675
diff changeset
   834
42753
c9552e617acc drop some type arguments to constants in unsound type systems + remove a few type systems that make no sense from the circulation
blanchet
parents: 42750
diff changeset
   835
(* The Booleans indicate whether all type arguments should be kept. *)
c9552e617acc drop some type arguments to constants in unsound type systems + remove a few type systems that make no sense from the circulation
blanchet
parents: 42750
diff changeset
   836
datatype type_arg_policy =
45937
blanchet
parents: 45920
diff changeset
   837
  Explicit_Type_Args of bool (* infer_from_term_args *) |
44771
0e5d4388bbac make mangling sound w.r.t. type arguments
blanchet
parents: 44770
diff changeset
   838
  Mangled_Type_Args |
42753
c9552e617acc drop some type arguments to constants in unsound type systems + remove a few type systems that make no sense from the circulation
blanchet
parents: 42750
diff changeset
   839
  No_Type_Args
41136
30bedf58b177 implemented new type system encoding "overload_args", which is more lightweight than "const_args" (the unsound default) and hopefully almost as sound
blanchet
parents: 41134
diff changeset
   840
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
   841
fun type_arg_policy monom_constrs type_enc s =
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   842
  let val poly = polymorphism_of_type_enc type_enc in
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   843
    if s = type_tag_name then
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   844
      if poly = Mangled_Monomorphic then Mangled_Type_Args
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   845
      else Explicit_Type_Args false
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   846
    else case type_enc of
47767
blanchet
parents: 47718
diff changeset
   847
      Native (_, Polymorphic, _) => Explicit_Type_Args false
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   848
    | Tags (_, All_Types) => No_Type_Args
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   849
    | _ =>
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   850
      let val level = level_of_type_enc type_enc in
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   851
        if level = No_Types orelse s = @{const_name HOL.eq} orelse
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   852
           (s = app_op_name andalso level = Const_Arg_Types) then
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   853
          No_Type_Args
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   854
        else if poly = Mangled_Monomorphic then
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   855
          Mangled_Type_Args
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
   856
        else if member (op =) monom_constrs s andalso
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
   857
                granularity_of_type_level level = Positively_Naked_Vars then
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
   858
          No_Type_Args
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   859
        else
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   860
          Explicit_Type_Args
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   861
              (level = All_Types orelse
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
   862
               granularity_of_type_level level = Ghost_Type_Arg_Vars)
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   863
      end
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
   864
  end
42227
662b50b7126f if "monomorphize" is enabled, mangle the type information in the names by default
blanchet
parents: 42180
diff changeset
   865
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   866
(* Make atoms for sorted type variables. *)
43263
blanchet
parents: 43259
diff changeset
   867
fun generic_add_sorts_on_type (_, []) = I
blanchet
parents: 43259
diff changeset
   868
  | generic_add_sorts_on_type ((x, i), s :: ss) =
blanchet
parents: 43259
diff changeset
   869
    generic_add_sorts_on_type ((x, i), ss)
blanchet
parents: 43259
diff changeset
   870
    #> (if s = the_single @{sort HOL.type} then
43093
blanchet
parents: 43092
diff changeset
   871
          I
blanchet
parents: 43092
diff changeset
   872
        else if i = ~1 then
44623
blanchet
parents: 44622
diff changeset
   873
          insert (op =) (`make_type_class s, `make_fixed_type_var x)
43093
blanchet
parents: 43092
diff changeset
   874
        else
44623
blanchet
parents: 44622
diff changeset
   875
          insert (op =) (`make_type_class s,
blanchet
parents: 44622
diff changeset
   876
                         (make_schematic_type_var (x, i), x)))
43263
blanchet
parents: 43259
diff changeset
   877
fun add_sorts_on_tfree (TFree (s, S)) = generic_add_sorts_on_type ((s, ~1), S)
blanchet
parents: 43259
diff changeset
   878
  | add_sorts_on_tfree _ = I
blanchet
parents: 43259
diff changeset
   879
fun add_sorts_on_tvar (TVar z) = generic_add_sorts_on_type z
blanchet
parents: 43259
diff changeset
   880
  | add_sorts_on_tvar _ = I
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   881
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   882
fun type_class_formula type_enc class arg =
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   883
  AAtom (ATerm (class, arg ::
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   884
      (case type_enc of
47767
blanchet
parents: 47718
diff changeset
   885
         Native (First_Order, Polymorphic, _) =>
45301
866b075aa99b added sorted DFG output for coming version of SPASS
blanchet
parents: 45299
diff changeset
   886
         if avoid_first_order_ghost_type_vars then [ATerm (TYPE_name, [arg])]
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
   887
         else []
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   888
       | _ => [])))
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   889
fun formulas_for_types type_enc add_sorts_on_typ Ts =
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
   890
  [] |> level_of_type_enc type_enc <> No_Types ? fold add_sorts_on_typ Ts
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   891
     |> map (fn (class, name) =>
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
   892
                type_class_formula type_enc class (ATerm (name, [])))
41137
8b634031b2a5 implemented "no_types" encoding, which is too unsound to be useful but can come in handy for evaluations
blanchet
parents: 41136
diff changeset
   893
42534
46e690db16b8 fake type declarations for full-type args and mangled type encodings, so that type assumptions can be discharged
blanchet
parents: 42533
diff changeset
   894
fun mk_aconns c phis =
46e690db16b8 fake type declarations for full-type args and mangled type encodings, so that type assumptions can be discharged
blanchet
parents: 42533
diff changeset
   895
  let val (phis', phi') = split_last phis in
46e690db16b8 fake type declarations for full-type args and mangled type encodings, so that type assumptions can be discharged
blanchet
parents: 42533
diff changeset
   896
    fold_rev (mk_aconn c) phis' phi'
46e690db16b8 fake type declarations for full-type args and mangled type encodings, so that type assumptions can be discharged
blanchet
parents: 42533
diff changeset
   897
  end
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   898
fun mk_ahorn [] phi = phi
42534
46e690db16b8 fake type declarations for full-type args and mangled type encodings, so that type assumptions can be discharged
blanchet
parents: 42533
diff changeset
   899
  | mk_ahorn phis psi = AConn (AImplies, [mk_aconns AAnd phis, psi])
42522
413b56894f82 close ATP formulas universally earlier, so that we can add type predicates
blanchet
parents: 42521
diff changeset
   900
fun mk_aquant _ [] phi = phi
413b56894f82 close ATP formulas universally earlier, so that we can add type predicates
blanchet
parents: 42521
diff changeset
   901
  | mk_aquant q xs (phi as AQuant (q', xs', phi')) =
413b56894f82 close ATP formulas universally earlier, so that we can add type predicates
blanchet
parents: 42521
diff changeset
   902
    if q = q' then AQuant (q, xs @ xs', phi') else AQuant (q, xs, phi)
413b56894f82 close ATP formulas universally earlier, so that we can add type predicates
blanchet
parents: 42521
diff changeset
   903
  | mk_aquant q xs phi = AQuant (q, xs, phi)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
   904
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   905
fun close_universally add_term_vars phi =
41145
a5ee3b8e5a90 improve partially tagged encoding by adding a helper fact that coalesces consecutive "ti" tags
blanchet
parents: 41140
diff changeset
   906
  let
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   907
    fun add_formula_vars bounds (AQuant (_, xs, phi)) =
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   908
        add_formula_vars (map fst xs @ bounds) phi
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   909
      | add_formula_vars bounds (AConn (_, phis)) =
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   910
        fold (add_formula_vars bounds) phis
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   911
      | add_formula_vars bounds (AAtom tm) = add_term_vars bounds tm
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   912
  in mk_aquant AForall (add_formula_vars [] phi []) phi end
42522
413b56894f82 close ATP formulas universally earlier, so that we can add type predicates
blanchet
parents: 42521
diff changeset
   913
45377
blanchet
parents: 45364
diff changeset
   914
fun add_term_vars bounds (ATerm (name as (s, _), tms)) =
blanchet
parents: 45364
diff changeset
   915
    (if is_tptp_variable s andalso
blanchet
parents: 45364
diff changeset
   916
        not (String.isPrefix tvar_prefix s) andalso
blanchet
parents: 45364
diff changeset
   917
        not (member (op =) bounds name) then
blanchet
parents: 45364
diff changeset
   918
       insert (op =) (name, NONE)
blanchet
parents: 45364
diff changeset
   919
     else
blanchet
parents: 45364
diff changeset
   920
       I)
blanchet
parents: 45364
diff changeset
   921
    #> fold (add_term_vars bounds) tms
blanchet
parents: 45364
diff changeset
   922
  | add_term_vars bounds (AAbs ((name, _), tm)) =
blanchet
parents: 45364
diff changeset
   923
    add_term_vars (name :: bounds) tm
45401
36478a5f6104 made SML/NJ happy
blanchet
parents: 45377
diff changeset
   924
fun close_formula_universally phi = close_universally add_term_vars phi
45315
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   925
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   926
fun add_iterm_vars bounds (IApp (tm1, tm2)) =
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   927
    fold (add_iterm_vars bounds) [tm1, tm2]
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   928
  | add_iterm_vars _ (IConst _) = I
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   929
  | add_iterm_vars bounds (IVar (name, T)) =
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   930
    not (member (op =) bounds name) ? insert (op =) (name, SOME T)
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   931
  | add_iterm_vars bounds (IAbs (_, tm)) = add_iterm_vars bounds tm
dfbbc5ac7194 improved TFF1 output
blanchet
parents: 45304
diff changeset
   932
fun close_iformula_universally phi = close_universally add_iterm_vars phi
41145
a5ee3b8e5a90 improve partially tagged encoding by adding a helper fact that coalesces consecutive "ti" tags
blanchet
parents: 41140
diff changeset
   933
46338
b02ff6b17599 better handling of individual type for DFG format (SPASS)
blanchet
parents: 46320
diff changeset
   934
val fused_infinite_type_name = "ATP.fused_inf" (* shouldn't clash *)
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   935
val fused_infinite_type = Type (fused_infinite_type_name, [])
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   936
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   937
fun tvar_name (x as (s, _)) = (make_schematic_type_var x, s)
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   938
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   939
fun ho_term_from_typ type_enc =
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   940
  let
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   941
    fun term (Type (s, Ts)) =
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
   942
      ATerm (case (is_type_enc_higher_order type_enc, s) of
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   943
               (true, @{type_name bool}) => `I tptp_bool_type
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   944
             | (true, @{type_name fun}) => `I tptp_fun_type
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   945
             | _ => if s = fused_infinite_type_name andalso
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   946
                       is_type_enc_native type_enc then
43178
b5862142d378 use "" type only in THF and TFF -- might cause strange failures if used in FOF or CNF, depending on how liberal the prover is
blanchet
parents: 43175
diff changeset
   947
                      `I tptp_individual_type
b5862142d378 use "" type only in THF and TFF -- might cause strange failures if used in FOF or CNF, depending on how liberal the prover is
blanchet
parents: 43175
diff changeset
   948
                    else
b5862142d378 use "" type only in THF and TFF -- might cause strange failures if used in FOF or CNF, depending on how liberal the prover is
blanchet
parents: 43175
diff changeset
   949
                      `make_fixed_type_const s,
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   950
             map term Ts)
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   951
    | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, [])
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
   952
    | term (TVar (x, _)) = ATerm (tvar_name x, [])
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   953
  in term end
42562
f1d903f789b1 killed needless datatype "combtyp" in Metis
blanchet
parents: 42561
diff changeset
   954
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   955
fun ho_term_for_type_arg type_enc T =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   956
  if T = dummyT then NONE else SOME (ho_term_from_typ type_enc T)
43401
e93dfcb53535 fixed soundness bug made more visible by previous change
blanchet
parents: 43399
diff changeset
   957
42562
f1d903f789b1 killed needless datatype "combtyp" in Metis
blanchet
parents: 42561
diff changeset
   958
(* This shouldn't clash with anything else. *)
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
   959
val uncurried_alias_sep = "\000"
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
   960
val mangled_type_sep = "\001"
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
   961
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
   962
val ascii_of_uncurried_alias_sep = ascii_of uncurried_alias_sep
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
   963
42562
f1d903f789b1 killed needless datatype "combtyp" in Metis
blanchet
parents: 42561
diff changeset
   964
fun generic_mangled_type_name f (ATerm (name, [])) = f name
f1d903f789b1 killed needless datatype "combtyp" in Metis
blanchet
parents: 42561
diff changeset
   965
  | generic_mangled_type_name f (ATerm (name, tys)) =
42761
8ea9c6fa8b53 fixed several bugs in Isar proof reconstruction, in particular w.r.t. mangled types and hAPP
blanchet
parents: 42755
diff changeset
   966
    f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys)
8ea9c6fa8b53 fixed several bugs in Isar proof reconstruction, in particular w.r.t. mangled types and hAPP
blanchet
parents: 42755
diff changeset
   967
    ^ ")"
43692
264881a20f50 make SML/NJ happy + tuning
blanchet
parents: 43678
diff changeset
   968
  | generic_mangled_type_name _ _ = raise Fail "unexpected type abstraction"
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
   969
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   970
fun mangled_type type_enc =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   971
  generic_mangled_type_name fst o ho_term_from_typ type_enc
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
   972
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
   973
fun make_native_type s =
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   974
  if s = tptp_bool_type orelse s = tptp_fun_type orelse
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   975
     s = tptp_individual_type then
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   976
    s
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   977
  else
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
   978
    native_type_prefix ^ ascii_of s
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
   979
43676
3b0b448b4d69 add support for lambdas in TPTP THF generator + killed an unsound type encoding (because the monotonicity calculus assumes first-order)
nik
parents: 43628
diff changeset
   980
fun ho_type_from_ho_term type_enc pred_sym ary =
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
   981
  let
44593
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   982
    fun to_mangled_atype ty =
46435
e9c90516bc0d renamed type encoding
blanchet
parents: 46422
diff changeset
   983
      AType ((make_native_type (generic_mangled_type_name fst ty),
44593
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   984
              generic_mangled_type_name snd ty), [])
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   985
    fun to_poly_atype (ATerm (name, tys)) = AType (name, map to_poly_atype tys)
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   986
      | to_poly_atype _ = raise Fail "unexpected type abstraction"
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   987
    val to_atype =
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   988
      if polymorphism_of_type_enc type_enc = Polymorphic then to_poly_atype
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
   989
      else to_mangled_atype
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
   990
    fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1))
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
   991
    fun to_fo 0 ty = if pred_sym then bool_atype else to_atype ty
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   992
      | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys
43692
264881a20f50 make SML/NJ happy + tuning
blanchet
parents: 43678
diff changeset
   993
      | to_fo _ _ = raise Fail "unexpected type abstraction"
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
   994
    fun to_ho (ty as ATerm ((s, _), tys)) =
43676
3b0b448b4d69 add support for lambdas in TPTP THF generator + killed an unsound type encoding (because the monotonicity calculus assumes first-order)
nik
parents: 43628
diff changeset
   995
        if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty
3b0b448b4d69 add support for lambdas in TPTP THF generator + killed an unsound type encoding (because the monotonicity calculus assumes first-order)
nik
parents: 43628
diff changeset
   996
      | to_ho _ = raise Fail "unexpected type abstraction"
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
   997
  in if is_type_enc_higher_order type_enc then to_ho else to_fo ary end
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
   998
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
   999
fun ho_type_from_typ type_enc pred_sym ary =
43676
3b0b448b4d69 add support for lambdas in TPTP THF generator + killed an unsound type encoding (because the monotonicity calculus assumes first-order)
nik
parents: 43628
diff changeset
  1000
  ho_type_from_ho_term type_enc pred_sym ary
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1001
  o ho_term_from_typ type_enc
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
  1002
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  1003
fun aliased_uncurried ary (s, s') =
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  1004
  (s ^ ascii_of_uncurried_alias_sep ^ string_of_int ary, s' ^ string_of_int ary)
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  1005
fun unaliased_uncurried (s, s') =
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  1006
  case space_explode uncurried_alias_sep s of
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1007
    [_] => (s, s')
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1008
  | [s1, s2] => (s1, unsuffix s2 s')
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1009
  | _ => raise Fail "ill-formed explicit application alias"
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1010
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1011
fun raw_mangled_const_name type_name ty_args (s, s') =
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
  1012
  let
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
  1013
    fun type_suffix f g =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1014
      fold_rev (curry (op ^) o g o prefix mangled_type_sep o type_name f)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1015
               ty_args ""
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
  1016
  in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1017
fun mangled_const_name type_enc =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1018
  map_filter (ho_term_for_type_arg type_enc)
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1019
  #> raw_mangled_const_name generic_mangled_type_name
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1020
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1021
val parse_mangled_ident =
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1022
  Scan.many1 (not o member (op =) ["(", ")", ","]) >> implode
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1023
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1024
fun parse_mangled_type x =
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1025
  (parse_mangled_ident
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1026
   -- Scan.optional ($$ "(" |-- Scan.optional parse_mangled_types [] --| $$ ")")
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1027
                    [] >> ATerm) x
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1028
and parse_mangled_types x =
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1029
  (parse_mangled_type ::: Scan.repeat ($$ "," |-- parse_mangled_type)) x
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1030
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1031
fun unmangled_type s =
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1032
  s |> suffix ")" |> raw_explode
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1033
    |> Scan.finite Symbol.stopper
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1034
           (Scan.error (!! (fn _ => raise Fail ("unrecognized mangled type " ^
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1035
                                                quote s)) parse_mangled_type))
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1036
    |> fst
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1037
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1038
fun unmangled_const_name s =
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  1039
  (s, s) |> unaliased_uncurried |> fst |> space_explode mangled_type_sep
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1040
fun unmangled_const s =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1041
  let val ss = unmangled_const_name s in
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1042
    (hd ss, map unmangled_type (tl ss))
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1043
  end
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1044
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1045
fun introduce_proxies_in_iterm type_enc =
42568
7b9801a34836 no needless "fequal" proxies if "explicit_apply" is set + always have readable names
blanchet
parents: 42566
diff changeset
  1046
  let
43987
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1047
    fun tweak_ho_quant ho_quant T [IAbs _] = IConst (`I ho_quant, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1048
      | tweak_ho_quant ho_quant (T as Type (_, [p_T as Type (_, [x_T, _]), _]))
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1049
                       _ =
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1050
        (* Eta-expand "!!" and "??", to work around LEO-II 1.2.8 parser
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1051
           limitation. This works in conjuction with special code in
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1052
           "ATP_Problem" that uses the syntactic sugar "!" and "?" whenever
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1053
           possible. *)
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1054
        IAbs ((`I "P", p_T),
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1055
              IApp (IConst (`I ho_quant, T, []),
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1056
                    IAbs ((`I "X", x_T),
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1057
                          IApp (IConst (`I "P", p_T, []),
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1058
                                IConst (`I "X", x_T, [])))))
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1059
      | tweak_ho_quant _ _ _ = raise Fail "unexpected type for quantifier"
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1060
    fun intro top_level args (IApp (tm1, tm2)) =
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1061
        IApp (intro top_level (tm2 :: args) tm1, intro false [] tm2)
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1062
      | intro top_level args (IConst (name as (s, _), T, T_args)) =
42570
77f94ac04f32 cleanup proxification/unproxification and make sure that "num_atp_type_args" is called on the proxy in the reconstruction code, since "c_fequal" has one type arg but the unproxified equal has 0
blanchet
parents: 42569
diff changeset
  1063
        (case proxify_const s of
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
  1064
           SOME proxy_base =>
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  1065
           if top_level orelse is_type_enc_higher_order type_enc then
43000
bd424c3dde46 cleaner handling of equality and proxies (esp. for THF)
blanchet
parents: 42998
diff changeset
  1066
             case (top_level, s) of
43987
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1067
               (_, "c_False") => IConst (`I tptp_false, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1068
             | (_, "c_True") => IConst (`I tptp_true, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1069
             | (false, "c_Not") => IConst (`I tptp_not, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1070
             | (false, "c_conj") => IConst (`I tptp_and, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1071
             | (false, "c_disj") => IConst (`I tptp_or, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1072
             | (false, "c_implies") => IConst (`I tptp_implies, T, [])
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1073
             | (false, "c_All") => tweak_ho_quant tptp_ho_forall T args
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1074
             | (false, "c_Ex") => tweak_ho_quant tptp_ho_exists T args
43000
bd424c3dde46 cleaner handling of equality and proxies (esp. for THF)
blanchet
parents: 42998
diff changeset
  1075
             | (false, s) =>
44097
3cae91385086 workaround THF parser limitation
blanchet
parents: 44088
diff changeset
  1076
               if is_tptp_equal s andalso length args = 2 then
3cae91385086 workaround THF parser limitation
blanchet
parents: 44088
diff changeset
  1077
                 IConst (`I tptp_equal, T, [])
3cae91385086 workaround THF parser limitation
blanchet
parents: 44088
diff changeset
  1078
               else
47786
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1079
                 (* Eta-expand partially applied THF equality, because the
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1080
                    LEO-II and Satallax parsers complain about not being able to
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1081
                    infer the type of "=". *)
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1082
                 let val i_T = domain_type T in
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1083
                   IAbs ((`I "X", i_T),
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1084
                         IAbs ((`I "Y", i_T),
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1085
                               IApp (IApp (IConst (`I tptp_equal, T, []),
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1086
                                           IConst (`I "X", i_T, [])),
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1087
                                     IConst (`I "Y", i_T, []))))
034cc7cc8b4a eta-expand unapplied equalities in THF rather than using a proxy
blanchet
parents: 47776
diff changeset
  1088
                 end
43987
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1089
             | _ => IConst (name, T, [])
42569
5737947e4c77 make sure that fequal keeps its type arguments for mangled type systems
blanchet
parents: 42568
diff changeset
  1090
           else
43987
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1091
             IConst (proxy_base |>> prefix const_prefix, T, T_args)
45167
6bc8d260d459 gracefully handle quantifiers of the form "All $ t" where "t" is not a lambda-abstraction in higher-order translations
blanchet
parents: 44859
diff changeset
  1092
          | NONE => if s = tptp_choice then tweak_ho_quant tptp_choice T args
6bc8d260d459 gracefully handle quantifiers of the form "All $ t" where "t" is not a lambda-abstraction in higher-order translations
blanchet
parents: 44859
diff changeset
  1093
                    else IConst (name, T, T_args))
43987
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1094
      | intro _ _ (IAbs (bound, tm)) = IAbs (bound, intro false [] tm)
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1095
      | intro _ _ tm = tm
2850b7dc27a4 further worked around LEO-II parser limitation, with eta-expansion
blanchet
parents: 43985
diff changeset
  1096
  in intro true [] end
42568
7b9801a34836 no needless "fequal" proxies if "explicit_apply" is set + always have readable names
blanchet
parents: 42566
diff changeset
  1097
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1098
fun mangle_type_args_in_const type_enc (name as (s, _)) T_args =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1099
  case unprefix_and_unascii const_prefix s of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1100
    NONE => (name, T_args)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1101
  | SOME s'' =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1102
    case type_arg_policy [] type_enc (invert_const s'') of
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1103
      Mangled_Type_Args => (mangled_const_name type_enc T_args name, [])
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1104
    | _ => (name, T_args)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1105
fun mangle_type_args_in_iterm type_enc =
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1106
  if polymorphism_of_type_enc type_enc = Mangled_Monomorphic then
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1107
    let
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1108
      fun mangle (IApp (tm1, tm2)) = IApp (mangle tm1, mangle tm2)
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1109
        | mangle (tm as IConst (_, _, [])) = tm
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1110
        | mangle (IConst (name, T, T_args)) =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1111
          mangle_type_args_in_const type_enc name T_args
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1112
          |> (fn (name, T_args) => IConst (name, T, T_args))
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1113
        | mangle (IAbs (bound, tm)) = IAbs (bound, mangle tm)
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1114
        | mangle tm = tm
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1115
    in mangle end
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1116
  else
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1117
    I
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1118
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1119
fun chop_fun 0 T = ([], T)
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1120
  | chop_fun n (Type (@{type_name fun}, [dom_T, ran_T])) =
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1121
    chop_fun (n - 1) ran_T |>> cons dom_T
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1122
  | chop_fun _ T = ([], T)
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1123
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1124
fun filter_const_type_args _ _ _ [] = []
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1125
  | filter_const_type_args thy s ary T_args =
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1126
    let
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1127
      val U = robust_const_type thy s
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1128
      val arg_U_vars = fold Term.add_tvarsT (U |> chop_fun ary |> fst) []
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1129
      val U_args = (s, U) |> robust_const_typargs thy
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1130
    in
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1131
      U_args ~~ T_args
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1132
      |> map (fn (U, T) =>
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1133
                 if member (op =) arg_U_vars (dest_TVar U) then dummyT else T)
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1134
    end
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1135
    handle TYPE _ => T_args
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1136
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1137
fun filter_type_args_in_const _ _ _ _ _ [] = []
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1138
  | filter_type_args_in_const thy monom_constrs type_enc ary s T_args =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1139
    case unprefix_and_unascii const_prefix s of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1140
      NONE =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1141
      if level_of_type_enc type_enc = No_Types orelse s = tptp_choice then []
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1142
      else T_args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1143
    | SOME s'' =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1144
      let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1145
        val s'' = invert_const s''
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1146
        fun filter_T_args false = T_args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1147
          | filter_T_args true = filter_const_type_args thy s'' ary T_args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1148
      in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1149
        case type_arg_policy monom_constrs type_enc s'' of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1150
          Explicit_Type_Args infer_from_term_args =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1151
          filter_T_args infer_from_term_args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1152
        | No_Type_Args => []
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1153
        | Mangled_Type_Args => raise Fail "unexpected (un)mangled symbol"
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1154
      end
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  1155
fun filter_type_args_in_iterm thy monom_constrs type_enc =
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1156
  let
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1157
    fun filt ary (IApp (tm1, tm2)) = IApp (filt (ary + 1) tm1, filt 0 tm2)
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1158
      | filt ary (IConst (name as (s, _), T, T_args)) =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1159
        filter_type_args_in_const thy monom_constrs type_enc ary s T_args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1160
        |> (fn T_args => IConst (name, T, T_args))
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1161
      | filt _ (IAbs (bound, tm)) = IAbs (bound, filt 0 tm)
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1162
      | filt _ tm = tm
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  1163
  in filt 0 end
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1164
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1165
fun iformula_from_prop ctxt type_enc iff_for_eq =
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1166
  let
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1167
    val thy = Proof_Context.theory_of ctxt
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1168
    fun do_term bs t atomic_Ts =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1169
      iterm_from_term thy type_enc bs (Envir.eta_contract t)
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1170
      |>> (introduce_proxies_in_iterm type_enc
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1171
           #> mangle_type_args_in_iterm type_enc #> AAtom)
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1172
      ||> union (op =) atomic_Ts
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1173
    fun do_quant bs q pos s T t' =
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1174
      let
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1175
        val s = singleton (Name.variant_list (map fst bs)) s
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1176
        val universal = Option.map (q = AExists ? not) pos
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1177
        val name =
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1178
          s |> `(case universal of
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1179
                   SOME true => make_all_bound_var
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1180
                 | SOME false => make_exist_bound_var
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1181
                 | NONE => make_bound_var)
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1182
      in
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1183
        do_formula ((s, (name, T)) :: bs) pos t'
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1184
        #>> mk_aquant q [(name, SOME T)]
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1185
        ##> union (op =) (atomic_types_of T)
38518
54727b44e277 handle bound name conflicts gracefully in FOF translation
blanchet
parents: 38496
diff changeset
  1186
      end
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1187
    and do_conn bs c pos1 t1 pos2 t2 =
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1188
      do_formula bs pos1 t1 ##>> do_formula bs pos2 t2 #>> uncurry (mk_aconn c)
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1189
    and do_formula bs pos t =
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1190
      case t of
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1191
        @{const Trueprop} $ t1 => do_formula bs pos t1
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1192
      | @{const Not} $ t1 => do_formula bs (Option.map not pos) t1 #>> mk_anot
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1193
      | Const (@{const_name All}, _) $ Abs (s, T, t') =>
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1194
        do_quant bs AForall pos s T t'
45167
6bc8d260d459 gracefully handle quantifiers of the form "All $ t" where "t" is not a lambda-abstraction in higher-order translations
blanchet
parents: 44859
diff changeset
  1195
      | (t0 as Const (@{const_name All}, _)) $ t1 =>
6bc8d260d459 gracefully handle quantifiers of the form "All $ t" where "t" is not a lambda-abstraction in higher-order translations
blanchet
parents: 44859
diff changeset
  1196
        do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1197
      | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1198
        do_quant bs AExists pos s T t'
45167
6bc8d260d459 gracefully handle quantifiers of the form "All $ t" where "t" is not a lambda-abstraction in higher-order translations
blanchet
parents: 44859
diff changeset
  1199
      | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
6bc8d260d459 gracefully handle quantifiers of the form "All $ t" where "t" is not a lambda-abstraction in higher-order translations
blanchet
parents: 44859
diff changeset
  1200
        do_formula bs pos (t0 $ eta_expand (map (snd o snd) bs) t1 1)
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1201
      | @{const HOL.conj} $ t1 $ t2 => do_conn bs AAnd pos t1 pos t2
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1202
      | @{const HOL.disj} $ t1 $ t2 => do_conn bs AOr pos t1 pos t2
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1203
      | @{const HOL.implies} $ t1 $ t2 =>
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1204
        do_conn bs AImplies (Option.map not pos) t1 pos t2
38864
4abe644fcea5 formerly unnamed infix equality now named HOL.eq
haftmann
parents: 38829
diff changeset
  1205
      | Const (@{const_name HOL.eq}, Type (_, [@{typ bool}, _])) $ t1 $ t2 =>
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1206
        if iff_for_eq then do_conn bs AIff NONE t1 NONE t2 else do_term bs t
41140
9c68004b8c9d added Sledgehammer support for higher-order propositional reasoning
blanchet
parents: 41138
diff changeset
  1207
      | _ => do_term bs t
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1208
  in do_formula [] end
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1209
47151
blanchet
parents: 47150
diff changeset
  1210
fun presimplify_term thy t =
blanchet
parents: 47150
diff changeset
  1211
  if exists_Const (member (op =) Meson.presimplified_consts o fst) t then
blanchet
parents: 47150
diff changeset
  1212
    t |> Skip_Proof.make_thm thy
blanchet
parents: 47150
diff changeset
  1213
      |> Meson.presimplify
blanchet
parents: 47150
diff changeset
  1214
      |> prop_of
blanchet
parents: 47150
diff changeset
  1215
  else
blanchet
parents: 47150
diff changeset
  1216
    t
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1217
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1218
fun preprocess_abstractions_in_terms trans_lams facts =
43862
a14fdb8c0497 pass kind to lambda-translation function
blanchet
parents: 43861
diff changeset
  1219
  let
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1220
    val (facts, lambda_ts) =
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1221
      facts |> map (snd o snd) |> trans_lams
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1222
            |>> map2 (fn (name, (kind, _)) => fn t => (name, (kind, t))) facts
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1223
    val lam_facts =
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1224
      map2 (fn t => fn j =>
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  1225
               ((lam_fact_prefix ^ Int.toString j, (Global, Def)), (Axiom, t)))
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1226
           lambda_ts (1 upto length lambda_ts)
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1227
  in (facts, lam_facts) end
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1228
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1229
(* Metis's use of "resolve_tac" freezes the schematic variables. We simulate the
42353
7797efa897a1 correctly handle TFrees that occur in (local) facts -- Metis did the right thing here but Sledgehammer was incorrectly generating spurious preconditions such as "dense_linorder(t_a)"
blanchet
parents: 42237
diff changeset
  1230
   same in Sledgehammer to prevent the discovery of unreplayable proofs. *)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1231
fun freeze_term t =
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1232
  let
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1233
    fun freeze (t $ u) = freeze t $ freeze u
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1234
      | freeze (Abs (s, T, t)) = Abs (s, T, freeze t)
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1235
      | freeze (Var ((s, i), T)) =
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1236
        Free (atp_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1237
      | freeze t = t
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1238
  in t |> exists_subterm is_Var t ? freeze end
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1239
47769
249a940953b0 don't extensionalize formulas for higher-order provers -- Satallax in particular will only expand definitions of the form "constant = ..."
blanchet
parents: 47768
diff changeset
  1240
fun presimp_prop ctxt type_enc t =
47713
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1241
  let
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1242
    val thy = Proof_Context.theory_of ctxt
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1243
    val t = t |> Envir.beta_eta_contract
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1244
              |> transform_elim_prop
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1245
              |> Object_Logic.atomize_term thy
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1246
    val need_trueprop = (fastype_of t = @{typ bool})
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1247
  in
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1248
    t |> need_trueprop ? HOLogic.mk_Trueprop
47769
249a940953b0 don't extensionalize formulas for higher-order provers -- Satallax in particular will only expand definitions of the form "constant = ..."
blanchet
parents: 47768
diff changeset
  1249
      |> not (is_type_enc_higher_order type_enc) ? extensionalize_term ctxt
47713
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1250
      |> presimplify_term thy
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1251
      |> HOLogic.dest_Trueprop
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1252
  end
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1253
  handle TERM _ => @{const True}
43096
f181d66046d4 don't preprocess twice
blanchet
parents: 43093
diff changeset
  1254
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1255
(* Satallax prefers "=" to "<=>" (for definitions) and Metis (CNF) requires "="
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1256
   for obscure technical reasons. *)
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1257
fun should_use_iff_for_eq CNF _ = false
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1258
  | should_use_iff_for_eq (THF _) format = not (is_type_enc_higher_order format)
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1259
  | should_use_iff_for_eq _ _ = true
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1260
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1261
fun make_formula ctxt format type_enc iff_for_eq name stature kind t =
43096
f181d66046d4 don't preprocess twice
blanchet
parents: 43093
diff changeset
  1262
  let
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1263
    val iff_for_eq = iff_for_eq andalso should_use_iff_for_eq format type_enc
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1264
    val (iformula, atomic_Ts) =
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1265
      iformula_from_prop ctxt type_enc iff_for_eq (SOME (kind <> Conjecture)) t
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1266
                         []
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1267
      |>> close_iformula_universally
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1268
  in
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
  1269
    {name = name, stature = stature, kind = kind, iformula = iformula,
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1270
     atomic_types = atomic_Ts}
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1271
  end
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1272
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1273
fun make_fact ctxt format type_enc iff_for_eq ((name, stature), t) =
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1274
  case t |> make_formula ctxt format type_enc iff_for_eq name stature Axiom of
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1275
    formula as {iformula = AAtom (IConst ((s, _), _, _)), ...} =>
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1276
    if s = tptp_true then NONE else SOME formula
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1277
  | formula => SOME formula
42561
23ddc4e3d19c have properly type-instantiated helper facts (combinators and If)
blanchet
parents: 42560
diff changeset
  1278
47713
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1279
fun s_not_prop (@{const Trueprop} $ t) = @{const Trueprop} $ s_not t
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1280
  | s_not_prop _ = @{prop True} (* "t" is too meta for "metis" *)
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1281
(*
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1282
  | s_not_prop (@{const "==>"} $ t $ @{prop False}) = t
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1283
  | s_not_prop t = @{const "==>"} $ t $ @{prop False}
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1284
*)
44460
blanchet
parents: 44450
diff changeset
  1285
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1286
fun make_conjecture ctxt format type_enc =
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
  1287
  map (fn ((name, stature), (kind, t)) =>
47713
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1288
          t |> kind = Conjecture ? s_not
47905
9b6afe0eb69c cleaner handling of bi-implication for THF output of first-order type encodings
blanchet
parents: 47810
diff changeset
  1289
            |> make_formula ctxt format type_enc true name stature kind)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1290
42682
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1291
(** Finite and infinite type inference **)
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1292
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1293
fun tvar_footprint thy s ary =
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1294
  (case unprefix_and_unascii const_prefix s of
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1295
     SOME s =>
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1296
     s |> invert_const |> robust_const_type thy |> chop_fun ary |> fst
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1297
       |> map (fn T => Term.add_tvarsT T [] |> map fst)
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1298
   | NONE => [])
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1299
  handle TYPE _ => []
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1300
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1301
fun ghost_type_args thy s ary =
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1302
  if is_tptp_equal s then
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1303
    0 upto ary - 1
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1304
  else
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1305
    let
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1306
      val footprint = tvar_footprint thy s ary
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1307
      val eq = (s = @{const_name HOL.eq})
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1308
      fun ghosts _ [] = []
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1309
        | ghosts seen ((i, tvars) :: args) =
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1310
          ghosts (union (op =) seen tvars) args
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1311
          |> (eq orelse exists (fn tvar => not (member (op =) seen tvar)) tvars)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1312
             ? cons i
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1313
    in
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1314
      if forall null footprint then
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1315
        []
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1316
      else
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1317
        0 upto length footprint - 1 ~~ footprint
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1318
        |> sort (rev_order o list_ord Term_Ord.indexname_ord o pairself snd)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1319
        |> ghosts []
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1320
    end
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1321
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1322
type monotonicity_info =
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1323
  {maybe_finite_Ts : typ list,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1324
   surely_finite_Ts : typ list,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1325
   maybe_infinite_Ts : typ list,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1326
   surely_infinite_Ts : typ list,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1327
   maybe_nonmono_Ts : typ list}
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1328
44397
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
  1329
(* These types witness that the type classes they belong to allow infinite
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
  1330
   models and hence that any types with these type classes is monotonic. *)
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
  1331
val known_infinite_types =
44634
2ac4ff398bc3 make "sound" sound and "unsound" more sound, based on evaluation
blanchet
parents: 44626
diff changeset
  1332
  [@{typ nat}, HOLogic.intT, HOLogic.realT, @{typ "nat => bool"}]
44397
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
  1333
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
  1334
fun is_type_kind_of_surely_infinite ctxt strictness cached_Ts T =
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
  1335
  strictness <> Strict andalso is_type_surely_infinite ctxt true cached_Ts T
42886
208ec29cc013 improved "poly_preds_{bang,query}" by picking up good witnesses for the possible infinity of common type classes and ensuring that "?'a::type" doesn't ruin everything
blanchet
parents: 42885
diff changeset
  1336
42682
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1337
(* Finite types such as "unit", "bool", "bool * bool", and "bool => bool" are
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1338
   dangerous because their "exhaust" properties can easily lead to unsound ATP
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1339
   proofs. On the other hand, all HOL infinite types can be given the same
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1340
   models in first-order logic (via Löwenheim-Skolem). *)
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1341
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1342
fun should_encode_type _ (_ : monotonicity_info) All_Types _ = true
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1343
  | should_encode_type ctxt {maybe_finite_Ts, surely_infinite_Ts,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1344
                             maybe_nonmono_Ts, ...}
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
  1345
                       (Noninf_Nonmono_Types (strictness, grain)) T =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1346
    let val thy = Proof_Context.theory_of ctxt in
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1347
      grain = Ghost_Type_Arg_Vars orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1348
      (exists (type_intersect thy T) maybe_nonmono_Ts andalso
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1349
       not (exists (type_instance thy T) surely_infinite_Ts orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1350
            (not (member (type_equiv thy) maybe_finite_Ts T) andalso
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1351
             is_type_kind_of_surely_infinite ctxt strictness surely_infinite_Ts
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1352
                                             T)))
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1353
    end
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1354
  | should_encode_type ctxt {surely_finite_Ts, maybe_infinite_Ts,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1355
                             maybe_nonmono_Ts, ...}
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1356
                       (Fin_Nonmono_Types grain) T =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1357
    let val thy = Proof_Context.theory_of ctxt in
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1358
      grain = Ghost_Type_Arg_Vars orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1359
      (exists (type_intersect thy T) maybe_nonmono_Ts andalso
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1360
       (exists (type_generalization thy T) surely_finite_Ts orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1361
        (not (member (type_equiv thy) maybe_infinite_Ts T) andalso
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1362
         is_type_surely_finite ctxt T)))
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1363
    end
42682
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1364
  | should_encode_type _ _ _ _ = false
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1365
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  1366
fun should_guard_type ctxt mono (Guards (_, level)) should_guard_var T =
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1367
    should_guard_var () andalso should_encode_type ctxt mono level T
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1368
  | should_guard_type _ _ _ _ _ = false
42682
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1369
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1370
fun is_maybe_universal_var (IConst ((s, _), _, _)) =
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1371
    String.isPrefix bound_var_prefix s orelse
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1372
    String.isPrefix all_bound_var_prefix s
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1373
  | is_maybe_universal_var (IVar _) = true
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1374
  | is_maybe_universal_var _ = false
42836
9adf6b3965b3 code cleanup, better handling of corner cases
blanchet
parents: 42834
diff changeset
  1375
45947
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  1376
datatype site =
43361
e37b54d429f5 revived the lightweight "poly_tags_{query,bang}" type encodings by fixing their soundness bug
blanchet
parents: 43324
diff changeset
  1377
  Top_Level of bool option |
e37b54d429f5 revived the lightweight "poly_tags_{query,bang}" type encodings by fixing their soundness bug
blanchet
parents: 43324
diff changeset
  1378
  Eq_Arg of bool option |
e37b54d429f5 revived the lightweight "poly_tags_{query,bang}" type encodings by fixing their soundness bug
blanchet
parents: 43324
diff changeset
  1379
  Elsewhere
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  1380
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1381
fun should_tag_with_type _ _ _ (Top_Level _) _ _ = false
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1382
  | should_tag_with_type ctxt mono (Tags (_, level)) site u T =
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1383
    if granularity_of_type_level level = All_Vars then
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1384
      should_encode_type ctxt mono level T
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1385
    else
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1386
      (case (site, is_maybe_universal_var u) of
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1387
         (Eq_Arg _, true) => should_encode_type ctxt mono level T
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1388
       | _ => false)
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1389
  | should_tag_with_type _ _ _ _ _ _ = false
42682
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1390
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  1391
fun fused_type ctxt mono level =
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
  1392
  let
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1393
    val should_encode = should_encode_type ctxt mono level
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  1394
    fun fuse 0 T = if should_encode T then T else fused_infinite_type
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  1395
      | fuse ary (Type (@{type_name fun}, [T1, T2])) =
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  1396
        fuse 0 T1 --> fuse (ary - 1) T2
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  1397
      | fuse _ _ = raise Fail "expected function type"
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  1398
  in fuse end
42682
562046fd8e0c added type homogenization, whereby all (isomorphic) infinite types are mapped to the same type (to reduce the number of different predicates/TFF-types)
blanchet
parents: 42680
diff changeset
  1399
44450
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1400
(** predicators and application operators **)
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  1401
42574
blanchet
parents: 42573
diff changeset
  1402
type sym_info =
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1403
  {pred_sym : bool, min_ary : int, max_ary : int, types : typ list,
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1404
   in_conj : bool}
42563
e70ffe3846d0 improve helper type instantiation code
blanchet
parents: 42562
diff changeset
  1405
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1406
fun default_sym_tab_entries type_enc =
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1407
  (make_fixed_const NONE @{const_name undefined},
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1408
       {pred_sym = false, min_ary = 0, max_ary = 0, types = [],
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1409
        in_conj = false}) ::
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1410
  ([tptp_false, tptp_true]
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1411
   |> map (rpair {pred_sym = true, min_ary = 0, max_ary = 0, types = [],
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1412
                  in_conj = false})) @
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1413
  ([tptp_equal, tptp_old_equal]
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1414
   |> map (rpair {pred_sym = true, min_ary = 2, max_ary = 2, types = [],
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1415
                  in_conj = false}))
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1416
  |> not (is_type_enc_higher_order type_enc)
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1417
     ? cons (prefixed_predicator_name,
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1418
             {pred_sym = true, min_ary = 1, max_ary = 1, types = [],
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1419
              in_conj = false})
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1420
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1421
datatype app_op_level =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1422
  Min_App_Op |
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1423
  Sufficient_App_Op |
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1424
  Sufficient_App_Op_And_Predicator |
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1425
  Full_App_Op_And_Predicator
46389
blanchet
parents: 46385
diff changeset
  1426
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1427
fun sym_table_for_facts ctxt type_enc app_op_level conjs facts =
42558
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
  1428
  let
46642
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1429
    val thy = Proof_Context.theory_of ctxt
44772
blanchet
parents: 44771
diff changeset
  1430
    fun consider_var_ary const_T var_T max_ary =
43064
b6e61d22fa61 made "explicit_apply" smarter -- no need to force explicit applications in minimizer on all constants, better do it more fine granularly
blanchet
parents: 43039
diff changeset
  1431
      let
b6e61d22fa61 made "explicit_apply" smarter -- no need to force explicit applications in minimizer on all constants, better do it more fine granularly
blanchet
parents: 43039
diff changeset
  1432
        fun iter ary T =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1433
          if ary = max_ary orelse type_instance thy var_T T orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1434
             type_instance thy T var_T then
43210
7384b771805d made "explicit_apply"'s smart mode (more) complete
blanchet
parents: 43207
diff changeset
  1435
            ary
7384b771805d made "explicit_apply"'s smart mode (more) complete
blanchet
parents: 43207
diff changeset
  1436
          else
7384b771805d made "explicit_apply"'s smart mode (more) complete
blanchet
parents: 43207
diff changeset
  1437
            iter (ary + 1) (range_type T)
43064
b6e61d22fa61 made "explicit_apply" smarter -- no need to force explicit applications in minimizer on all constants, better do it more fine granularly
blanchet
parents: 43039
diff changeset
  1438
      in iter 0 const_T end
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1439
    fun add_universal_var T (accum as ((bool_vars, fun_var_Ts), sym_tab)) =
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1440
      if (app_op_level = Sufficient_App_Op andalso can dest_funT T) orelse
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1441
         (app_op_level = Sufficient_App_Op_And_Predicator andalso
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1442
          (can dest_funT T orelse T = @{typ bool})) then
43201
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1443
        let
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1444
          val bool_vars' =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1445
            bool_vars orelse
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1446
            (app_op_level = Sufficient_App_Op_And_Predicator andalso
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1447
             body_type T = @{typ bool})
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1448
          fun repair_min_ary {pred_sym, min_ary, max_ary, types, in_conj} =
43201
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1449
            {pred_sym = pred_sym andalso not bool_vars',
44772
blanchet
parents: 44771
diff changeset
  1450
             min_ary = fold (fn T' => consider_var_ary T' T) types min_ary,
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1451
             max_ary = max_ary, types = types, in_conj = in_conj}
43201
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1452
          val fun_var_Ts' =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1453
            fun_var_Ts |> can dest_funT T ? insert_type thy I T
43201
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1454
        in
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1455
          if bool_vars' = bool_vars andalso
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1456
             pointer_eq (fun_var_Ts', fun_var_Ts) then
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1457
            accum
43167
839f599bc7ed ensured that the logic for "explicit_apply = smart" also works on CNF (i.e. new Metis)
blanchet
parents: 43159
diff changeset
  1458
          else
44772
blanchet
parents: 44771
diff changeset
  1459
            ((bool_vars', fun_var_Ts'), Symtab.map (K repair_min_ary) sym_tab)
43201
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1460
        end
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1461
      else
0c9bf1a8e0d8 make "smart" mode of "explicit_apply" smarter, by also detecting the other kind of higher-order quantification, namely "bool"s
blanchet
parents: 43198
diff changeset
  1462
        accum
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1463
      fun add_iterm_syms conj_fact top_level tm
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1464
                         (accum as ((bool_vars, fun_var_Ts), sym_tab)) =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1465
        let val (head, args) = strip_iterm_comb tm in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1466
          (case head of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1467
             IConst ((s, _), T, _) =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1468
             if String.isPrefix bound_var_prefix s orelse
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1469
                String.isPrefix all_bound_var_prefix s then
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1470
               add_universal_var T accum
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1471
             else if String.isPrefix exist_bound_var_prefix s then
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1472
               accum
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1473
             else
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1474
               let val ary = length args in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1475
                 ((bool_vars, fun_var_Ts),
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1476
                  case Symtab.lookup sym_tab s of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1477
                    SOME {pred_sym, min_ary, max_ary, types, in_conj} =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1478
                    let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1479
                      val pred_sym =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1480
                        pred_sym andalso top_level andalso not bool_vars
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  1481
                      val types' = types |> insert_type thy I T
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1482
                      val in_conj = in_conj orelse conj_fact
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1483
                      val min_ary =
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1484
                        if (app_op_level = Sufficient_App_Op orelse
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1485
                            app_op_level = Sufficient_App_Op_And_Predicator)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1486
                           andalso not (pointer_eq (types', types)) then
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1487
                          fold (consider_var_ary T) fun_var_Ts min_ary
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1488
                        else
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1489
                          min_ary
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1490
                    in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1491
                      Symtab.update (s, {pred_sym = pred_sym,
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1492
                                         min_ary = Int.min (ary, min_ary),
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1493
                                         max_ary = Int.max (ary, max_ary),
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1494
                                         types = types', in_conj = in_conj})
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1495
                                    sym_tab
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1496
                    end
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1497
                  | NONE =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1498
                    let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1499
                      val pred_sym = top_level andalso not bool_vars
46639
d0ef1d1562d7 fixed arity bug with "If" helpers for "If" that returns a function
blanchet
parents: 46450
diff changeset
  1500
                      val ary =
d0ef1d1562d7 fixed arity bug with "If" helpers for "If" that returns a function
blanchet
parents: 46450
diff changeset
  1501
                        case unprefix_and_unascii const_prefix s of
d0ef1d1562d7 fixed arity bug with "If" helpers for "If" that returns a function
blanchet
parents: 46450
diff changeset
  1502
                          SOME s =>
46642
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1503
                          (if String.isSubstring uncurried_alias_sep s then
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1504
                             ary
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1505
                           else case try (robust_const_ary thy
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1506
                                          o invert_const o hd
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1507
                                          o unmangled_const_name) s of
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1508
                             SOME ary0 => Int.min (ary0, ary)
37a055f37224 general solution to the arity bug that occasionally plagues Sledgehammer -- short story, lots of things go kaputt when a polymorphic symbol's arity in the translation is higher than the arity of the fully polymorphic HOL constant
blanchet
parents: 46639
diff changeset
  1509
                           | NONE => ary)
46639
d0ef1d1562d7 fixed arity bug with "If" helpers for "If" that returns a function
blanchet
parents: 46450
diff changeset
  1510
                        | NONE => ary
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1511
                      val min_ary =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1512
                        case app_op_level of
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1513
                          Min_App_Op => ary
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1514
                        | Full_App_Op_And_Predicator => 0
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  1515
                        | _ => fold (consider_var_ary T) fun_var_Ts ary
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1516
                    in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1517
                      Symtab.update_new (s,
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1518
                          {pred_sym = pred_sym, min_ary = min_ary,
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1519
                           max_ary = ary, types = [T], in_conj = conj_fact})
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1520
                          sym_tab
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1521
                    end)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1522
               end
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1523
           | IVar (_, T) => add_universal_var T accum
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1524
           | IAbs ((_, T), tm) =>
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1525
             accum |> add_universal_var T |> add_iterm_syms conj_fact false tm
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1526
           | _ => accum)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1527
          |> fold (add_iterm_syms conj_fact false) args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1528
        end
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1529
    fun add_fact_syms conj_fact =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1530
      K (add_iterm_syms conj_fact true) |> formula_fold NONE |> fact_lift
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1531
  in
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1532
    ((false, []), Symtab.empty)
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1533
    |> fold (add_fact_syms true) conjs
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1534
    |> fold (add_fact_syms false) facts
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1535
    |> snd
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1536
    |> fold Symtab.update (default_sym_tab_entries type_enc)
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  1537
  end
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1538
44772
blanchet
parents: 44771
diff changeset
  1539
fun min_ary_of sym_tab s =
42558
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
  1540
  case Symtab.lookup sym_tab s of
42574
blanchet
parents: 42573
diff changeset
  1541
    SOME ({min_ary, ...} : sym_info) => min_ary
42558
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
  1542
  | NONE =>
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1543
    case unprefix_and_unascii const_prefix s of
42547
b5eec0c99528 fixed arity of special constants if "explicit_apply" is set
blanchet
parents: 42546
diff changeset
  1544
      SOME s =>
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1545
      let val s = s |> unmangled_const_name |> hd |> invert_const in
42966
4e2d6c1e5392 more work on parsing LEO-II proofs without lambdas
blanchet
parents: 42963
diff changeset
  1546
        if s = predicator_name then 1
4e2d6c1e5392 more work on parsing LEO-II proofs without lambdas
blanchet
parents: 42963
diff changeset
  1547
        else if s = app_op_name then 2
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  1548
        else if s = type_guard_name then 1
42557
ae0deb39a254 fixed min-arity computation when "explicit_apply" is specified
blanchet
parents: 42556
diff changeset
  1549
        else 0
42547
b5eec0c99528 fixed arity of special constants if "explicit_apply" is set
blanchet
parents: 42546
diff changeset
  1550
      end
42544
75cb06eee990 reimplemented the hAPP introduction code so that it's done earlier, when the types are still available
blanchet
parents: 42543
diff changeset
  1551
    | NONE => 0
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1552
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1553
(* True if the constant ever appears outside of the top-level position in
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1554
   literals, or if it appears with different arities (e.g., because of different
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1555
   type instantiations). If false, the constant always receives all of its
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1556
   arguments and is used as a predicate. *)
42558
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
  1557
fun is_pred_sym sym_tab s =
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
  1558
  case Symtab.lookup sym_tab s of
42574
blanchet
parents: 42573
diff changeset
  1559
    SOME ({pred_sym, min_ary, max_ary, ...} : sym_info) =>
blanchet
parents: 42573
diff changeset
  1560
    pred_sym andalso min_ary = max_ary
42558
3d9930cb6770 cleaned up "explicit_apply" so that it shares most of its code path with the default mode of operation
blanchet
parents: 42557
diff changeset
  1561
  | NONE => false
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  1562
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1563
val app_op = `(make_fixed_const NONE) app_op_name
42568
7b9801a34836 no needless "fequal" proxies if "explicit_apply" is set + always have readable names
blanchet
parents: 42566
diff changeset
  1564
val predicator_combconst =
44495
4c2242c8a96c added choice operator output for
nik
parents: 44494
diff changeset
  1565
  IConst (`(make_fixed_const NONE) predicator_name, @{typ "bool => bool"}, [])
42542
024920b65ce2 perform constant mangling and/or removal of its type args in an earlier phase, so that the rest of the code doesn't need to worry about it
blanchet
parents: 42541
diff changeset
  1566
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1567
fun list_app head args = fold (curry (IApp o swap)) args head
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1568
fun predicator tm = IApp (predicator_combconst, tm)
42544
75cb06eee990 reimplemented the hAPP introduction code so that it's done earlier, when the types are still available
blanchet
parents: 42543
diff changeset
  1569
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1570
fun mk_app_op type_enc head arg =
42544
75cb06eee990 reimplemented the hAPP introduction code so that it's done earlier, when the types are still available
blanchet
parents: 42543
diff changeset
  1571
  let
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1572
    val head_T = ityp_of head
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1573
    val (arg_T, res_T) = dest_funT head_T
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1574
    val app =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1575
      IConst (app_op, head_T --> head_T, [arg_T, res_T])
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1576
      |> mangle_type_args_in_iterm type_enc
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1577
  in list_app app [head, arg] end
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1578
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1579
fun firstorderize_fact thy monom_constrs type_enc sym_tab uncurried_aliases =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1580
  let
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1581
    fun do_app arg head = mk_app_op type_enc head arg
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1582
    fun list_app_ops head args = fold do_app args head
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1583
    fun introduce_app_ops tm =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1584
      let val (head, args) = tm |> strip_iterm_comb ||> map introduce_app_ops in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1585
        case head of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1586
          IConst (name as (s, _), T, T_args) =>
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  1587
          if uncurried_aliases andalso String.isPrefix const_prefix s then
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1588
            let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1589
              val ary = length args
46639
d0ef1d1562d7 fixed arity bug with "If" helpers for "If" that returns a function
blanchet
parents: 46450
diff changeset
  1590
              val name =
d0ef1d1562d7 fixed arity bug with "If" helpers for "If" that returns a function
blanchet
parents: 46450
diff changeset
  1591
                name |> ary > min_ary_of sym_tab s ? aliased_uncurried ary
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1592
            in list_app (IConst (name, T, T_args)) args end
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1593
          else
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1594
            args |> chop (min_ary_of sym_tab s)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1595
                 |>> list_app head |-> list_app_ops
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1596
        | _ => list_app_ops head args
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1597
      end
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1598
    fun introduce_predicators tm =
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1599
      case strip_iterm_comb tm of
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1600
        (IConst ((s, _), _, _), _) =>
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1601
        if is_pred_sym sym_tab s then tm else predicator tm
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1602
      | _ => predicator tm
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1603
    val do_iterm =
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1604
      not (is_type_enc_higher_order type_enc)
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1605
      ? (introduce_app_ops #> introduce_predicators)
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  1606
      #> filter_type_args_in_iterm thy monom_constrs type_enc
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1607
  in update_iformula (formula_map do_iterm) end
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1608
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1609
(** Helper facts **)
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1610
44450
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1611
val not_ffalse = @{lemma "~ fFalse" by (unfold fFalse_def) fast}
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1612
val ftrue = @{lemma "fTrue" by (unfold fTrue_def) fast}
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1613
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1614
(* The Boolean indicates that a fairly sound type encoding is needed. *)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1615
val helper_table =
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1616
  [(("COMBI", false), @{thms Meson.COMBI_def}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1617
   (("COMBK", false), @{thms Meson.COMBK_def}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1618
   (("COMBB", false), @{thms Meson.COMBB_def}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1619
   (("COMBC", false), @{thms Meson.COMBC_def}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1620
   (("COMBS", false), @{thms Meson.COMBS_def}),
44450
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1621
   ((predicator_name, false), [not_ffalse, ftrue]),
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1622
   (("fFalse", false), [not_ffalse]),
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1623
   (("fFalse", true), @{thms True_or_False}),
44450
d848dd7b21f4 fixed "hBOOL" of existential variables, and generate more helpers
blanchet
parents: 44418
diff changeset
  1624
   (("fTrue", false), [ftrue]),
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1625
   (("fTrue", true), @{thms True_or_False}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1626
   (("fNot", false),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1627
    @{thms fNot_def [THEN Meson.iff_to_disjD, THEN conjunct1]
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1628
           fNot_def [THEN Meson.iff_to_disjD, THEN conjunct2]}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1629
   (("fconj", false),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1630
    @{lemma "~ P | ~ Q | fconj P Q" "~ fconj P Q | P" "~ fconj P Q | Q"
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1631
        by (unfold fconj_def) fast+}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1632
   (("fdisj", false),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1633
    @{lemma "~ P | fdisj P Q" "~ Q | fdisj P Q" "~ fdisj P Q | P | Q"
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1634
        by (unfold fdisj_def) fast+}),
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1635
   (("fimplies", false),
43210
7384b771805d made "explicit_apply"'s smart mode (more) complete
blanchet
parents: 43207
diff changeset
  1636
    @{lemma "P | fimplies P Q" "~ Q | fimplies P Q" "~ fimplies P Q | ~ P | Q"
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1637
        by (unfold fimplies_def) fast+}),
43678
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
  1638
   (("fequal", true),
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
  1639
    (* This is a lie: Higher-order equality doesn't need a sound type encoding.
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
  1640
       However, this is done so for backward compatibility: Including the
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
  1641
       equality helpers by default in Metis breaks a few existing proofs. *)
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
  1642
    @{thms fequal_def [THEN Meson.iff_to_disjD, THEN conjunct1]
56d352659500 improved translation of lambdas in THF
nik
parents: 43677
diff changeset
  1643
           fequal_def [THEN Meson.iff_to_disjD, THEN conjunct2]}),
44003
0a0ee31ec20a added helpers for "All" and "Ex"
blanchet
parents: 44001
diff changeset
  1644
   (* Partial characterization of "fAll" and "fEx". A complete characterization
0a0ee31ec20a added helpers for "All" and "Ex"
blanchet
parents: 44001
diff changeset
  1645
      would require the axiom of choice for replay with Metis. *)
0a0ee31ec20a added helpers for "All" and "Ex"
blanchet
parents: 44001
diff changeset
  1646
   (("fAll", false), [@{lemma "~ fAll P | P x" by (auto simp: fAll_def)}]),
0a0ee31ec20a added helpers for "All" and "Ex"
blanchet
parents: 44001
diff changeset
  1647
   (("fEx", false), [@{lemma "~ P x | fEx P" by (auto simp: fEx_def)}]),
43194
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1648
   (("If", true), @{thms if_True if_False True_or_False})]
ef3ff8856245 fixed type helper indices in new Metis
blanchet
parents: 43193
diff changeset
  1649
  |> map (apsnd (map zero_var_indexes))
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1650
47767
blanchet
parents: 47718
diff changeset
  1651
fun atype_of_type_vars (Native (_, Polymorphic, _)) = SOME atype_of_types
45364
d00339ae7fff repaired quantification over type variables for non-TFF1/THF encodings
blanchet
parents: 45316
diff changeset
  1652
  | atype_of_type_vars _ = NONE
d00339ae7fff repaired quantification over type variables for non-TFF1/THF encodings
blanchet
parents: 45316
diff changeset
  1653
45920
ddbe94f7242c ensure TPTP FOF/TFF/THF formulas are close
blanchet
parents: 45875
diff changeset
  1654
fun bound_tvars type_enc sorts Ts =
ddbe94f7242c ensure TPTP FOF/TFF/THF formulas are close
blanchet
parents: 45875
diff changeset
  1655
  (sorts ? mk_ahorn (formulas_for_types type_enc add_sorts_on_tvar Ts))
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1656
  #> mk_aquant AForall
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1657
        (map_filter (fn TVar (x as (s, _), _) =>
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1658
                        SOME ((make_schematic_type_var x, s),
45364
d00339ae7fff repaired quantification over type variables for non-TFF1/THF encodings
blanchet
parents: 45316
diff changeset
  1659
                              atype_of_type_vars type_enc)
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  1660
                      | _ => NONE) Ts)
44404
3111af540141 tuning, plus started implementing tag equation generation for existential variables
blanchet
parents: 44403
diff changeset
  1661
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1662
fun eq_formula type_enc atomic_Ts bounds pred_sym tm1 tm2 =
44404
3111af540141 tuning, plus started implementing tag equation generation for existential variables
blanchet
parents: 44403
diff changeset
  1663
  (if pred_sym then AConn (AIff, [AAtom tm1, AAtom tm2])
3111af540141 tuning, plus started implementing tag equation generation for existential variables
blanchet
parents: 44403
diff changeset
  1664
   else AAtom (ATerm (`I tptp_equal, [tm1, tm2])))
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1665
  |> mk_aquant AForall bounds
45377
blanchet
parents: 45364
diff changeset
  1666
  |> close_formula_universally
45920
ddbe94f7242c ensure TPTP FOF/TFF/THF formulas are close
blanchet
parents: 45875
diff changeset
  1667
  |> bound_tvars type_enc true atomic_Ts
44404
3111af540141 tuning, plus started implementing tag equation generation for existential variables
blanchet
parents: 44403
diff changeset
  1668
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1669
val helper_rank = default_rank
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1670
val min_rank = 9 * helper_rank div 10
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1671
val max_rank = 4 * min_rank
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1672
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1673
fun rank_of_fact_num n j = min_rank + (max_rank - min_rank) * j div n
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1674
44495
4c2242c8a96c added choice operator output for
nik
parents: 44494
diff changeset
  1675
val type_tag = `(make_fixed_const NONE) type_tag_name
43130
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
  1676
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  1677
fun should_specialize_helper type_enc t =
44493
c2602c5d4b0a handle nonmangled monomorphich the same way as mangled monomorphic when it comes to helper -- otherwise we can end up generating too tight type guards
blanchet
parents: 44491
diff changeset
  1678
  polymorphism_of_type_enc type_enc <> Polymorphic andalso
43628
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1679
  level_of_type_enc type_enc <> No_Types andalso
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1680
  not (null (Term.hidden_polymorphism t))
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
  1681
47810
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1682
fun add_helper_facts_for_sym ctxt format type_enc (s, {types, ...} : sym_info) =
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1683
  case unprefix_and_unascii const_prefix s of
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1684
    SOME mangled_s =>
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1685
    let
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1686
      val thy = Proof_Context.theory_of ctxt
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1687
      val unmangled_s = mangled_s |> unmangled_const_name |> hd
43628
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1688
      fun dub needs_fairly_sound j k =
46339
6268c5b3efdc generate left-to-right rewrite tag for combinator helpers for SPASS 3.8
blanchet
parents: 46338
diff changeset
  1689
        unmangled_s ^ "_" ^ string_of_int j ^ "_" ^ string_of_int k ^
6268c5b3efdc generate left-to-right rewrite tag for combinator helpers for SPASS 3.8
blanchet
parents: 46338
diff changeset
  1690
        (if mangled_s = unmangled_s then "" else "_" ^ ascii_of mangled_s) ^
6268c5b3efdc generate left-to-right rewrite tag for combinator helpers for SPASS 3.8
blanchet
parents: 46338
diff changeset
  1691
        (if needs_fairly_sound then typed_helper_suffix
6268c5b3efdc generate left-to-right rewrite tag for combinator helpers for SPASS 3.8
blanchet
parents: 46338
diff changeset
  1692
         else untyped_helper_suffix)
43159
29b55f292e0b added support for helpers in new Metis, so far only for polymorphic type encodings
blanchet
parents: 43139
diff changeset
  1693
      fun dub_and_inst needs_fairly_sound (th, j) =
43628
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1694
        let val t = prop_of th in
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1695
          if should_specialize_helper type_enc t then
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1696
            map (fn T => specialize_type thy (invert_const unmangled_s, T) t)
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1697
                types
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1698
          else
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1699
            [t]
996b2022ff78 further repair "mangled_tags", now that tags are also mangled
blanchet
parents: 43626
diff changeset
  1700
        end
46339
6268c5b3efdc generate left-to-right rewrite tag for combinator helpers for SPASS 3.8
blanchet
parents: 46338
diff changeset
  1701
        |> tag_list 1
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  1702
        |> map (fn (k, t) => ((dub needs_fairly_sound j k, (Global, Def)), t))
43860
57ef3cd4126e more refactoring of preprocessing, so as to be able to centralize it
blanchet
parents: 43859
diff changeset
  1703
      val make_facts = map_filter (make_fact ctxt format type_enc false)
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  1704
      val fairly_sound = is_type_enc_fairly_sound type_enc
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1705
    in
47810
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1706
      fold (fn ((helper_s, needs_fairly_sound), ths) =>
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1707
               if helper_s <> unmangled_s orelse
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1708
                  (needs_fairly_sound andalso not fairly_sound) then
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1709
                 I
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1710
               else
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1711
                 ths ~~ (1 upto length ths)
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1712
                 |> maps (dub_and_inst needs_fairly_sound)
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1713
                 |> make_facts
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1714
                 |> union (op = o pairself #iformula))
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1715
           helper_table
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1716
    end
47810
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1717
  | NONE => I
43858
be41d12de6fa simplify code -- there are no lambdas in helpers anyway
blanchet
parents: 43857
diff changeset
  1718
fun helper_facts_for_sym_table ctxt format type_enc sym_tab =
47810
9579464d00f9 avoid duplicate helpers
blanchet
parents: 47786
diff changeset
  1719
  Symtab.fold_rev (add_helper_facts_for_sym ctxt format type_enc) sym_tab []
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1720
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1721
(***************************************************************)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1722
(* Type Classes Present in the Axiom or Conjecture Clauses     *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1723
(***************************************************************)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1724
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1725
fun set_insert (x, s) = Symtab.update (x, ()) s
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1726
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1727
fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1728
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1729
(* Remove this trivial type class (FIXME: similar code elsewhere) *)
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1730
fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1731
43093
blanchet
parents: 43092
diff changeset
  1732
fun classes_of_terms get_Ts =
43121
5df3777f376d make SML/NJ happier
blanchet
parents: 43120
diff changeset
  1733
  map (map snd o get_Ts)
43093
blanchet
parents: 43092
diff changeset
  1734
  #> List.foldl add_classes Symtab.empty
blanchet
parents: 43092
diff changeset
  1735
  #> delete_type #> Symtab.keys
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1736
44121
44adaa6db327 old term operations are legacy;
wenzelm
parents: 44097
diff changeset
  1737
val tfree_classes_of_terms = classes_of_terms Misc_Legacy.term_tfrees
44adaa6db327 old term operations are legacy;
wenzelm
parents: 44097
diff changeset
  1738
val tvar_classes_of_terms = classes_of_terms Misc_Legacy.term_tvars
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1739
43622
blanchet
parents: 43572
diff changeset
  1740
fun fold_type_constrs f (Type (s, Ts)) x =
blanchet
parents: 43572
diff changeset
  1741
    fold (fold_type_constrs f) Ts (f (s, x))
43189
blanchet
parents: 43188
diff changeset
  1742
  | fold_type_constrs _ _ x = x
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1743
43907
073ab5379842 pass type arguments to lambda-lifted Frees, to account for polymorphism
blanchet
parents: 43906
diff changeset
  1744
(* Type constructors used to instantiate overloaded constants are the only ones
073ab5379842 pass type arguments to lambda-lifted Frees, to account for polymorphism
blanchet
parents: 43906
diff changeset
  1745
   needed. *)
43189
blanchet
parents: 43188
diff changeset
  1746
fun add_type_constrs_in_term thy =
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1747
  let
43188
0c36ae874fcc fixed detection of Skolem constants in type construction detection code
blanchet
parents: 43185
diff changeset
  1748
    fun add (Const (@{const_name Meson.skolem}, _) $ _) = I
43181
cd3b7798ecc2 don't stumble on Skolem names
blanchet
parents: 43179
diff changeset
  1749
      | add (t $ u) = add t #> add u
44738
1b333e4173a2 drop more type arguments soundly, when they can be deduced from the arg types
blanchet
parents: 44634
diff changeset
  1750
      | add (Const x) =
1b333e4173a2 drop more type arguments soundly, when they can be deduced from the arg types
blanchet
parents: 44634
diff changeset
  1751
        x |> robust_const_typargs thy |> fold (fold_type_constrs set_insert)
43181
cd3b7798ecc2 don't stumble on Skolem names
blanchet
parents: 43179
diff changeset
  1752
      | add (Abs (_, _, u)) = add u
cd3b7798ecc2 don't stumble on Skolem names
blanchet
parents: 43179
diff changeset
  1753
      | add _ = I
cd3b7798ecc2 don't stumble on Skolem names
blanchet
parents: 43179
diff changeset
  1754
  in add end
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1755
43189
blanchet
parents: 43188
diff changeset
  1756
fun type_constrs_of_terms thy ts =
blanchet
parents: 43188
diff changeset
  1757
  Symtab.keys (fold (add_type_constrs_in_term thy) ts Symtab.empty)
43085
0a2f5b86bdd7 first step in sharing more code between ATP and Metis translation
blanchet
parents: 43064
diff changeset
  1758
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1759
fun extract_lambda_def (Const (@{const_name HOL.eq}, _) $ t $ u) =
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1760
    let val (head, args) = strip_comb t in
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1761
      (head |> dest_Const |> fst,
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1762
       fold_rev (fn t as Var ((s, _), T) =>
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1763
                    (fn u => Abs (s, T, abstract_over (t, u)))
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1764
                  | _ => raise Fail "expected Var") args u)
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1765
    end
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1766
  | extract_lambda_def _ = raise Fail "malformed lifted lambda"
45508
b216dc1b3630 started implementing lambda-lifting in Metis
blanchet
parents: 45401
diff changeset
  1767
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1768
fun trans_lams_from_string ctxt type_enc lam_trans =
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1769
  if lam_trans = no_lamsN then
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1770
    rpair []
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1771
  else if lam_trans = hide_lamsN then
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1772
    lift_lams ctxt type_enc ##> K []
46365
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
  1773
  else if lam_trans = liftingN orelse lam_trans = lam_liftingN then
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1774
    lift_lams ctxt type_enc
46365
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
  1775
  else if lam_trans = combsN then
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1776
    map (introduce_combinators ctxt) #> rpair []
46365
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
  1777
  else if lam_trans = combs_and_liftingN then
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
  1778
    lift_lams_part_1 ctxt type_enc
547d1a1dcaf6 rename lambda translation schemes
blanchet
parents: 46341
diff changeset
  1779
    ##> maps (fn t => [t, introduce_combinators ctxt (intentionalize_def t)])
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1780
    #> lift_lams_part_2 ctxt
46368
ded0390eceae implemented new lambda translations scheme
blanchet
parents: 46365
diff changeset
  1781
  else if lam_trans = combs_or_liftingN then
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1782
    lift_lams_part_1 ctxt type_enc
46368
ded0390eceae implemented new lambda translations scheme
blanchet
parents: 46365
diff changeset
  1783
    ##> map (fn t => case head_of (strip_qnt_body @{const_name All} t) of
ded0390eceae implemented new lambda translations scheme
blanchet
parents: 46365
diff changeset
  1784
                       @{term "op =::bool => bool => bool"} => t
ded0390eceae implemented new lambda translations scheme
blanchet
parents: 46365
diff changeset
  1785
                     | _ => introduce_combinators ctxt (intentionalize_def t))
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1786
    #> lift_lams_part_2 ctxt
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1787
  else if lam_trans = keep_lamsN then
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1788
    map (Envir.eta_contract) #> rpair []
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1789
  else
45519
cd6e78cb6ee8 make metis reconstruction handling more flexible
blanchet
parents: 45516
diff changeset
  1790
    error ("Unknown lambda translation scheme: " ^ quote lam_trans ^ ".")
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1791
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1792
fun translate_formulas ctxt prem_kind format type_enc lam_trans presimp hyp_ts
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1793
                       concl_t facts =
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1794
  let
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1795
    val thy = Proof_Context.theory_of ctxt
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1796
    val trans_lams = trans_lams_from_string ctxt type_enc lam_trans
43861
a08c591bdcdf more refactoring of preprocessing
blanchet
parents: 43860
diff changeset
  1797
    val fact_ts = facts |> map snd
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1798
    (* Remove existing facts from the conjecture, as this can dramatically
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1799
       boost an ATP's performance (for some reason). *)
43192
9c29a00f2970 avoid renumbering hypotheses
blanchet
parents: 43189
diff changeset
  1800
    val hyp_ts =
9c29a00f2970 avoid renumbering hypotheses
blanchet
parents: 43189
diff changeset
  1801
      hyp_ts
9c29a00f2970 avoid renumbering hypotheses
blanchet
parents: 43189
diff changeset
  1802
      |> map (fn t => if member (op aconv) fact_ts t then @{prop True} else t)
43864
58a7b3fdc193 fixed lambda-liftg: must ensure the formulas are in close form
blanchet
parents: 43863
diff changeset
  1803
    val facts = facts |> map (apsnd (pair Axiom))
58a7b3fdc193 fixed lambda-liftg: must ensure the formulas are in close form
blanchet
parents: 43863
diff changeset
  1804
    val conjs =
47713
bd0683000a0f fix handling of atomizable conjectures without a top-level "Trueprop" (e.g. "x == (y::nat)")
blanchet
parents: 47153
diff changeset
  1805
      map (pair prem_kind) hyp_ts @ [(Conjecture, s_not_prop concl_t)]
45168
0e8e662013f9 freeze conjecture schematics before applying lambda-translation, which sometimes calls "close_form" and ruins it for freezing
blanchet
parents: 45167
diff changeset
  1806
      |> map (apsnd freeze_term)
46340
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
  1807
      |> map2 (pair o rpair (Local, General) o string_of_int)
cac402c486b0 separate orthogonal components
blanchet
parents: 46339
diff changeset
  1808
              (0 upto length hyp_ts)
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1809
    val ((conjs, facts), lam_facts) =
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1810
      (conjs, facts)
47769
249a940953b0 don't extensionalize formulas for higher-order provers -- Satallax in particular will only expand definitions of the form "constant = ..."
blanchet
parents: 47768
diff changeset
  1811
      |> presimp ? pairself (map (apsnd (apsnd (presimp_prop ctxt type_enc))))
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1812
      |> (if lam_trans = no_lamsN then
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1813
            rpair []
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1814
          else
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1815
            op @
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  1816
            #> preprocess_abstractions_in_terms trans_lams
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  1817
            #>> chop (length conjs))
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  1818
    val conjs = conjs |> make_conjecture ctxt format type_enc
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1819
    val (fact_names, facts) =
43864
58a7b3fdc193 fixed lambda-liftg: must ensure the formulas are in close form
blanchet
parents: 43863
diff changeset
  1820
      facts
43863
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1821
      |> map_filter (fn (name, (_, t)) =>
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1822
                        make_fact ctxt format type_enc true (name, t)
a43d61270142 ensure that the lambda translation procedure is called only once with all the facts, which is necessary for soundness of lambda-lifting (freshness of new names)
blanchet
parents: 43862
diff changeset
  1823
                        |> Option.map (pair name))
43861
a08c591bdcdf more refactoring of preprocessing
blanchet
parents: 43860
diff changeset
  1824
      |> ListPair.unzip
46375
d724066ff3d0 reverted e2b1a86d59fc -- broke Metis's lambda-lifting
blanchet
parents: 46371
diff changeset
  1825
    val lifted = lam_facts |> map (extract_lambda_def o snd o snd)
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1826
    val lam_facts =
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1827
      lam_facts |> map_filter (make_fact ctxt format type_enc true o apsnd snd)
43861
a08c591bdcdf more refactoring of preprocessing
blanchet
parents: 43860
diff changeset
  1828
    val all_ts = concl_t :: hyp_ts @ fact_ts
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1829
    val subs = tfree_classes_of_terms all_ts
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1830
    val supers = tvar_classes_of_terms all_ts
43189
blanchet
parents: 43188
diff changeset
  1831
    val tycons = type_constrs_of_terms thy all_ts
43861
a08c591bdcdf more refactoring of preprocessing
blanchet
parents: 43860
diff changeset
  1832
    val (supers, arity_clauses) =
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  1833
      if level_of_type_enc type_enc = No_Types then ([], [])
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1834
      else make_arity_clauses thy tycons supers
43861
a08c591bdcdf more refactoring of preprocessing
blanchet
parents: 43860
diff changeset
  1835
    val class_rel_clauses = make_class_rel_clauses thy subs supers
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1836
  in
45508
b216dc1b3630 started implementing lambda-lifting in Metis
blanchet
parents: 45401
diff changeset
  1837
    (fact_names |> map single, union (op =) subs supers, conjs,
45554
09ad83de849c don't pass "lam_lifted" option to "metis" unless there's a good reason
blanchet
parents: 45551
diff changeset
  1838
     facts @ lam_facts, class_rel_clauses, arity_clauses, lifted)
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1839
  end
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1840
44495
4c2242c8a96c added choice operator output for
nik
parents: 44494
diff changeset
  1841
val type_guard = `(make_fixed_const NONE) type_guard_name
43130
d73fc2e55308 implemented missing hAPP and ti cases of new path finder
blanchet
parents: 43129
diff changeset
  1842
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1843
fun type_guard_iterm type_enc T tm =
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  1844
  IApp (IConst (type_guard, T --> @{typ bool}, [T])
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1845
        |> mangle_type_args_in_iterm type_enc, tm)
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1846
43421
926bfe067a32 fixed soundness bug related to extensionality
blanchet
parents: 43401
diff changeset
  1847
fun is_var_positively_naked_in_term _ (SOME false) _ accum = accum
926bfe067a32 fixed soundness bug related to extensionality
blanchet
parents: 43401
diff changeset
  1848
  | is_var_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum =
43000
bd424c3dde46 cleaner handling of equality and proxies (esp. for THF)
blanchet
parents: 42998
diff changeset
  1849
    accum orelse (is_tptp_equal s andalso member (op =) tms (ATerm (name, [])))
43692
264881a20f50 make SML/NJ happy + tuning
blanchet
parents: 43678
diff changeset
  1850
  | is_var_positively_naked_in_term _ _ _ _ = true
44403
15160cdc4688 precisely distinguish between universal and existential quantifiers, instead of assuming the worst (universal), for monotonicity analysis
blanchet
parents: 44402
diff changeset
  1851
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1852
fun is_var_ghost_type_arg_in_term thy polym_constrs name pos tm accum =
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1853
  is_var_positively_naked_in_term name pos tm accum orelse
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1854
  let
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1855
    val var = ATerm (name, [])
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1856
    fun is_nasty_in_term (ATerm (_, [])) = false
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1857
      | is_nasty_in_term (ATerm ((s, _), tms)) =
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1858
        let
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1859
          val ary = length tms
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1860
          val polym_constr = member (op =) polym_constrs s
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1861
          val ghosts = ghost_type_args thy s ary
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1862
        in
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1863
          exists (fn (j, tm) =>
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1864
                     if polym_constr then
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1865
                       member (op =) ghosts j andalso
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1866
                       (tm = var orelse is_nasty_in_term tm)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1867
                     else
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1868
                       tm = var andalso member (op =) ghosts j)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1869
                 (0 upto ary - 1 ~~ tms)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1870
          orelse (not polym_constr andalso exists is_nasty_in_term tms)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1871
        end
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1872
      | is_nasty_in_term _ = true
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1873
  in is_nasty_in_term tm end
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1874
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1875
fun should_guard_var_in_formula thy polym_constrs level pos phi (SOME true)
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1876
                                name =
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1877
    (case granularity_of_type_level level of
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1878
       All_Vars => true
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1879
     | Positively_Naked_Vars =>
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1880
       formula_fold pos (is_var_positively_naked_in_term name) phi false
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1881
     | Ghost_Type_Arg_Vars =>
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1882
       formula_fold pos (is_var_ghost_type_arg_in_term thy polym_constrs name) phi
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1883
                    false)
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1884
  | should_guard_var_in_formula _ _ _ _ _ _ _ = true
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1885
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1886
fun always_guard_var_in_formula _ _ _ _ _ _ _ = true
42834
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1887
44405
6fe1a89bb69a generate tag equations for existential variables
blanchet
parents: 44404
diff changeset
  1888
fun should_generate_tag_bound_decl _ _ _ (SOME true) _ = false
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  1889
  | should_generate_tag_bound_decl ctxt mono (Tags (_, level)) _ T =
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1890
    granularity_of_type_level level <> All_Vars andalso
44782
blanchet
parents: 44774
diff changeset
  1891
    should_encode_type ctxt mono level T
44405
6fe1a89bb69a generate tag equations for existential variables
blanchet
parents: 44404
diff changeset
  1892
  | should_generate_tag_bound_decl _ _ _ _ _ = false
44404
3111af540141 tuning, plus started implementing tag equation generation for existential variables
blanchet
parents: 44403
diff changeset
  1893
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1894
fun mk_aterm type_enc name T_args args =
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1895
  ATerm (name, map_filter (ho_term_for_type_arg type_enc) T_args @ args)
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
  1896
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1897
fun do_bound_type ctxt mono type_enc =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1898
  case type_enc of
47767
blanchet
parents: 47718
diff changeset
  1899
    Native (_, _, level) =>
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1900
    fused_type ctxt mono level 0 #> ho_type_from_typ type_enc false 0 #> SOME
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1901
  | _ => K NONE
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  1902
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1903
fun tag_with_type ctxt mono type_enc pos T tm =
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1904
  IConst (type_tag, T --> T, [T])
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1905
  |> mangle_type_args_in_iterm type_enc
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1906
  |> ho_term_from_iterm ctxt mono type_enc pos
43692
264881a20f50 make SML/NJ happy + tuning
blanchet
parents: 43678
diff changeset
  1907
  |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm])
264881a20f50 make SML/NJ happy + tuning
blanchet
parents: 43678
diff changeset
  1908
       | _ => raise Fail "unexpected lambda-abstraction")
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1909
and ho_term_from_iterm ctxt mono type_enc pos =
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1910
  let
47153
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1911
    fun beta_red bs (IApp (IAbs ((name, _), tm), tm')) =
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1912
        beta_red ((name, beta_red bs tm') :: bs) tm
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1913
      | beta_red bs (IApp tmp) = IApp (pairself (beta_red bs) tmp)
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1914
      | beta_red bs (tm as IConst (name, _, _)) =
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1915
        (case AList.lookup (op =) bs name of
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1916
           SOME tm' => tm'
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1917
         | NONE => tm)
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1918
      | beta_red bs (IAbs ((name, T), tm)) =
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1919
        IAbs ((name, T), beta_red (AList.delete (op =) name bs) tm)
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1920
      | beta_red _ tm = tm
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1921
    fun term site u =
42962
3b50fdeb6cfc started adding support for THF output (but no lambdas)
blanchet
parents: 42956
diff changeset
  1922
      let
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1923
        val (head, args) = strip_iterm_comb u
43677
2cd0b478d1b6 added generation of lambdas in THF
nik
parents: 43676
diff changeset
  1924
        val pos =
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1925
          case site of
43677
2cd0b478d1b6 added generation of lambdas in THF
nik
parents: 43676
diff changeset
  1926
            Top_Level pos => pos
2cd0b478d1b6 added generation of lambdas in THF
nik
parents: 43676
diff changeset
  1927
          | Eq_Arg pos => pos
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  1928
          | _ => NONE
43677
2cd0b478d1b6 added generation of lambdas in THF
nik
parents: 43676
diff changeset
  1929
        val t =
2cd0b478d1b6 added generation of lambdas in THF
nik
parents: 43676
diff changeset
  1930
          case head of
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1931
            IConst (name as (s, _), _, T_args) =>
47153
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1932
            let
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1933
              val arg_site = if is_tptp_equal s then Eq_Arg pos else Elsewhere
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1934
            in map (term arg_site) args |> mk_aterm type_enc name T_args end
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1935
          | IVar (name, _) =>
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1936
            map (term Elsewhere) args |> mk_aterm type_enc name []
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1937
          | IAbs ((name, T), tm) =>
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1938
            if is_type_enc_higher_order type_enc then
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1939
              AAbs ((name, ho_type_from_typ type_enc true 0 T),
46818
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1940
                    term Elsewhere tm)
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1941
            else
2a28e66e2e4c ensure no abstractions leak through after lambda-lifting (for formulas with higher-order occurrences of quantifiers)
blanchet
parents: 46711
diff changeset
  1942
              raise Fail "unexpected lambda-abstraction"
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1943
          | IApp _ => raise Fail "impossible \"IApp\""
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1944
        val T = ityp_of u
42962
3b50fdeb6cfc started adding support for THF output (but no lambdas)
blanchet
parents: 42956
diff changeset
  1945
      in
45949
70b9d1e9fddc killed "guard@?" encodings -- they were found to be unsound
blanchet
parents: 45948
diff changeset
  1946
        if should_tag_with_type ctxt mono type_enc site u T then
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1947
          tag_with_type ctxt mono type_enc pos T t
45947
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  1948
        else
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  1949
          t
42962
3b50fdeb6cfc started adding support for THF output (but no lambdas)
blanchet
parents: 42956
diff changeset
  1950
      end
47153
4d4f2721b3ef fixed eta-extension of higher-order quantifiers in THF output
blanchet
parents: 47151
diff changeset
  1951
  in term (Top_Level pos) o beta_red [] end
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1952
and formula_from_iformula ctxt polym_constrs mono type_enc should_guard_var =
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  1953
  let
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1954
    val thy = Proof_Context.theory_of ctxt
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  1955
    val level = level_of_type_enc type_enc
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1956
    val do_term = ho_term_from_iterm ctxt mono type_enc
42878
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1957
    fun do_out_of_bound_type pos phi universal (name, T) =
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  1958
      if should_guard_type ctxt mono type_enc
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1959
             (fn () => should_guard_var thy polym_constrs level pos phi
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  1960
                                        universal name) T then
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1961
        IVar (name, T)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1962
        |> type_guard_iterm type_enc T
43361
e37b54d429f5 revived the lightweight "poly_tags_{query,bang}" type encodings by fixing their soundness bug
blanchet
parents: 43324
diff changeset
  1963
        |> do_term pos |> AAtom |> SOME
44405
6fe1a89bb69a generate tag equations for existential variables
blanchet
parents: 44404
diff changeset
  1964
      else if should_generate_tag_bound_decl ctxt mono type_enc universal T then
6fe1a89bb69a generate tag equations for existential variables
blanchet
parents: 44404
diff changeset
  1965
        let
6fe1a89bb69a generate tag equations for existential variables
blanchet
parents: 44404
diff changeset
  1966
          val var = ATerm (name, [])
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1967
          val tagged_var = tag_with_type ctxt mono type_enc pos T var
44405
6fe1a89bb69a generate tag equations for existential variables
blanchet
parents: 44404
diff changeset
  1968
        in SOME (AAtom (ATerm (`I tptp_equal, [tagged_var, var]))) end
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1969
      else
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1970
        NONE
42878
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1971
    fun do_formula pos (AQuant (q, xs, phi)) =
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1972
        let
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1973
          val phi = phi |> do_formula pos
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1974
          val universal = Option.map (q = AExists ? not) pos
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1975
          val do_bound_type = do_bound_type ctxt mono type_enc
42878
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1976
        in
42834
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1977
          AQuant (q, xs |> map (apsnd (fn NONE => NONE
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1978
                                        | SOME T => do_bound_type T)),
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1979
                  (if q = AForall then mk_ahorn else fold_rev (mk_aconn AAnd))
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1980
                      (map_filter
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1981
                           (fn (_, NONE) => NONE
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1982
                             | (s, SOME T) =>
42878
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1983
                               do_out_of_bound_type pos phi universal (s, T))
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1984
                           xs)
42834
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1985
                      phi)
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  1986
        end
42878
85ac4c12a4b7 slightly fewer type predicates introduced in the lightweight encoding, based on the observation that only universal positive equalities are dangerous
blanchet
parents: 42855
diff changeset
  1987
      | do_formula pos (AConn conn) = aconn_map pos do_formula conn
43361
e37b54d429f5 revived the lightweight "poly_tags_{query,bang}" type encodings by fixing their soundness bug
blanchet
parents: 43324
diff changeset
  1988
      | do_formula pos (AAtom tm) = AAtom (do_term pos tm)
43493
bdb11c68f142 generate type predicates for existentials/skolems, otherwise some problems might not be provable
blanchet
parents: 43423
diff changeset
  1989
  in do_formula end
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1990
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1991
(* Each fact is given a unique fact number to avoid name clashes (e.g., because
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1992
   of monomorphization). The TPTP explicitly forbids name clashes, and some of
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  1993
   the remote provers might care. *)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1994
fun formula_line_for_fact ctxt polym_constrs prefix encode freshen pos
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  1995
        mono type_enc rank (j, {name, stature, kind, iformula, atomic_types}) =
43864
58a7b3fdc193 fixed lambda-liftg: must ensure the formulas are in close form
blanchet
parents: 43863
diff changeset
  1996
  (prefix ^ (if freshen then string_of_int j ^ "_" else "") ^ encode name, kind,
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  1997
   iformula
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  1998
   |> formula_from_iformula ctxt polym_constrs mono type_enc
45947
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  1999
          should_guard_var_in_formula (if pos then SOME true else NONE)
45377
blanchet
parents: 45364
diff changeset
  2000
   |> close_formula_universally
45920
ddbe94f7242c ensure TPTP FOF/TFF/THF formulas are close
blanchet
parents: 45875
diff changeset
  2001
   |> bound_tvars type_enc true atomic_types,
43493
bdb11c68f142 generate type predicates for existentials/skolems, otherwise some problems might not be provable
blanchet
parents: 43423
diff changeset
  2002
   NONE,
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2003
   let val rank = rank j in
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2004
     case snd stature of
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2005
       Intro => isabelle_info introN rank
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2006
     | Inductive => isabelle_info inductiveN rank
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2007
     | Elim => isabelle_info elimN rank
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2008
     | Simp => isabelle_info simpN rank
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2009
     | Def => isabelle_info defN rank
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2010
     | _ => isabelle_info "" rank
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2011
   end)
43493
bdb11c68f142 generate type predicates for existentials/skolems, otherwise some problems might not be provable
blanchet
parents: 43423
diff changeset
  2012
  |> Formula
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2013
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2014
fun formula_line_for_class_rel_clause type_enc
44593
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
  2015
        ({name, subclass, superclass, ...} : class_rel_clause) =
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2016
  let val ty_arg = ATerm (tvar_a_name, []) in
42577
78414ec6fa4e made the format (TFF or FOF) of the TPTP problem a global argument of the problem again and have the ATPs report which formats they support
blanchet
parents: 42576
diff changeset
  2017
    Formula (class_rel_clause_prefix ^ ascii_of name, Axiom,
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2018
             AConn (AImplies,
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2019
                    [type_class_formula type_enc subclass ty_arg,
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2020
                     type_class_formula type_enc superclass ty_arg])
45830
45a5b6edd4f7 added missing quantifier
blanchet
parents: 45829
diff changeset
  2021
             |> mk_aquant AForall
45a5b6edd4f7 added missing quantifier
blanchet
parents: 45829
diff changeset
  2022
                          [(tvar_a_name, atype_of_type_vars type_enc)],
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2023
             NONE, isabelle_info inductiveN helper_rank)
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2024
  end
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2025
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2026
fun formula_from_arity_atom type_enc (class, t, args) =
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2027
  ATerm (t, map (fn arg => ATerm (arg, [])) args)
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2028
  |> type_class_formula type_enc class
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2029
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2030
fun formula_line_for_arity_clause type_enc
45364
d00339ae7fff repaired quantification over type variables for non-TFF1/THF encodings
blanchet
parents: 45316
diff changeset
  2031
        ({name, prem_atoms, concl_atom} : arity_clause) =
43495
75d2e48c5d30 avoid double ASCII-fication
blanchet
parents: 43493
diff changeset
  2032
  Formula (arity_clause_prefix ^ name, Axiom,
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2033
           mk_ahorn (map (formula_from_arity_atom type_enc) prem_atoms)
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2034
                    (formula_from_arity_atom type_enc concl_atom)
45364
d00339ae7fff repaired quantification over type variables for non-TFF1/THF encodings
blanchet
parents: 45316
diff changeset
  2035
           |> mk_aquant AForall
d00339ae7fff repaired quantification over type variables for non-TFF1/THF encodings
blanchet
parents: 45316
diff changeset
  2036
                  (map (rpair (atype_of_type_vars type_enc)) (#3 concl_atom)),
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2037
           NONE, isabelle_info inductiveN helper_rank)
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2038
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2039
fun formula_line_for_conjecture ctxt polym_constrs mono type_enc
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  2040
        ({name, kind, iformula, atomic_types, ...} : translated_formula) =
42577
78414ec6fa4e made the format (TFF or FOF) of the TPTP problem a global argument of the problem again and have the ATPs report which formats they support
blanchet
parents: 42576
diff changeset
  2041
  Formula (conjecture_prefix ^ name, kind,
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  2042
           iformula
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2043
           |> formula_from_iformula ctxt polym_constrs mono type_enc
45316
08d84bdd5b37 improve handling of bound type variables (esp. for TFF1)
blanchet
parents: 45315
diff changeset
  2044
                  should_guard_var_in_formula (SOME false)
45377
blanchet
parents: 45364
diff changeset
  2045
           |> close_formula_universally
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2046
           |> bound_tvars type_enc true atomic_types, NONE, [])
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2047
47767
blanchet
parents: 47718
diff changeset
  2048
fun type_enc_needs_free_types (Native (_, Polymorphic, _)) = true
blanchet
parents: 47718
diff changeset
  2049
  | type_enc_needs_free_types (Native _) = false
47145
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2050
  | type_enc_needs_free_types _ = true
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2051
44625
4a1132815a70 more tuning
blanchet
parents: 44624
diff changeset
  2052
fun formula_line_for_free_type j phi =
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2053
  Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, phi, NONE, [])
44626
a40b713232c8 make SML/NJ happy
blanchet
parents: 44625
diff changeset
  2054
fun formula_lines_for_free_types type_enc (facts : translated_formula list) =
47145
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2055
  if type_enc_needs_free_types type_enc then
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2056
    let
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2057
      val phis =
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2058
        fold (union (op =)) (map #atomic_types facts) []
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2059
        |> formulas_for_types type_enc add_sorts_on_tfree
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2060
    in map2 formula_line_for_free_type (0 upto length phis - 1) phis end
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2061
  else
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2062
    []
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2063
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2064
(** Symbol declarations **)
42544
75cb06eee990 reimplemented the hAPP introduction code so that it's done earlier, when the types are still available
blanchet
parents: 42543
diff changeset
  2065
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
  2066
fun decl_line_for_class order s =
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2067
  let val name as (s, _) = `make_type_class s in
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2068
    Decl (sym_decl_prefix ^ s, name,
45779
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
  2069
          if order = First_Order then
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
  2070
            ATyAbs ([tvar_a_name],
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
  2071
                    if avoid_first_order_ghost_type_vars then
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
  2072
                      AFun (a_itself_atype, bool_atype)
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
  2073
                    else
eb7b74c7a69b updated TFF1 support
blanchet
parents: 45570
diff changeset
  2074
                      bool_atype)
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2075
          else
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
  2076
            AFun (atype_of_types, bool_atype))
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2077
  end
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2078
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2079
fun decl_lines_for_classes type_enc classes =
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2080
  case type_enc of
47767
blanchet
parents: 47718
diff changeset
  2081
    Native (order, Polymorphic, _) => map (decl_line_for_class order) classes
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2082
  | _ => []
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2083
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2084
fun sym_decl_table_for_facts thy type_enc sym_tab (conjs, facts, extra_tms) =
42574
blanchet
parents: 42573
diff changeset
  2085
  let
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2086
    fun add_iterm_syms tm =
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  2087
      let val (head, args) = strip_iterm_comb tm in
42574
blanchet
parents: 42573
diff changeset
  2088
        (case head of
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  2089
           IConst ((s, s'), T, T_args) =>
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2090
           let
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2091
             val (pred_sym, in_conj) =
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2092
               case Symtab.lookup sym_tab s of
44853
e3310cdb4e48 made SML/NJ happy
blanchet
parents: 44829
diff changeset
  2093
                 SOME ({pred_sym, in_conj, ...} : sym_info) =>
e3310cdb4e48 made SML/NJ happy
blanchet
parents: 44829
diff changeset
  2094
                 (pred_sym, in_conj)
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2095
               | NONE => (false, false)
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2096
             val decl_sym =
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2097
               (case type_enc of
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2098
                  Guards _ => not pred_sym
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2099
                | _ => true) andalso
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2100
               is_tptp_user_symbol s
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2101
           in
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2102
             if decl_sym then
42576
a8a80a2a34be merge symbol declarations that are type-instances of each other -- useful for type system "Args true" with monomorphization turned off
blanchet
parents: 42575
diff changeset
  2103
               Symtab.map_default (s, [])
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2104
                   (insert_type thy #3 (s', T_args, T, pred_sym, length args,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2105
                                        in_conj))
42574
blanchet
parents: 42573
diff changeset
  2106
             else
blanchet
parents: 42573
diff changeset
  2107
               I
blanchet
parents: 42573
diff changeset
  2108
           end
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2109
         | IAbs (_, tm) => add_iterm_syms tm
42574
blanchet
parents: 42573
diff changeset
  2110
         | _ => I)
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2111
        #> fold add_iterm_syms args
42574
blanchet
parents: 42573
diff changeset
  2112
      end
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2113
    val add_fact_syms = K add_iterm_syms |> formula_fold NONE |> fact_lift
43966
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2114
    fun add_formula_var_types (AQuant (_, xs, phi)) =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2115
        fold (fn (_, SOME T) => insert_type thy I T | _ => I) xs
43966
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2116
        #> add_formula_var_types phi
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2117
      | add_formula_var_types (AConn (_, phis)) =
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2118
        fold add_formula_var_types phis
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2119
      | add_formula_var_types _ = I
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2120
    fun var_types () =
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2121
      if polymorphism_of_type_enc type_enc = Polymorphic then [tvar_a]
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2122
      else fold (fact_lift add_formula_var_types) (conjs @ facts) []
bb11faa6a79e declare "undefined" constant
blanchet
parents: 43961
diff changeset
  2123
    fun add_undefined_const T =
43984
aefc5b046c1e mangle "undefined"
blanchet
parents: 43966
diff changeset
  2124
      let
aefc5b046c1e mangle "undefined"
blanchet
parents: 43966
diff changeset
  2125
        val (s, s') =
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2126
          `(make_fixed_const NONE) @{const_name undefined}
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2127
          |> (case type_arg_policy [] type_enc @{const_name undefined} of
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2128
                Mangled_Type_Args => mangled_const_name type_enc [T]
44001
2b75760fa75e no needless mangling
blanchet
parents: 43997
diff changeset
  2129
              | _ => I)
43984
aefc5b046c1e mangle "undefined"
blanchet
parents: 43966
diff changeset
  2130
      in
aefc5b046c1e mangle "undefined"
blanchet
parents: 43966
diff changeset
  2131
        Symtab.map_default (s, [])
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2132
                           (insert_type thy #3 (s', [T], T, false, 0, false))
43984
aefc5b046c1e mangle "undefined"
blanchet
parents: 43966
diff changeset
  2133
      end
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2134
    fun add_TYPE_const () =
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2135
      let val (s, s') = TYPE_name in
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2136
        Symtab.map_default (s, [])
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2137
            (insert_type thy #3
44622
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2138
                         (s', [tvar_a], @{typ "'a itself"}, false, 0, false))
779f79ed0ddc avoid relying on dubious TFF1 feature
blanchet
parents: 44595
diff changeset
  2139
      end
42698
ffd1ae4ff5c6 help SOS by ensuring that typing information is marked as part of the conjecture + be more precise w.r.t. typedefs in monotonicity check
blanchet
parents: 42697
diff changeset
  2140
  in
ffd1ae4ff5c6 help SOS by ensuring that typing information is marked as part of the conjecture + be more precise w.r.t. typedefs in monotonicity check
blanchet
parents: 42697
diff changeset
  2141
    Symtab.empty
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  2142
    |> is_type_enc_fairly_sound type_enc
44829
5a2cd5db0a11 fixed computation of "in_conj" for polymorphic encodings
blanchet
parents: 44814
diff changeset
  2143
       ? (fold (fold add_fact_syms) [conjs, facts]
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2144
          #> fold add_iterm_syms extra_tms
43985
33d8b99531c2 no need for existential witnesses for sorts in TFF and THF formats
blanchet
parents: 43984
diff changeset
  2145
          #> (case type_enc of
47767
blanchet
parents: 47718
diff changeset
  2146
                Native (First_Order, Polymorphic, _) =>
45829
0b19934792d2 remove needless declaration in TFF1 problems
blanchet
parents: 45828
diff changeset
  2147
                if avoid_first_order_ghost_type_vars then add_TYPE_const ()
0b19934792d2 remove needless declaration in TFF1 problems
blanchet
parents: 45828
diff changeset
  2148
                else I
47767
blanchet
parents: 47718
diff changeset
  2149
              | Native _ => I
43985
33d8b99531c2 no need for existential witnesses for sorts in TFF and THF formats
blanchet
parents: 43984
diff changeset
  2150
              | _ => fold add_undefined_const (var_types ())))
42698
ffd1ae4ff5c6 help SOS by ensuring that typing information is marked as part of the conjecture + be more precise w.r.t. typedefs in monotonicity check
blanchet
parents: 42697
diff changeset
  2151
  end
42533
dc81fe6b7a87 generate TFF type declarations in typed mode
blanchet
parents: 42531
diff changeset
  2152
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2153
(* We add "bool" in case the helper "True_or_False" is included later. *)
44634
2ac4ff398bc3 make "sound" sound and "unsound" more sound, based on evaluation
blanchet
parents: 44626
diff changeset
  2154
fun default_mono level =
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2155
  {maybe_finite_Ts = [@{typ bool}],
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2156
   surely_finite_Ts = [@{typ bool}],
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2157
   maybe_infinite_Ts = known_infinite_types,
44634
2ac4ff398bc3 make "sound" sound and "unsound" more sound, based on evaluation
blanchet
parents: 44626
diff changeset
  2158
   surely_infinite_Ts =
2ac4ff398bc3 make "sound" sound and "unsound" more sound, based on evaluation
blanchet
parents: 44626
diff changeset
  2159
     case level of
46301
e2e52c7d25c9 renamed "sound" option to "strict"
blanchet
parents: 46093
diff changeset
  2160
       Noninf_Nonmono_Types (Strict, _) => []
44634
2ac4ff398bc3 make "sound" sound and "unsound" more sound, based on evaluation
blanchet
parents: 44626
diff changeset
  2161
     | _ => known_infinite_types,
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2162
   maybe_nonmono_Ts = [@{typ bool}]}
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2163
42685
7a5116bd63b7 documentation tuning
blanchet
parents: 42684
diff changeset
  2164
(* This inference is described in section 2.3 of Claessen et al.'s "Sorting it
7a5116bd63b7 documentation tuning
blanchet
parents: 42684
diff changeset
  2165
   out with monotonicity" paper presented at CADE 2011. *)
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2166
fun add_iterm_mononotonicity_info _ _ (SOME false) _ mono = mono
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2167
  | add_iterm_mononotonicity_info ctxt level _
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2168
        (IApp (IApp (IConst ((s, _), Type (_, [T, _]), _), tm1), tm2))
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2169
        (mono as {maybe_finite_Ts, surely_finite_Ts, maybe_infinite_Ts,
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2170
                  surely_infinite_Ts, maybe_nonmono_Ts}) =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2171
    let val thy = Proof_Context.theory_of ctxt in
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2172
      if is_tptp_equal s andalso exists is_maybe_universal_var [tm1, tm2] then
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2173
        case level of
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2174
          Noninf_Nonmono_Types (strictness, _) =>
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2175
          if exists (type_instance thy T) surely_infinite_Ts orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2176
             member (type_equiv thy) maybe_finite_Ts T then
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2177
            mono
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2178
          else if is_type_kind_of_surely_infinite ctxt strictness
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2179
                                                  surely_infinite_Ts T then
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2180
            {maybe_finite_Ts = maybe_finite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2181
             surely_finite_Ts = surely_finite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2182
             maybe_infinite_Ts = maybe_infinite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2183
             surely_infinite_Ts = surely_infinite_Ts |> insert_type thy I T,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2184
             maybe_nonmono_Ts = maybe_nonmono_Ts}
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2185
          else
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2186
            {maybe_finite_Ts = maybe_finite_Ts |> insert (type_equiv thy) T,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2187
             surely_finite_Ts = surely_finite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2188
             maybe_infinite_Ts = maybe_infinite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2189
             surely_infinite_Ts = surely_infinite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2190
             maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type thy I T}
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2191
        | Fin_Nonmono_Types _ =>
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2192
          if exists (type_instance thy T) surely_finite_Ts orelse
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2193
             member (type_equiv thy) maybe_infinite_Ts T then
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2194
            mono
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2195
          else if is_type_surely_finite ctxt T then
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2196
            {maybe_finite_Ts = maybe_finite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2197
             surely_finite_Ts = surely_finite_Ts |> insert_type thy I T,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2198
             maybe_infinite_Ts = maybe_infinite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2199
             surely_infinite_Ts = surely_infinite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2200
             maybe_nonmono_Ts = maybe_nonmono_Ts |> insert_type thy I T}
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2201
          else
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2202
            {maybe_finite_Ts = maybe_finite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2203
             surely_finite_Ts = surely_finite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2204
             maybe_infinite_Ts = maybe_infinite_Ts |> insert (type_equiv thy) T,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2205
             surely_infinite_Ts = surely_infinite_Ts,
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2206
             maybe_nonmono_Ts = maybe_nonmono_Ts}
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2207
        | _ => mono
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2208
      else
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2209
        mono
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2210
    end
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2211
  | add_iterm_mononotonicity_info _ _ _ _ mono = mono
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2212
fun add_fact_mononotonicity_info ctxt level
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2213
        ({kind, iformula, ...} : translated_formula) =
42834
40f7691d0539 implemented thin versions of "preds" type systems + fixed various issues with type args
blanchet
parents: 42832
diff changeset
  2214
  formula_fold (SOME (kind <> Conjecture))
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2215
               (add_iterm_mononotonicity_info ctxt level) iformula
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2216
fun mononotonicity_info_for_facts ctxt type_enc facts =
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  2217
  let val level = level_of_type_enc type_enc in
44634
2ac4ff398bc3 make "sound" sound and "unsound" more sound, based on evaluation
blanchet
parents: 44626
diff changeset
  2218
    default_mono level
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2219
    |> is_type_level_monotonicity_based level
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2220
       ? fold (add_fact_mononotonicity_info ctxt level) facts
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2221
  end
42677
25496cd3c199 monotonic type inference in ATP Sledgehammer problems -- based on Claessen & al.'s CADE 2011 paper, Sect. 2.3.
blanchet
parents: 42675
diff changeset
  2222
44501
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2223
fun add_iformula_monotonic_types ctxt mono type_enc =
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2224
  let
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2225
    val thy = Proof_Context.theory_of ctxt
44501
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2226
    val level = level_of_type_enc type_enc
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2227
    val should_encode = should_encode_type ctxt mono level
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2228
    fun add_type T = not (should_encode T) ? insert_type thy I T
44506
7e3913e70846 improve completeness of polymorphic encodings
blanchet
parents: 44505
diff changeset
  2229
    fun add_args (IApp (tm1, tm2)) = add_args tm1 #> add_term tm2
7e3913e70846 improve completeness of polymorphic encodings
blanchet
parents: 44505
diff changeset
  2230
      | add_args _ = I
7e3913e70846 improve completeness of polymorphic encodings
blanchet
parents: 44505
diff changeset
  2231
    and add_term tm = add_type (ityp_of tm) #> add_args tm
44501
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2232
  in formula_fold NONE (K add_term) end
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2233
fun add_fact_monotonic_types ctxt mono type_enc =
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2234
  add_iformula_monotonic_types ctxt mono type_enc |> fact_lift
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2235
fun monotonic_types_for_facts ctxt mono type_enc facts =
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2236
  let val level = level_of_type_enc type_enc in
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2237
    [] |> (polymorphism_of_type_enc type_enc = Polymorphic andalso
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2238
           is_type_level_monotonicity_based level andalso
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2239
           granularity_of_type_level level <> Ghost_Type_Arg_Vars)
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2240
          ? fold (add_fact_monotonic_types ctxt mono type_enc) facts
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2241
  end
44501
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2242
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2243
fun formula_line_for_guards_mono_type ctxt mono type_enc T =
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2244
  Formula (guards_sym_formula_prefix ^
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2245
           ascii_of (mangled_type type_enc T),
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2246
           Axiom,
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2247
           IConst (`make_bound_var "X", T, [])
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2248
           |> type_guard_iterm type_enc T
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2249
           |> AAtom
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2250
           |> formula_from_iformula ctxt [] mono type_enc
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  2251
                                    always_guard_var_in_formula (SOME true)
45377
blanchet
parents: 45364
diff changeset
  2252
           |> close_formula_universally
45920
ddbe94f7242c ensure TPTP FOF/TFF/THF formulas are close
blanchet
parents: 45875
diff changeset
  2253
           |> bound_tvars type_enc true (atomic_types_of T),
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2254
           NONE, isabelle_info inductiveN helper_rank)
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2255
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2256
fun formula_line_for_tags_mono_type ctxt mono type_enc T =
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2257
  let val x_var = ATerm (`make_bound_var "X", []) in
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2258
    Formula (tags_sym_formula_prefix ^
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2259
             ascii_of (mangled_type type_enc T),
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2260
             Axiom,
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2261
             eq_formula type_enc (atomic_types_of T) [] false
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2262
                  (tag_with_type ctxt mono type_enc NONE T x_var) x_var,
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2263
             NONE, isabelle_info defN helper_rank)
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2264
  end
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2265
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2266
fun problem_lines_for_mono_types ctxt mono type_enc Ts =
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2267
  case type_enc of
47767
blanchet
parents: 47718
diff changeset
  2268
    Native _ => []
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2269
  | Guards _ => map (formula_line_for_guards_mono_type ctxt mono type_enc) Ts
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2270
  | Tags _ => map (formula_line_for_tags_mono_type ctxt mono type_enc) Ts
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2271
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2272
fun decl_line_for_sym ctxt mono type_enc s
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
  2273
                      (s', T_args, T, pred_sym, ary, _) =
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
  2274
  let
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2275
    val thy = Proof_Context.theory_of ctxt
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2276
    val (T, T_args) =
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2277
      if null T_args then
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2278
        (T, [])
45511
9b0f8ca4388e continued implementation of lambda-lifting in Metis
blanchet
parents: 45509
diff changeset
  2279
      else case unprefix_and_unascii const_prefix s of
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2280
        SOME s' =>
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2281
        let
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2282
          val s' = s' |> invert_const
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2283
          val T = s' |> robust_const_type thy
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2284
        in (T, robust_const_typargs thy (s', T)) end
45509
624872fc47bf use consts, not frees, for lambda-lifting
blanchet
parents: 45508
diff changeset
  2285
      | NONE => raise Fail "unexpected type arguments"
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
  2286
  in
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2287
    Decl (sym_decl_prefix ^ s, (s, s'),
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2288
          T |> fused_type ctxt mono (level_of_type_enc type_enc) ary
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2289
            |> ho_type_from_typ type_enc pred_sym ary
44594
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2290
            |> not (null T_args)
ae82943481e9 added type abstractions (for declaring polymorphic constants) to TFF syntax
blanchet
parents: 44593
diff changeset
  2291
               ? curry ATyAbs (map (tvar_name o fst o dest_TVar) T_args))
42994
fe291ab75eb5 towards supporting non-simply-typed encodings for TFF and THF (for orthogonality and experiments)
blanchet
parents: 42966
diff changeset
  2292
  end
42579
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2293
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2294
fun honor_conj_sym_kind in_conj conj_sym_kind =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2295
  if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2296
  else (Axiom, I)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2297
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2298
fun formula_line_for_guards_sym_decl ctxt conj_sym_kind mono type_enc n s j
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2299
                                     (s', T_args, T, _, ary, in_conj) =
42579
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2300
  let
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2301
    val thy = Proof_Context.theory_of ctxt
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2302
    val (kind, maybe_negate) = honor_conj_sym_kind in_conj conj_sym_kind
42753
c9552e617acc drop some type arguments to constants in unsound type systems + remove a few type systems that make no sense from the circulation
blanchet
parents: 42750
diff changeset
  2303
    val (arg_Ts, res_T) = chop_fun ary T
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2304
    val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int)
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2305
    val bounds =
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  2306
      bound_names ~~ arg_Ts |> map (fn (name, T) => IConst (name, T, []))
42579
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2307
    val bound_Ts =
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2308
      if exists (curry (op =) dummyT) T_args then
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2309
        case level_of_type_enc type_enc of
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2310
          All_Types => map SOME arg_Ts
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2311
        | level =>
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2312
          if granularity_of_type_level level = Ghost_Type_Arg_Vars then
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2313
            let val ghosts = ghost_type_args thy s ary in
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2314
              map2 (fn j => if member (op =) ghosts j then SOME else K NONE)
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2315
                   (0 upto ary - 1) arg_Ts
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2316
            end
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2317
          else
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2318
            replicate ary NONE
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2319
      else
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2320
        replicate ary NONE
42579
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2321
  in
43989
eb763b3ff9ed renamed "preds" encodings to "guards"
blanchet
parents: 43987
diff changeset
  2322
    Formula (guards_sym_formula_prefix ^ s ^
42709
e7af132d48fe allow each prover to specify its own formula kind for symbols occurring in the conjecture
blanchet
parents: 42701
diff changeset
  2323
             (if n > 1 then "_" ^ string_of_int j else ""), kind,
43859
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  2324
             IConst ((s, s'), T, T_args)
b7890554c424 renamed internal data structure
blanchet
parents: 43858
diff changeset
  2325
             |> fold (curry (IApp o swap)) bounds
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2326
             |> type_guard_iterm type_enc res_T
42963
5725deb11ae7 identify HOL functions with THF functions
blanchet
parents: 42962
diff changeset
  2327
             |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2328
             |> formula_from_iformula ctxt [] mono type_enc
45948
f88f502d635f extend previous optimizations to guard-based encodings
blanchet
parents: 45947
diff changeset
  2329
                                      always_guard_var_in_formula (SOME true)
45377
blanchet
parents: 45364
diff changeset
  2330
             |> close_formula_universally
45920
ddbe94f7242c ensure TPTP FOF/TFF/THF formulas are close
blanchet
parents: 45875
diff changeset
  2331
             |> bound_tvars type_enc (n > 1) (atomic_types_of T)
42709
e7af132d48fe allow each prover to specify its own formula kind for symbols occurring in the conjecture
blanchet
parents: 42701
diff changeset
  2332
             |> maybe_negate,
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2333
             NONE, isabelle_info inductiveN helper_rank)
42579
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2334
  end
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2335
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2336
fun formula_lines_for_tags_sym_decl ctxt conj_sym_kind mono type_enc n s
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2337
        (j, (s', T_args, T, pred_sym, ary, in_conj)) =
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2338
  let
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2339
    val thy = Proof_Context.theory_of ctxt
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2340
    val level = level_of_type_enc type_enc
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2341
    val grain = granularity_of_type_level level
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2342
    val ident_base =
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2343
      tags_sym_formula_prefix ^ s ^
43125
ddf63baabdec distinguish different kinds of typing informations in the fact name
blanchet
parents: 43121
diff changeset
  2344
      (if n > 1 then "_" ^ string_of_int j else "")
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2345
    val (kind, maybe_negate) = honor_conj_sym_kind in_conj conj_sym_kind
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2346
    val (arg_Ts, res_T) = chop_fun ary T
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2347
    val bound_names = 1 upto ary |> map (`I o make_bound_var o string_of_int)
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2348
    val bounds = bound_names |> map (fn name => ATerm (name, []))
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2349
    val cst = mk_aterm type_enc (s, s') T_args
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2350
    val eq = maybe_negate oo eq_formula type_enc (atomic_types_of T) [] pred_sym
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2351
    val should_encode = should_encode_type ctxt mono level
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2352
    val tag_with = tag_with_type ctxt mono type_enc NONE
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2353
    val add_formula_for_res =
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2354
      if should_encode res_T then
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2355
        let
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2356
          val tagged_bounds =
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2357
            if grain = Ghost_Type_Arg_Vars then
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2358
              let val ghosts = ghost_type_args thy s ary in
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2359
                map2 (fn (j, arg_T) => member (op =) ghosts j ? tag_with arg_T)
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2360
                     (0 upto ary - 1 ~~ arg_Ts) bounds
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2361
              end
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2362
            else
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2363
              bounds
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2364
        in
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2365
          cons (Formula (ident_base ^ "_res", kind,
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2366
                         eq (tag_with res_T (cst bounds)) (cst tagged_bounds),
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2367
                         NONE, isabelle_info defN helper_rank))
44814
52318464c73b also implemented ghost version of the tagged encodings
blanchet
parents: 44812
diff changeset
  2368
        end
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2369
      else
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2370
        I
47046
62ca06cc5a99 remove two options that were found to play hardly any role
blanchet
parents: 47039
diff changeset
  2371
  in [] |> not pred_sym ? add_formula_for_res end
42829
1558741f8a72 started implementing "shallow" type systems, based on ideas by Claessen et al.
blanchet
parents: 42828
diff changeset
  2372
42836
9adf6b3965b3 code cleanup, better handling of corner cases
blanchet
parents: 42834
diff changeset
  2373
fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
9adf6b3965b3 code cleanup, better handling of corner cases
blanchet
parents: 42834
diff changeset
  2374
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2375
fun rationalize_decls thy (decls as decl :: (decls' as _ :: _)) =
45780
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2376
    let
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2377
      val T = result_type_of_decl decl
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2378
              |> map_type_tvar (fn (z, _) => TVar (z, HOLogic.typeS))
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2379
    in
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2380
      if forall (type_generalization thy T o result_type_of_decl) decls' then
45780
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2381
        [decl]
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2382
      else
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2383
        decls
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2384
    end
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2385
  | rationalize_decls _ decls = decls
cef82dc1462d avoid multiple TFF1 declarations
blanchet
parents: 45779
diff changeset
  2386
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2387
fun problem_lines_for_sym_decls ctxt conj_sym_kind mono type_enc (s, decls) =
43626
a867ebb12209 renamed "type_sys" to "type_enc", which is more accurate
blanchet
parents: 43624
diff changeset
  2388
  case type_enc of
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2389
    Native _ => [decl_line_for_sym ctxt mono type_enc s (hd decls)]
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2390
  | Guards (_, level) =>
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2391
    let
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2392
      val thy = Proof_Context.theory_of ctxt
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2393
      val decls = decls |> rationalize_decls thy
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2394
      val n = length decls
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2395
      val decls =
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2396
        decls |> filter (should_encode_type ctxt mono level
43401
e93dfcb53535 fixed soundness bug made more visible by previous change
blanchet
parents: 43399
diff changeset
  2397
                         o result_type_of_decl)
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2398
    in
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2399
      (0 upto length decls - 1, decls)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2400
      |-> map2 (formula_line_for_guards_sym_decl ctxt conj_sym_kind mono
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2401
                                                 type_enc n s)
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2402
    end
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2403
  | Tags (_, level) =>
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2404
    if granularity_of_type_level level = All_Vars then
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2405
      []
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2406
    else
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2407
      let val n = length decls in
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2408
        (0 upto n - 1 ~~ decls)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2409
        |> maps (formula_lines_for_tags_sym_decl ctxt conj_sym_kind mono
44811
0bff1a4228b3 started work on ghost type arg encoding
blanchet
parents: 44810
diff changeset
  2410
                                                 type_enc n s)
44768
a7bc1bdb8bb4 rationalize uniform encodings
blanchet
parents: 44754
diff changeset
  2411
      end
42579
2552c09b1a72 implement the new ATP type system in Sledgehammer
blanchet
parents: 42577
diff changeset
  2412
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2413
fun problem_lines_for_sym_decl_table ctxt conj_sym_kind mono type_enc mono_Ts
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2414
                                     sym_decl_tab =
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2415
  let
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2416
    val syms = sym_decl_tab |> Symtab.dest |> sort_wrt fst
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2417
    val mono_lines = problem_lines_for_mono_types ctxt mono type_enc mono_Ts
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2418
    val decl_lines =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2419
      fold_rev (append o problem_lines_for_sym_decls ctxt conj_sym_kind mono
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2420
                             type_enc)
44396
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2421
               syms []
66b9b3fcd608 started cleaning up polymorphic monotonicity-based encodings, based on discussions with Nick Smallbone
blanchet
parents: 44394
diff changeset
  2422
  in mono_lines @ decl_lines end
42543
f9d402d144d4 declare TFF types so that SNARK can be used with types
blanchet
parents: 42542
diff changeset
  2423
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2424
fun pair_append (xs1, xs2) (ys1, ys2) = (xs1 @ ys1, xs2 @ ys2)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2425
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2426
fun do_uncurried_alias_lines_for_sym ctxt monom_constrs conj_sym_kind mono
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2427
        type_enc sym_tab0 sym_tab base_s0 types in_conj =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2428
  let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2429
    fun do_alias ary =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2430
      let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2431
        val thy = Proof_Context.theory_of ctxt
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2432
        val (kind, maybe_negate) = honor_conj_sym_kind in_conj conj_sym_kind
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2433
        val base_name = base_s0 |> `(make_fixed_const (SOME type_enc))
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2434
        val T = case types of [T] => T | _ => robust_const_type thy base_s0
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2435
        val T_args = robust_const_typargs thy (base_s0, T)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2436
        val (base_name as (base_s, _), T_args) =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2437
          mangle_type_args_in_const type_enc base_name T_args
46402
ef8d65f64f77 change 9ce354a77908 wasn't quite right -- here's an improvement
blanchet
parents: 46400
diff changeset
  2438
        val base_ary = min_ary_of sym_tab0 base_s
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2439
        fun do_const name = IConst (name, T, T_args)
46437
9552b6f2c670 fixed arity error
blanchet
parents: 46435
diff changeset
  2440
        val filter_ty_args =
46410
78ff6a886b50 made sure to filter type args also for "uncurried alias" equations
blanchet
parents: 46409
diff changeset
  2441
          filter_type_args_in_iterm thy monom_constrs type_enc
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2442
        val ho_term_of = ho_term_from_iterm ctxt mono type_enc (SOME true)
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2443
        val name1 as (s1, _) =
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2444
          base_name |> ary - 1 > base_ary ? aliased_uncurried (ary - 1)
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2445
        val name2 as (s2, _) = base_name |> aliased_uncurried ary
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2446
        val (arg_Ts, _) = chop_fun ary T
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2447
        val bound_names =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2448
          1 upto ary |> map (`I o make_bound_var o string_of_int)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2449
        val bounds = bound_names ~~ arg_Ts
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2450
        val (first_bounds, last_bound) =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2451
          bounds |> map (fn (name, T) => IConst (name, T, [])) |> split_last
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2452
        val tm1 =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2453
          mk_app_op type_enc (list_app (do_const name1) first_bounds) last_bound
46437
9552b6f2c670 fixed arity error
blanchet
parents: 46435
diff changeset
  2454
          |> filter_ty_args
9552b6f2c670 fixed arity error
blanchet
parents: 46435
diff changeset
  2455
        val tm2 =
9552b6f2c670 fixed arity error
blanchet
parents: 46435
diff changeset
  2456
          list_app (do_const name2) (first_bounds @ [last_bound])
9552b6f2c670 fixed arity error
blanchet
parents: 46435
diff changeset
  2457
          |> filter_ty_args
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2458
        val do_bound_type = do_bound_type ctxt mono type_enc
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2459
        val eq =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2460
          eq_formula type_enc (atomic_types_of T)
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2461
                     (map (apsnd do_bound_type) bounds) false
46437
9552b6f2c670 fixed arity error
blanchet
parents: 46435
diff changeset
  2462
                     (ho_term_of tm1) (ho_term_of tm2)
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2463
      in
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2464
        ([tm1, tm2],
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2465
         [Formula (uncurried_alias_eq_prefix ^ s2, kind, eq |> maybe_negate,
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2466
                   NONE, isabelle_info defN helper_rank)])
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2467
        |> (if ary - 1 = base_ary orelse Symtab.defined sym_tab s1 then I
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2468
            else pair_append (do_alias (ary - 1)))
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2469
      end
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2470
  in do_alias end
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2471
fun uncurried_alias_lines_for_sym ctxt monom_constrs conj_sym_kind mono type_enc
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2472
        sym_tab0 sym_tab (s, {min_ary, types, in_conj, ...} : sym_info) =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2473
  case unprefix_and_unascii const_prefix s of
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2474
    SOME mangled_s =>
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2475
    if String.isSubstring uncurried_alias_sep mangled_s then
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2476
      let
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2477
        val base_s0 = mangled_s |> unmangled_const_name |> hd |> invert_const
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2478
      in
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2479
        do_uncurried_alias_lines_for_sym ctxt monom_constrs conj_sym_kind mono
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2480
            type_enc sym_tab0 sym_tab base_s0 types in_conj min_ary
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2481
      end
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2482
    else
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2483
      ([], [])
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2484
  | NONE => ([], [])
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2485
fun uncurried_alias_lines_for_sym_table ctxt monom_constrs conj_sym_kind mono
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2486
        type_enc uncurried_aliases sym_tab0 sym_tab =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2487
  ([], [])
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2488
  |> uncurried_aliases
46402
ef8d65f64f77 change 9ce354a77908 wasn't quite right -- here's an improvement
blanchet
parents: 46400
diff changeset
  2489
     ? Symtab.fold_rev
ef8d65f64f77 change 9ce354a77908 wasn't quite right -- here's an improvement
blanchet
parents: 46400
diff changeset
  2490
           (pair_append
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2491
            o uncurried_alias_lines_for_sym ctxt monom_constrs conj_sym_kind
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2492
                  mono type_enc sym_tab0 sym_tab) sym_tab
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2493
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2494
val implicit_declsN = "Should-be-implicit typings"
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2495
val explicit_declsN = "Explicit typings"
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2496
val uncurried_alias_eqsN = "Uncurried aliases"
41157
blanchet
parents: 41150
diff changeset
  2497
val factsN = "Relevant facts"
blanchet
parents: 41150
diff changeset
  2498
val class_relsN = "Class relationships"
42543
f9d402d144d4 declare TFF types so that SNARK can be used with types
blanchet
parents: 42542
diff changeset
  2499
val aritiesN = "Arities"
41157
blanchet
parents: 41150
diff changeset
  2500
val helpersN = "Helper facts"
blanchet
parents: 41150
diff changeset
  2501
val conjsN = "Conjectures"
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2502
val free_typesN = "Type variables"
41157
blanchet
parents: 41150
diff changeset
  2503
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2504
(* TFF allows implicit declarations of types, function symbols, and predicate
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2505
   symbols (with "$i" as the type of individuals), but some provers (e.g.,
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2506
   SNARK) require explicit declarations. The situation is similar for THF. *)
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2507
45875
6d3533fd26ea make sure that all symbols are declared in untyped SPASS DFG output (broken since 3b8606fba2dd)
blanchet
parents: 45831
diff changeset
  2508
fun default_type type_enc pred_sym s =
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2509
  let
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2510
    val ind =
45875
6d3533fd26ea make sure that all symbols are declared in untyped SPASS DFG output (broken since 3b8606fba2dd)
blanchet
parents: 45831
diff changeset
  2511
      case type_enc of
47767
blanchet
parents: 47718
diff changeset
  2512
        Native _ =>
47145
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2513
        if String.isPrefix type_const_prefix s orelse
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2514
           String.isPrefix tfree_prefix s then
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2515
          atype_of_types
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2516
        else
ffc6d6267a88 TFF: declare free types as types
blanchet
parents: 47073
diff changeset
  2517
          individual_atype
45875
6d3533fd26ea make sure that all symbols are declared in untyped SPASS DFG output (broken since 3b8606fba2dd)
blanchet
parents: 45831
diff changeset
  2518
      | _ => individual_atype
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2519
    fun typ 0 = if pred_sym then bool_atype else ind
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2520
      | typ ary = AFun (ind, typ (ary - 1))
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2521
  in typ end
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2522
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2523
fun nary_type_constr_type n =
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2524
  funpow n (curry AFun atype_of_types) atype_of_types
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2525
45875
6d3533fd26ea make sure that all symbols are declared in untyped SPASS DFG output (broken since 3b8606fba2dd)
blanchet
parents: 45831
diff changeset
  2526
fun undeclared_syms_in_problem type_enc problem =
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2527
  let
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2528
    fun do_sym (name as (s, _)) ty =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2529
      if is_tptp_user_symbol s then
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2530
        Symtab.default (s, (name, ty))
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2531
      else
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2532
        I
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2533
    fun do_type (AType (name, tys)) =
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2534
        do_sym name (fn () => nary_type_constr_type (length tys))
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2535
        #> fold do_type tys
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2536
      | do_type (AFun (ty1, ty2)) = do_type ty1 #> do_type ty2
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2537
      | do_type (ATyAbs (_, ty)) = do_type ty
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2538
    fun do_term pred_sym (ATerm (name as (s, _), tms)) =
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2539
        do_sym name (fn _ => default_type type_enc pred_sym s (length tms))
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2540
        #> fold (do_term false) tms
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2541
      | do_term _ (AAbs ((_, ty), tm)) = do_type ty #> do_term false tm
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2542
    fun do_formula (AQuant (_, xs, phi)) =
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2543
        fold do_type (map_filter snd xs) #> do_formula phi
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2544
      | do_formula (AConn (_, phis)) = fold do_formula phis
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2545
      | do_formula (AAtom tm) = do_term true tm
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2546
    fun do_problem_line (Decl (_, _, ty)) = do_type ty
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2547
      | do_problem_line (Formula (_, _, phi, _, _)) = do_formula phi
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2548
  in
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2549
    Symtab.empty
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2550
    |> fold (fn (s, _) => Symtab.default (s, (("", ""), K tvar_a_atype)))
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2551
            (declared_syms_in_problem problem)
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2552
    |> fold (fold do_problem_line o snd) problem
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2553
  end
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2554
45875
6d3533fd26ea make sure that all symbols are declared in untyped SPASS DFG output (broken since 3b8606fba2dd)
blanchet
parents: 45831
diff changeset
  2555
fun declare_undeclared_syms_in_atp_problem type_enc problem =
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2556
  let
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2557
    val decls =
47150
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2558
      Symtab.fold (fn (_, (("", ""), _)) => I (* already declared *)
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2559
                    | (s, (sym, ty)) =>
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2560
                      cons (Decl (type_decl_prefix ^ s, sym, ty ())))
6df6e56fd7cd tuning (in particular, Symtab instead of AList)
blanchet
parents: 47148
diff changeset
  2561
                  (undeclared_syms_in_problem type_enc problem) []
45828
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2562
  in (implicit_declsN, decls) :: problem end
3b8606fba2dd correctly declare implicit TFF1 types that appear first as type arguments with "$tType" and not "$i
blanchet
parents: 45780
diff changeset
  2563
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2564
fun exists_subdtype P =
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2565
  let
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2566
    fun ex U = P U orelse
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2567
      (case U of Datatype.DtType (_, Us) => exists ex Us | _ => false)
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2568
  in ex end
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2569
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2570
fun is_poly_constr (_, Us) =
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2571
  exists (exists_subdtype (fn Datatype.DtTFree _ => true | _ => false)) Us
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2572
45947
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  2573
fun all_constrs_of_polymorphic_datatypes thy =
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2574
  Symtab.fold (snd
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2575
               #> #descr
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2576
               #> maps (snd #> #3)
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2577
               #> (fn cs => exists is_poly_constr cs ? append cs))
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2578
              (Datatype.get_all thy) []
45947
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  2579
  |> List.partition is_poly_constr
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  2580
  |> pairself (map fst)
45945
aa8100cc02dc no need for type arguments for monomorphic constructors of polymorphic datatypes (e.g. "Nil")
blanchet
parents: 45939
diff changeset
  2581
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2582
val app_op_and_predicator_threshold = 50
43259
30c141dc22d6 killed "explicit_apply" option in Sledgehammer -- the "smart" default is about as lightweight as "false" and just as complete as "true"
blanchet
parents: 43258
diff changeset
  2583
44397
06375952f1fa cleaner handling of polymorphic monotonicity inference
blanchet
parents: 44396
diff changeset
  2584
fun prepare_atp_problem ctxt format conj_sym_kind prem_kind type_enc exporter
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2585
                        lam_trans uncurried_aliases readable_names preproc
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2586
                        hyp_ts concl_t facts =
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2587
  let
44774
72785558a6ff separate mangling, which can (and should) be done before the formulas are first-orderized, and type arg filtering, which must be done after once the min arities have been computed
blanchet
parents: 44773
diff changeset
  2588
    val thy = Proof_Context.theory_of ctxt
44416
cabd06b69c18 added formats to the slice and use TFF for remote Vampire
blanchet
parents: 44410
diff changeset
  2589
    val type_enc = type_enc |> adjust_type_enc format
46389
blanchet
parents: 46385
diff changeset
  2590
    (* Forcing explicit applications is expensive for polymorphic encodings,
blanchet
parents: 46385
diff changeset
  2591
       because it takes only one existential variable ranging over "'a => 'b" to
blanchet
parents: 46385
diff changeset
  2592
       ruin everything. Hence we do it only if there are few facts (which is
blanchet
parents: 46385
diff changeset
  2593
       normally the case for "metis" and the minimizer). *)
46392
676a4b4b6e73 implemented partial application aliases (for SPASS mainly)
blanchet
parents: 46389
diff changeset
  2594
    val app_op_level =
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2595
      if length facts > app_op_and_predicator_threshold then
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2596
        if polymorphism_of_type_enc type_enc = Polymorphic then
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2597
          Min_App_Op
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2598
        else
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2599
          Sufficient_App_Op
46370
b3e53dd6f10a new SPASS setup
blanchet
parents: 46368
diff changeset
  2600
      else
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2601
        Sufficient_App_Op_And_Predicator
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  2602
    val lam_trans =
45520
2b1dde0b1c30 thread in additional options to minimizer
blanchet
parents: 45519
diff changeset
  2603
      if lam_trans = keep_lamsN andalso
2b1dde0b1c30 thread in additional options to minimizer
blanchet
parents: 45519
diff changeset
  2604
         not (is_type_enc_higher_order type_enc) then
45519
cd6e78cb6ee8 make metis reconstruction handling more flexible
blanchet
parents: 45516
diff changeset
  2605
        error ("Lambda translation scheme incompatible with first-order \
44088
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
  2606
               \encoding.")
3693baa6befb move lambda-lifting code to ATP encoding, so it can be used by Metis
blanchet
parents: 44003
diff changeset
  2607
      else
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  2608
        lam_trans
45508
b216dc1b3630 started implementing lambda-lifting in Metis
blanchet
parents: 45401
diff changeset
  2609
    val (fact_names, classes, conjs, facts, class_rel_clauses, arity_clauses,
b216dc1b3630 started implementing lambda-lifting in Metis
blanchet
parents: 45401
diff changeset
  2610
         lifted) =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2611
      translate_formulas ctxt prem_kind format type_enc lam_trans preproc hyp_ts
45514
973bb7846505 parse lambda translation option in Metis
blanchet
parents: 45513
diff changeset
  2612
                         concl_t facts
46402
ef8d65f64f77 change 9ce354a77908 wasn't quite right -- here's an improvement
blanchet
parents: 46400
diff changeset
  2613
    val sym_tab0 = sym_table_for_facts ctxt type_enc app_op_level conjs facts
44399
cd1e32b8d4c4 added caching for (in)finiteness checks
blanchet
parents: 44398
diff changeset
  2614
    val mono = conjs @ facts |> mononotonicity_info_for_facts ctxt type_enc
45947
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  2615
    val (polym_constrs, monom_constrs) =
7eccf8147f57 treat polymorphic constructors specially in @? encodings
blanchet
parents: 45946
diff changeset
  2616
      all_constrs_of_polymorphic_datatypes thy
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2617
      |>> map (make_fixed_const (SOME type_enc))
46400
9ce354a77908 don't introduce new symbols in helpers -- makes problems unprovable
blanchet
parents: 46399
diff changeset
  2618
    fun firstorderize in_helper =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2619
      firstorderize_fact thy monom_constrs type_enc sym_tab0
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2620
                         (uncurried_aliases andalso not in_helper)
46400
9ce354a77908 don't introduce new symbols in helpers -- makes problems unprovable
blanchet
parents: 46399
diff changeset
  2621
    val (conjs, facts) = (conjs, facts) |> pairself (map (firstorderize false))
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2622
    val sym_tab = sym_table_for_facts ctxt type_enc Min_App_Op conjs facts
42573
744215c3e90c got rid of one "sym_table" in "prepare_atp_problem" now that proxies are always handled first, and tuned accordingly
blanchet
parents: 42572
diff changeset
  2623
    val helpers =
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  2624
      sym_tab |> helper_facts_for_sym_table ctxt format type_enc
46400
9ce354a77908 don't introduce new symbols in helpers -- makes problems unprovable
blanchet
parents: 46399
diff changeset
  2625
              |> map (firstorderize true)
44501
5bde887b4785 make polymorphic encodings more complete
blanchet
parents: 44500
diff changeset
  2626
    val mono_Ts =
45937
blanchet
parents: 45920
diff changeset
  2627
      helpers @ conjs @ facts |> monotonic_types_for_facts ctxt mono type_enc
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2628
    val class_decl_lines = decl_lines_for_classes type_enc classes
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2629
    val (uncurried_alias_eq_tms, uncurried_alias_eq_lines) =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2630
      uncurried_alias_lines_for_sym_table ctxt monom_constrs conj_sym_kind mono
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2631
          type_enc uncurried_aliases sym_tab0 sym_tab
42680
b6c27cf04fe9 exploit inferred monotonicity
blanchet
parents: 42677
diff changeset
  2632
    val sym_decl_lines =
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2633
      (conjs, helpers @ facts, uncurried_alias_eq_tms)
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2634
      |> sym_decl_table_for_facts thy type_enc sym_tab
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2635
      |> problem_lines_for_sym_decl_table ctxt conj_sym_kind mono type_enc
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2636
                                          mono_Ts
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2637
    val num_facts = length facts
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2638
    val fact_lines =
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2639
      map (formula_line_for_fact ctxt polym_constrs fact_prefix
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2640
               ascii_of (not exporter) (not exporter) mono type_enc
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2641
               (rank_of_fact_num num_facts))
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2642
          (0 upto num_facts - 1 ~~ facts)
42881
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
  2643
    val helper_lines =
42956
9aeb0f6ad971 filter Waldmeister facts better -- and don't encode type classes as predicates, since it doesn't like conditional equations
blanchet
parents: 42951
diff changeset
  2644
      0 upto length helpers - 1 ~~ helpers
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2645
      |> map (formula_line_for_fact ctxt polym_constrs helper_prefix I false
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2646
                                    true mono type_enc (K default_rank))
42522
413b56894f82 close ATP formulas universally earlier, so that we can add type predicates
blanchet
parents: 42521
diff changeset
  2647
    (* Reordering these might confuse the proof reconstruction code or the SPASS
43039
b967219cec78 tuned comments
blanchet
parents: 43017
diff changeset
  2648
       FLOTTER hack. *)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2649
    val problem =
44595
444d111bde7d generate properly typed TFF1 (PFF) problems in the presence of type class predicates
blanchet
parents: 44594
diff changeset
  2650
      [(explicit_declsN, class_decl_lines @ sym_decl_lines),
46409
d4754183ccce made option available to users (mostly for experiments)
blanchet
parents: 46406
diff changeset
  2651
       (uncurried_alias_eqsN, uncurried_alias_eq_lines),
46406
0e490b9e8422 extended SPASS/DFG output with ranks
blanchet
parents: 46402
diff changeset
  2652
       (factsN, fact_lines),
44593
ccf40af26ae9 implement more of the polymorphic simply typed format TFF(1)
blanchet
parents: 44591
diff changeset
  2653
       (class_relsN,
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2654
        map (formula_line_for_class_rel_clause type_enc) class_rel_clauses),
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2655
       (aritiesN, map (formula_line_for_arity_clause type_enc) arity_clauses),
42881
dbdfe2d5b6ab automatically use "metisFT" when typed helpers are necessary
blanchet
parents: 42879
diff changeset
  2656
       (helpersN, helper_lines),
46643
a88bccd2b567 added support for Alt-Ergo through Why3 (mostly for experimental purposes, e.g. polymorphism vs. monomorphization)
blanchet
parents: 46642
diff changeset
  2657
       (free_typesN, formula_lines_for_free_types type_enc (facts @ conjs)),
42962
3b50fdeb6cfc started adding support for THF output (but no lambdas)
blanchet
parents: 42956
diff changeset
  2658
       (conjsN,
47768
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2659
        map (formula_line_for_conjecture ctxt polym_constrs mono type_enc)
0b2b7ff31867 don't use the native choice operator if the type encoding isn't higher-order
blanchet
parents: 47767
diff changeset
  2660
                                         conjs)]
42543
f9d402d144d4 declare TFF types so that SNARK can be used with types
blanchet
parents: 42542
diff changeset
  2661
    val problem =
42561
23ddc4e3d19c have properly type-instantiated helper facts (combinators and If)
blanchet
parents: 42560
diff changeset
  2662
      problem
43092
93ec303e1917 more work on new metis that exploits the powerful new type encodings
blanchet
parents: 43086
diff changeset
  2663
      |> (case format of
93ec303e1917 more work on new metis that exploits the powerful new type encodings
blanchet
parents: 43086
diff changeset
  2664
            CNF => ensure_cnf_problem
93ec303e1917 more work on new metis that exploits the powerful new type encodings
blanchet
parents: 43086
diff changeset
  2665
          | CNF_UEQ => filter_cnf_ueq_problem
44589
0a1dfc6365e9 first step towards polymorphic TFF + changed defaults for Vampire
blanchet
parents: 44587
diff changeset
  2666
          | FOF => I
44754
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
  2667
          | TFF (_, TPTP_Implicit) => I
265174356212 added dummy polymorphic THF system
blanchet
parents: 44742
diff changeset
  2668
          | THF (_, TPTP_Implicit, _) => I
45875
6d3533fd26ea make sure that all symbols are declared in untyped SPASS DFG output (broken since 3b8606fba2dd)
blanchet
parents: 45831
diff changeset
  2669
          | _ => declare_undeclared_syms_in_atp_problem type_enc)
45939
711fec5b4f61 don't try to avoid SPASS keywords; instead, just suffix an underscore to all generated identifiers
blanchet
parents: 45937
diff changeset
  2670
    val (problem, pool) = problem |> nice_atp_problem readable_names format
44772
blanchet
parents: 44771
diff changeset
  2671
    fun add_sym_ary (s, {min_ary, ...} : sym_info) =
44773
e701dabbfe37 perform mangling before computing symbol arity, to avoid needless "hAPP"s and "hBOOL"s
blanchet
parents: 44772
diff changeset
  2672
      min_ary > 0 ? Symtab.insert (op =) (s, min_ary)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2673
  in
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2674
    (problem,
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2675
     case pool of SOME the_pool => snd the_pool | NONE => Symtab.empty,
42755
4603154a3018 robustly detect how many type args were passed to the ATP, even if some of them were omitted
blanchet
parents: 42754
diff changeset
  2676
     fact_names |> Vector.fromList,
45508
b216dc1b3630 started implementing lambda-lifting in Metis
blanchet
parents: 45401
diff changeset
  2677
     lifted,
44772
blanchet
parents: 44771
diff changeset
  2678
     Symtab.empty |> Symtab.fold add_sym_ary sym_tab)
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2679
  end
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2680
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2681
(* FUDGE *)
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2682
val conj_weight = 0.0
41770
a710e96583d5 adjust fudge factors
blanchet
parents: 41769
diff changeset
  2683
val hyp_weight = 0.1
a710e96583d5 adjust fudge factors
blanchet
parents: 41769
diff changeset
  2684
val fact_min_weight = 0.2
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2685
val fact_max_weight = 1.0
42608
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2686
val type_info_default_weight = 0.8
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2687
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2688
(* Weights are from 0.0 (most important) to 1.0 (least important). *)
47030
7e80e14247fc internal renamings
blanchet
parents: 46818
diff changeset
  2689
fun atp_problem_selection_weights problem =
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2690
  let
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2691
    fun add_term_weights weight (ATerm (s, tms)) =
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2692
        is_tptp_user_symbol s ? Symtab.default (s, weight)
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2693
        #> fold (add_term_weights weight) tms
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2694
      | add_term_weights weight (AAbs (_, tm)) = add_term_weights weight tm
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2695
    fun add_line_weights weight (Formula (_, _, phi, _, _)) =
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2696
        formula_fold NONE (K (add_term_weights weight)) phi
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2697
      | add_line_weights _ _ = I
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2698
    fun add_conjectures_weights [] = I
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2699
      | add_conjectures_weights conjs =
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2700
        let val (hyps, conj) = split_last conjs in
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2701
          add_line_weights conj_weight conj
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2702
          #> fold (add_line_weights hyp_weight) hyps
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2703
        end
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2704
    fun add_facts_weights facts =
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2705
      let
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2706
        val num_facts = length facts
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2707
        fun weight_of j =
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2708
          fact_min_weight + (fact_max_weight - fact_min_weight) * Real.fromInt j
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2709
                            / Real.fromInt num_facts
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2710
      in
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2711
        map weight_of (0 upto num_facts - 1) ~~ facts
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2712
        |> fold (uncurry add_line_weights)
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2713
      end
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2714
    val get = these o AList.lookup (op =) problem
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2715
  in
42608
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2716
    Symtab.empty
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2717
    |> add_conjectures_weights (get free_typesN @ get conjsN)
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2718
    |> add_facts_weights (get factsN)
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2719
    |> fold (fold (add_line_weights type_info_default_weight) o get)
42998
1c80902d0456 fully support all type system encodings in typed formats (TFF, THF)
blanchet
parents: 42994
diff changeset
  2720
            [explicit_declsN, class_relsN, aritiesN]
42608
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2721
    |> Symtab.dest
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2722
    |> sort (prod_ord Real.compare string_ord o pairself swap)
6ef61823b63b make sure E type information constants are given a weight, even if they don't appear anywhere else
blanchet
parents: 42592
diff changeset
  2723
  end
41313
a96ac4d180b7 optionally supply constant weights to E -- turned off by default until properly parameterized
blanchet
parents: 41211
diff changeset
  2724
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2725
(* Ugly hack: may make innocent victims (collateral damage) *)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2726
fun may_be_app s args = String.isPrefix app_op_name s andalso length args = 2
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2727
fun may_be_predicator s =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2728
  member (op =) [predicator_name, prefixed_predicator_name] s
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2729
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2730
fun strip_predicator (tm as ATerm (s, [tm'])) =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2731
    if may_be_predicator s then tm' else tm
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2732
  | strip_predicator tm = tm
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2733
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2734
fun make_head_roll (ATerm (s, tms)) =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2735
    if may_be_app s tms then make_head_roll (hd tms) ||> append (tl tms)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2736
    else (s, tms)
47032
73cdeed236c0 more weight attribute tuning
blanchet
parents: 47030
diff changeset
  2737
  | make_head_roll _ = ("", [])
46443
c86276014571 improved KBO weights -- beware of explicit applications
blanchet
parents: 46442
diff changeset
  2738
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2739
fun strip_up_to_predicator (AQuant (_, _, phi)) = strip_up_to_predicator phi
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2740
  | strip_up_to_predicator (AConn (_, phis)) = maps strip_up_to_predicator phis
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2741
  | strip_up_to_predicator (AAtom tm) = [strip_predicator tm]
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2742
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2743
fun strip_ahorn_etc (AQuant (_, _, phi)) = strip_ahorn_etc phi
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2744
  | strip_ahorn_etc (AConn (AImplies, [phi1, phi2])) =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2745
    strip_ahorn_etc phi2 |>> append (strip_up_to_predicator phi1)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2746
  | strip_ahorn_etc phi = ([], hd (strip_up_to_predicator phi))
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2747
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2748
fun strip_iff_etc (AQuant (_, _, phi)) = strip_iff_etc phi
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2749
  | strip_iff_etc (AConn (AIff, [phi1, phi2])) =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2750
    pairself strip_up_to_predicator (phi1, phi2)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2751
  | strip_iff_etc _ = ([], [])
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2752
47030
7e80e14247fc internal renamings
blanchet
parents: 46818
diff changeset
  2753
val max_term_order_weight = 2147483647
46450
7560930b2e06 be more gentle when generating KBO weights
blanchet
parents: 46446
diff changeset
  2754
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2755
fun atp_problem_term_order_info problem =
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2756
  let
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2757
    fun add_edge s s' =
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2758
      Graph.default_node (s, ())
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2759
      #> Graph.default_node (s', ())
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2760
      #> Graph.add_edge_acyclic (s, s')
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2761
    fun add_term_deps head (ATerm (s, args)) =
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2762
        if is_tptp_user_symbol head then
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2763
          (if is_tptp_user_symbol s then perhaps (try (add_edge s head)) else I)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2764
          #> fold (add_term_deps head) args
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2765
        else
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2766
          I
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2767
      | add_term_deps head (AAbs (_, tm)) = add_term_deps head tm
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2768
    fun add_intro_deps pred (Formula (_, role, phi, _, info)) =
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2769
        if pred (role, info) then
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2770
          let val (hyps, concl) = strip_ahorn_etc phi in
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2771
            case make_head_roll concl of
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2772
              (head, args as _ :: _) => fold (add_term_deps head) (hyps @ args)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2773
            | _ => I
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2774
          end
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2775
        else
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2776
          I
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2777
      | add_intro_deps _ _ = I
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2778
    fun add_atom_eq_deps (SOME true) (ATerm (s, [lhs as _, rhs])) =
46443
c86276014571 improved KBO weights -- beware of explicit applications
blanchet
parents: 46442
diff changeset
  2779
        if is_tptp_equal s then
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2780
          case make_head_roll lhs of
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2781
            (head, args as _ :: _) => fold (add_term_deps head) (rhs :: args)
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2782
          | _ => I
46443
c86276014571 improved KBO weights -- beware of explicit applications
blanchet
parents: 46442
diff changeset
  2783
        else
c86276014571 improved KBO weights -- beware of explicit applications
blanchet
parents: 46442
diff changeset
  2784
          I
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2785
      | add_atom_eq_deps _ _ = I
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2786
    fun add_eq_deps pred (Formula (_, role, phi, _, info)) =
47039
1b36a05a070d added "metis_advisory_simp" option to orient as many equations as possible in Metis the right way (cf. "More SPASS with Isabelle")
blanchet
parents: 47038
diff changeset
  2787
        if pred (role, info) then
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2788
          case strip_iff_etc phi of
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2789
            ([lhs], rhs) =>
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2790
            (case make_head_roll lhs of
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2791
               (head, args as _ :: _) => fold (add_term_deps head) (rhs @ args)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2792
             | _ => I)
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2793
          | _ => formula_fold (SOME (role <> Conjecture)) add_atom_eq_deps phi
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2794
        else
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2795
          I
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2796
      | add_eq_deps _ _ = I
47039
1b36a05a070d added "metis_advisory_simp" option to orient as many equations as possible in Metis the right way (cf. "More SPASS with Isabelle")
blanchet
parents: 47038
diff changeset
  2797
    fun has_status status (_, info) =
1b36a05a070d added "metis_advisory_simp" option to orient as many equations as possible in Metis the right way (cf. "More SPASS with Isabelle")
blanchet
parents: 47038
diff changeset
  2798
      extract_isabelle_status info = SOME status
1b36a05a070d added "metis_advisory_simp" option to orient as many equations as possible in Metis the right way (cf. "More SPASS with Isabelle")
blanchet
parents: 47038
diff changeset
  2799
    fun is_conj (role, _) = (role = Conjecture orelse role = Hypothesis)
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2800
    val graph =
47039
1b36a05a070d added "metis_advisory_simp" option to orient as many equations as possible in Metis the right way (cf. "More SPASS with Isabelle")
blanchet
parents: 47038
diff changeset
  2801
      Graph.empty
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2802
      |> fold (fold (add_eq_deps (has_status defN)) o snd) problem
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2803
      |> fold (fold (add_eq_deps (has_status simpN orf is_conj)) o snd) problem
47148
7b5846065c1b be less forceful about ":lt" to make infinite loops less likely (could still fail with mutually recursive tail rec functions)
blanchet
parents: 47145
diff changeset
  2804
      |> fold (fold (add_intro_deps (has_status inductiveN)) o snd) problem
47073
c73f7b0c7ebc generate weights and precedences for predicates as well
blanchet
parents: 47046
diff changeset
  2805
      |> fold (fold (add_intro_deps (has_status introN)) o snd) problem
47030
7e80e14247fc internal renamings
blanchet
parents: 46818
diff changeset
  2806
    fun next_weight w = if w + w <= max_term_order_weight then w + w else w + 1
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2807
    fun add_weights _ [] = I
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2808
      | add_weights weight syms =
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2809
        fold (AList.update (op =) o rpair weight) syms
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2810
        #> add_weights (next_weight weight)
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2811
               (fold (union (op =) o Graph.immediate_succs graph) syms [])
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2812
  in
47038
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2813
    (* Sorting is not just for aesthetics: It specifies the precedence order
2409b484e1cc continued implementation of term ordering attributes
blanchet
parents: 47032
diff changeset
  2814
       for the term ordering (KBO or LPO), from smaller to larger values. *)
46446
45ff234921a3 tune KBO weight code
blanchet
parents: 46443
diff changeset
  2815
    [] |> add_weights 1 (Graph.minimals graph) |> sort (int_ord o pairself snd)
46442
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2816
  end
1e07620d724c added possibility of generating KBO weights to DFG problems
blanchet
parents: 46437
diff changeset
  2817
38282
319c59682c51 move Sledgehammer's HOL -> FOL translation to separate file (sledgehammer_translate.ML)
blanchet
parents:
diff changeset
  2818
end;