author | blanchet |
Wed, 04 May 2011 18:48:25 +0200 | |
changeset 42679 | 223f01b32f17 |
parent 42678 | 593e375b939f |
child 42680 | b6c27cf04fe9 |
permissions | -rw-r--r-- |
33978
2380c1dac86e
fix soundness bug in Nitpick's "destroy_constrs" optimization
blanchet
parents:
33968
diff
changeset
|
1 |
(* Title: HOL/Tools/Nitpick/nitpick_hol.ML |
33192 | 2 |
Author: Jasmin Blanchette, TU Muenchen |
34982
7b8c366e34a2
added support for nonstandard models to Nitpick (based on an idea by Koen Claessen) and did other fixes to Nitpick
blanchet
parents:
34936
diff
changeset
|
3 |
Copyright 2008, 2009, 2010 |
33192 | 4 |
|
5 |
Auxiliary HOL-related functions used by Nitpick. |
|
6 |
*) |
|
7 |
||
8 |
signature NITPICK_HOL = |
|
9 |
sig |
|
33705
947184dc75c9
removed a few global names in Nitpick (styp, nat_less, pairf)
blanchet
parents:
33583
diff
changeset
|
10 |
type styp = Nitpick_Util.styp |
33192 | 11 |
type const_table = term list Symtab.table |
12 |
type special_fun = (styp * int list * term list) * styp |
|
13 |
type unrolled = styp * styp |
|
14 |
type wf_cache = (styp * (bool * bool)) list |
|
15 |
||
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
16 |
type hol_context = |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
17 |
{thy: theory, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
18 |
ctxt: Proof.context, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
19 |
max_bisim_depth: int, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
20 |
boxes: (typ option * bool option) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
21 |
stds: (typ option * bool) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
22 |
wfs: (styp option * bool option) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
23 |
user_axioms: bool option, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
24 |
debug: bool, |
38209 | 25 |
whacks: term list, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
26 |
binary_ints: bool option, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
27 |
destroy_constrs: bool, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
28 |
specialize: bool, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
29 |
star_linear_preds: bool, |
41871
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
30 |
total_consts: bool option, |
41876 | 31 |
needs: term list option, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
32 |
tac_timeout: Time.time option, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
33 |
evals: term list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
34 |
case_names: (string * int) list, |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
35 |
def_tables: const_table * const_table, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
36 |
nondef_table: const_table, |
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
37 |
nondefs: term list, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
38 |
simp_table: const_table Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
39 |
psimp_table: const_table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
40 |
choice_spec_table: const_table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
41 |
intro_table: const_table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
42 |
ground_thm_table: term list Inttab.table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
43 |
ersatz_table: (string * string) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
44 |
skolems: (string * string list) list Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
45 |
special_funs: special_fun list Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
46 |
unrolled_preds: unrolled list Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
47 |
wf_cache: wf_cache Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
48 |
constr_cache: (typ * styp list) list Unsynchronized.ref} |
33192 | 49 |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
50 |
datatype fixpoint_kind = Lfp | Gfp | NoFp |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
51 |
datatype boxability = |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
52 |
InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2 |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
53 |
|
33192 | 54 |
val name_sep : string |
55 |
val numeral_prefix : string |
|
35718 | 56 |
val base_prefix : string |
57 |
val step_prefix : string |
|
58 |
val unrolled_prefix : string |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
59 |
val ubfp_prefix : string |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
60 |
val lbfp_prefix : string |
35311 | 61 |
val quot_normal_prefix : string |
33192 | 62 |
val skolem_prefix : string |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
63 |
val special_prefix : string |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
64 |
val uncurry_prefix : string |
33192 | 65 |
val eval_prefix : string |
35718 | 66 |
val iter_var_prefix : string |
67 |
val strip_first_name_sep : string -> string * string |
|
33192 | 68 |
val original_name : string -> string |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
69 |
val abs_var : indexname * typ -> term -> term |
34998 | 70 |
val s_conj : term * term -> term |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
71 |
val s_disj : term * term -> term |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
72 |
val strip_any_connective : term -> term list * term |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
73 |
val conjuncts_of : term -> term list |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
74 |
val disjuncts_of : term -> term list |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
75 |
val unarize_unbox_etc_type : typ -> typ |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
76 |
val uniterize_unarize_unbox_etc_type : typ -> typ |
33192 | 77 |
val string_for_type : Proof.context -> typ -> string |
38188 | 78 |
val pretty_for_type : Proof.context -> typ -> Pretty.T |
33192 | 79 |
val prefix_name : string -> string -> string |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
80 |
val shortest_name : string -> string |
33192 | 81 |
val short_name : string -> string |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
82 |
val shorten_names_in_term : term -> term |
35711
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
83 |
val strict_type_match : theory -> typ * typ -> bool |
33192 | 84 |
val type_match : theory -> typ * typ -> bool |
85 |
val const_match : theory -> styp * styp -> bool |
|
86 |
val term_match : theory -> term * term -> bool |
|
35711
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
87 |
val frac_from_term_pair : typ -> term -> term -> term |
33192 | 88 |
val is_TFree : typ -> bool |
89 |
val is_fun_type : typ -> bool |
|
90 |
val is_set_type : typ -> bool |
|
91 |
val is_pair_type : typ -> bool |
|
92 |
val is_lfp_iterator_type : typ -> bool |
|
93 |
val is_gfp_iterator_type : typ -> bool |
|
94 |
val is_fp_iterator_type : typ -> bool |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
95 |
val is_iterator_type : typ -> bool |
33192 | 96 |
val is_boolean_type : typ -> bool |
97 |
val is_integer_type : typ -> bool |
|
34124
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
98 |
val is_bit_type : typ -> bool |
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
99 |
val is_word_type : typ -> bool |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
100 |
val is_integer_like_type : typ -> bool |
33192 | 101 |
val is_record_type : typ -> bool |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
102 |
val is_number_type : Proof.context -> typ -> bool |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
103 |
val is_higher_order_type : typ -> bool |
33192 | 104 |
val const_for_iterator_type : typ -> styp |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
105 |
val strip_n_binders : int -> typ -> typ list * typ |
33192 | 106 |
val nth_range_type : int -> typ -> typ |
107 |
val num_factors_in_type : typ -> int |
|
108 |
val num_binder_types : typ -> int |
|
109 |
val curried_binder_types : typ -> typ list |
|
110 |
val mk_flat_tuple : typ -> term list -> term |
|
111 |
val dest_n_tuple : int -> term -> term list |
|
33978
2380c1dac86e
fix soundness bug in Nitpick's "destroy_constrs" optimization
blanchet
parents:
33968
diff
changeset
|
112 |
val is_real_datatype : theory -> string -> bool |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
113 |
val is_standard_datatype : theory -> (typ option * bool) list -> typ -> bool |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
114 |
val is_codatatype : Proof.context -> typ -> bool |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
115 |
val is_quot_type : Proof.context -> typ -> bool |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
116 |
val is_pure_typedef : Proof.context -> typ -> bool |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
117 |
val is_univ_typedef : Proof.context -> typ -> bool |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
118 |
val is_datatype : Proof.context -> (typ option * bool) list -> typ -> bool |
33192 | 119 |
val is_record_constr : styp -> bool |
120 |
val is_record_get : theory -> styp -> bool |
|
121 |
val is_record_update : theory -> styp -> bool |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
122 |
val is_abs_fun : Proof.context -> styp -> bool |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
123 |
val is_rep_fun : Proof.context -> styp -> bool |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
124 |
val is_quot_abs_fun : Proof.context -> styp -> bool |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
125 |
val is_quot_rep_fun : Proof.context -> styp -> bool |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
126 |
val mate_of_rep_fun : Proof.context -> styp -> styp |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
127 |
val is_constr_like : Proof.context -> styp -> bool |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
128 |
val is_constr : Proof.context -> (typ option * bool) list -> styp -> bool |
33192 | 129 |
val is_sel : string -> bool |
34124
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
130 |
val is_sel_like_and_no_discr : string -> bool |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
131 |
val box_type : hol_context -> boxability -> typ -> typ |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
132 |
val binarize_nat_and_int_in_type : typ -> typ |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
133 |
val binarize_nat_and_int_in_term : term -> term |
33192 | 134 |
val discr_for_constr : styp -> styp |
135 |
val num_sels_for_constr_type : typ -> int |
|
136 |
val nth_sel_name_for_constr_name : string -> int -> string |
|
137 |
val nth_sel_for_constr : styp -> int -> styp |
|
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
138 |
val binarized_and_boxed_nth_sel_for_constr : |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
139 |
hol_context -> bool -> styp -> int -> styp |
33192 | 140 |
val sel_no_from_name : string -> int |
35078
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
141 |
val close_form : term -> term |
33192 | 142 |
val distinctness_formula : typ -> term list -> term |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
143 |
val register_frac_type : |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
144 |
string -> (string * string) list -> morphism -> Context.generic |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
145 |
-> Context.generic |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
146 |
val register_frac_type_global : |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
147 |
string -> (string * string) list -> theory -> theory |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
148 |
val unregister_frac_type : |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
149 |
string -> morphism -> Context.generic -> Context.generic |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
150 |
val unregister_frac_type_global : string -> theory -> theory |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
151 |
val register_codatatype : |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
152 |
typ -> string -> styp list -> morphism -> Context.generic -> Context.generic |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
153 |
val register_codatatype_global : |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
154 |
typ -> string -> styp list -> theory -> theory |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
155 |
val unregister_codatatype : |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
156 |
typ -> morphism -> Context.generic -> Context.generic |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
157 |
val unregister_codatatype_global : typ -> theory -> theory |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
158 |
val datatype_constrs : hol_context -> typ -> styp list |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
159 |
val binarized_and_boxed_datatype_constrs : |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
160 |
hol_context -> bool -> typ -> styp list |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
161 |
val num_datatype_constrs : hol_context -> typ -> int |
33192 | 162 |
val constr_name_for_sel_like : string -> string |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
163 |
val binarized_and_boxed_constr_for_sel : hol_context -> bool -> styp -> styp |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
164 |
val card_of_type : (typ * int) list -> typ -> int |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
165 |
val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
166 |
val bounded_exact_card_of_type : |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
167 |
hol_context -> typ list -> int -> int -> (typ * int) list -> typ -> int |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
168 |
val typical_card_of_type : typ -> int |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
169 |
val is_finite_type : hol_context -> typ -> bool |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
170 |
val is_special_eligible_arg : bool -> typ list -> term -> bool |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
171 |
val s_let : |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
172 |
typ list -> string -> int -> typ -> typ -> (term -> term) -> term -> term |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
173 |
val s_betapply : typ list -> term * term -> term |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
174 |
val s_betapplys : typ list -> term * term list -> term |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
175 |
val discriminate_value : hol_context -> styp -> term -> term |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
176 |
val select_nth_constr_arg : |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
177 |
Proof.context -> (typ option * bool) list -> styp -> term -> int -> typ |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
178 |
-> term |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
179 |
val construct_value : |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
180 |
Proof.context -> (typ option * bool) list -> styp -> term list -> term |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
181 |
val coerce_term : hol_context -> typ list -> typ -> typ -> term -> term |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
182 |
val special_bounds : term list -> (indexname * typ) list |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
183 |
val is_funky_typedef : Proof.context -> typ -> bool |
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
184 |
val all_defs_of : theory -> (term * term) list -> term list |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
185 |
val all_nondefs_of : Proof.context -> (term * term) list -> term list |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
186 |
val arity_of_built_in_const : |
39359 | 187 |
theory -> (typ option * bool) list -> styp -> int option |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
188 |
val is_built_in_const : |
39359 | 189 |
theory -> (typ option * bool) list -> styp -> bool |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
190 |
val term_under_def : term -> term |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
191 |
val case_const_names : |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
192 |
Proof.context -> (typ option * bool) list -> (string * int) list |
35718 | 193 |
val unfold_defs_in_term : hol_context -> term -> term |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
194 |
val const_def_tables : |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
195 |
Proof.context -> (term * term) list -> term list |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
196 |
-> const_table * const_table |
33192 | 197 |
val const_nondef_table : term list -> const_table |
35335 | 198 |
val const_simp_table : Proof.context -> (term * term) list -> const_table |
199 |
val const_psimp_table : Proof.context -> (term * term) list -> const_table |
|
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
200 |
val const_choice_spec_table : |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
201 |
Proof.context -> (term * term) list -> const_table |
35335 | 202 |
val inductive_intro_table : |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
203 |
Proof.context -> (term * term) list -> const_table * const_table |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
204 |
-> const_table |
33192 | 205 |
val ground_theorem_table : theory -> term list Inttab.table |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
206 |
val ersatz_table : Proof.context -> (string * string) list |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
207 |
val add_simps : const_table Unsynchronized.ref -> string -> term list -> unit |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
208 |
val inverse_axioms_for_rep_fun : Proof.context -> styp -> term list |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
209 |
val optimized_typedef_axioms : Proof.context -> string * typ list -> term list |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
210 |
val optimized_quot_type_axioms : |
35311 | 211 |
Proof.context -> (typ option * bool) list -> string * typ list -> term list |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
212 |
val def_of_const : theory -> const_table * const_table -> styp -> term option |
35718 | 213 |
val fixpoint_kind_of_rhs : term -> fixpoint_kind |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
214 |
val fixpoint_kind_of_const : |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
215 |
theory -> const_table * const_table -> string * typ -> fixpoint_kind |
38205
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
216 |
val is_real_inductive_pred : hol_context -> styp -> bool |
41994
c567c860caf6
always destroy constructor patterns, since this seems to be always useful
blanchet
parents:
41898
diff
changeset
|
217 |
val is_constr_pattern : Proof.context -> term -> bool |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
218 |
val is_constr_pattern_lhs : Proof.context -> term -> bool |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
219 |
val is_constr_pattern_formula : Proof.context -> term -> bool |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
220 |
val nondef_props_for_const : |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
221 |
theory -> bool -> const_table -> styp -> term list |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
222 |
val is_choice_spec_fun : hol_context -> styp -> bool |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
223 |
val is_choice_spec_axiom : theory -> const_table -> term -> bool |
38205
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
224 |
val is_real_equational_fun : hol_context -> styp -> bool |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
225 |
val is_equational_fun_but_no_plain_def : hol_context -> styp -> bool |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
226 |
val codatatype_bisim_axioms : hol_context -> typ -> term list |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
227 |
val is_well_founded_inductive_pred : hol_context -> styp -> bool |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
228 |
val unrolled_inductive_pred_const : hol_context -> bool -> styp -> term |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
229 |
val equational_fun_axioms : hol_context -> styp -> term list |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
230 |
val is_equational_fun_surely_complete : hol_context -> styp -> bool |
38212
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
231 |
val merged_type_var_table_for_terms : |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
232 |
theory -> term list -> (sort * string) list |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
233 |
val merge_type_vars_in_term : |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
234 |
theory -> bool -> (sort * string) list -> term -> term |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
235 |
val ground_types_in_type : hol_context -> bool -> typ -> typ list |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
236 |
val ground_types_in_terms : hol_context -> bool -> term list -> typ list |
33192 | 237 |
end; |
238 |
||
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
239 |
structure Nitpick_HOL : NITPICK_HOL = |
33192 | 240 |
struct |
241 |
||
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
242 |
open Nitpick_Util |
33192 | 243 |
|
244 |
type const_table = term list Symtab.table |
|
245 |
type special_fun = (styp * int list * term list) * styp |
|
246 |
type unrolled = styp * styp |
|
247 |
type wf_cache = (styp * (bool * bool)) list |
|
248 |
||
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
249 |
type hol_context = |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
250 |
{thy: theory, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
251 |
ctxt: Proof.context, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
252 |
max_bisim_depth: int, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
253 |
boxes: (typ option * bool option) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
254 |
stds: (typ option * bool) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
255 |
wfs: (styp option * bool option) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
256 |
user_axioms: bool option, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
257 |
debug: bool, |
38209 | 258 |
whacks: term list, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
259 |
binary_ints: bool option, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
260 |
destroy_constrs: bool, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
261 |
specialize: bool, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
262 |
star_linear_preds: bool, |
41871
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
263 |
total_consts: bool option, |
41876 | 264 |
needs: term list option, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
265 |
tac_timeout: Time.time option, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
266 |
evals: term list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
267 |
case_names: (string * int) list, |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
268 |
def_tables: const_table * const_table, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
269 |
nondef_table: const_table, |
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
270 |
nondefs: term list, |
36390
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
271 |
simp_table: const_table Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
272 |
psimp_table: const_table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
273 |
choice_spec_table: const_table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
274 |
intro_table: const_table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
275 |
ground_thm_table: term list Inttab.table, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
276 |
ersatz_table: (string * string) list, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
277 |
skolems: (string * string list) list Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
278 |
special_funs: special_fun list Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
279 |
unrolled_preds: unrolled list Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
280 |
wf_cache: wf_cache Unsynchronized.ref, |
eee4ee6a5cbe
remove "show_skolems" option and change style of record declarations
blanchet
parents:
36389
diff
changeset
|
281 |
constr_cache: (typ * styp list) list Unsynchronized.ref} |
33192 | 282 |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
283 |
datatype fixpoint_kind = Lfp | Gfp | NoFp |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
284 |
datatype boxability = |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
285 |
InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2 |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
286 |
|
41472
f6ab14e61604
misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents:
41052
diff
changeset
|
287 |
structure Data = Generic_Data |
f6ab14e61604
misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents:
41052
diff
changeset
|
288 |
( |
33192 | 289 |
type T = {frac_types: (string * (string * string) list) list, |
290 |
codatatypes: (string * (string * styp list)) list} |
|
291 |
val empty = {frac_types = [], codatatypes = []} |
|
292 |
val extend = I |
|
33522 | 293 |
fun merge ({frac_types = fs1, codatatypes = cs1}, |
36391 | 294 |
{frac_types = fs2, codatatypes = cs2}) : T = |
33699
f33b036ef318
permissive AList.merge -- most likely setup for theory data (beware of spurious AList.DUP);
wenzelm
parents:
33583
diff
changeset
|
295 |
{frac_types = AList.merge (op =) (K true) (fs1, fs2), |
41472
f6ab14e61604
misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents:
41052
diff
changeset
|
296 |
codatatypes = AList.merge (op =) (K true) (cs1, cs2)} |
f6ab14e61604
misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents:
41052
diff
changeset
|
297 |
) |
33192 | 298 |
|
299 |
val name_sep = "$" |
|
300 |
val numeral_prefix = nitpick_prefix ^ "num" ^ name_sep |
|
301 |
val sel_prefix = nitpick_prefix ^ "sel" |
|
302 |
val discr_prefix = nitpick_prefix ^ "is" ^ name_sep |
|
303 |
val set_prefix = nitpick_prefix ^ "set" ^ name_sep |
|
304 |
val lfp_iterator_prefix = nitpick_prefix ^ "lfpit" ^ name_sep |
|
305 |
val gfp_iterator_prefix = nitpick_prefix ^ "gfpit" ^ name_sep |
|
306 |
val unrolled_prefix = nitpick_prefix ^ "unroll" ^ name_sep |
|
307 |
val base_prefix = nitpick_prefix ^ "base" ^ name_sep |
|
308 |
val step_prefix = nitpick_prefix ^ "step" ^ name_sep |
|
309 |
val ubfp_prefix = nitpick_prefix ^ "ubfp" ^ name_sep |
|
310 |
val lbfp_prefix = nitpick_prefix ^ "lbfp" ^ name_sep |
|
35311 | 311 |
val quot_normal_prefix = nitpick_prefix ^ "qn" ^ name_sep |
33192 | 312 |
val skolem_prefix = nitpick_prefix ^ "sk" |
313 |
val special_prefix = nitpick_prefix ^ "sp" |
|
314 |
val uncurry_prefix = nitpick_prefix ^ "unc" |
|
315 |
val eval_prefix = nitpick_prefix ^ "eval" |
|
316 |
val iter_var_prefix = "i" |
|
35718 | 317 |
|
318 |
(** Constant/type information and term/type manipulation **) |
|
33192 | 319 |
|
320 |
fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep |
|
35311 | 321 |
fun quot_normal_name_for_type ctxt T = |
322 |
quot_normal_prefix ^ unyxml (Syntax.string_of_typ ctxt T) |
|
33192 | 323 |
|
324 |
val strip_first_name_sep = |
|
325 |
Substring.full #> Substring.position name_sep ##> Substring.triml 1 |
|
326 |
#> pairself Substring.string |
|
327 |
fun original_name s = |
|
328 |
if String.isPrefix nitpick_prefix s then |
|
329 |
case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2 |
|
330 |
else |
|
331 |
s |
|
35718 | 332 |
|
34998 | 333 |
fun s_conj (t1, @{const True}) = t1 |
334 |
| s_conj (@{const True}, t2) = t2 |
|
335 |
| s_conj (t1, t2) = |
|
336 |
if t1 = @{const False} orelse t2 = @{const False} then @{const False} |
|
337 |
else HOLogic.mk_conj (t1, t2) |
|
338 |
fun s_disj (t1, @{const False}) = t1 |
|
339 |
| s_disj (@{const False}, t2) = t2 |
|
340 |
| s_disj (t1, t2) = |
|
341 |
if t1 = @{const True} orelse t2 = @{const True} then @{const True} |
|
342 |
else HOLogic.mk_disj (t1, t2) |
|
343 |
||
344 |
fun strip_connective conn_t (t as (t0 $ t1 $ t2)) = |
|
345 |
if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t] |
|
346 |
| strip_connective _ t = [t] |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
347 |
fun strip_any_connective (t as (t0 $ _ $ _)) = |
38795
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
348 |
if t0 = @{const HOL.conj} orelse t0 = @{const HOL.disj} then |
34998 | 349 |
(strip_connective t0 t, t0) |
350 |
else |
|
351 |
([t], @{const Not}) |
|
352 |
| strip_any_connective t = ([t], @{const Not}) |
|
38795
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
353 |
val conjuncts_of = strip_connective @{const HOL.conj} |
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
354 |
val disjuncts_of = strip_connective @{const HOL.disj} |
34998 | 355 |
|
33192 | 356 |
(* When you add constants to these lists, make sure to handle them in |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
357 |
"Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as |
33192 | 358 |
well. *) |
359 |
val built_in_consts = |
|
360 |
[(@{const_name all}, 1), |
|
361 |
(@{const_name "=="}, 2), |
|
362 |
(@{const_name "==>"}, 2), |
|
363 |
(@{const_name Pure.conjunction}, 2), |
|
364 |
(@{const_name Trueprop}, 1), |
|
365 |
(@{const_name Not}, 1), |
|
366 |
(@{const_name False}, 0), |
|
367 |
(@{const_name True}, 0), |
|
368 |
(@{const_name All}, 1), |
|
369 |
(@{const_name Ex}, 1), |
|
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
370 |
(@{const_name HOL.eq}, 1), |
38795
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
371 |
(@{const_name HOL.conj}, 2), |
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
372 |
(@{const_name HOL.disj}, 2), |
38786
e46e7a9cb622
formerly unnamed infix impliciation now named HOL.implies
haftmann
parents:
38652
diff
changeset
|
373 |
(@{const_name HOL.implies}, 2), |
33192 | 374 |
(@{const_name If}, 3), |
375 |
(@{const_name Let}, 2), |
|
376 |
(@{const_name Pair}, 2), |
|
377 |
(@{const_name fst}, 1), |
|
378 |
(@{const_name snd}, 1), |
|
379 |
(@{const_name Id}, 0), |
|
380 |
(@{const_name converse}, 1), |
|
381 |
(@{const_name trancl}, 1), |
|
382 |
(@{const_name rel_comp}, 2), |
|
383 |
(@{const_name finite}, 1), |
|
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
384 |
(@{const_name unknown}, 0), |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
385 |
(@{const_name is_unknown}, 1), |
35671
ed2c3830d881
improved Nitpick's precision for "card" and "setsum" + fix incorrect outcome code w.r.t. "bisim_depth = -1"
blanchet
parents:
35665
diff
changeset
|
386 |
(@{const_name safe_The}, 1), |
33192 | 387 |
(@{const_name Frac}, 0), |
388 |
(@{const_name norm_frac}, 0)] |
|
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
389 |
val built_in_nat_consts = |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
390 |
[(@{const_name Suc}, 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
391 |
(@{const_name nat}, 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
392 |
(@{const_name nat_gcd}, 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
393 |
(@{const_name nat_lcm}, 0)] |
33192 | 394 |
val built_in_typed_consts = |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
395 |
[((@{const_name zero_class.zero}, int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
396 |
((@{const_name one_class.one}, int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
397 |
((@{const_name plus_class.plus}, int_T --> int_T --> int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
398 |
((@{const_name minus_class.minus}, int_T --> int_T --> int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
399 |
((@{const_name times_class.times}, int_T --> int_T --> int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
400 |
((@{const_name div_class.div}, int_T --> int_T --> int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
401 |
((@{const_name uminus_class.uminus}, int_T --> int_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
402 |
((@{const_name ord_class.less}, int_T --> int_T --> bool_T), 2), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
403 |
((@{const_name ord_class.less_eq}, int_T --> int_T --> bool_T), 2)] |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
404 |
val built_in_typed_nat_consts = |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
405 |
[((@{const_name zero_class.zero}, nat_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
406 |
((@{const_name one_class.one}, nat_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
407 |
((@{const_name plus_class.plus}, nat_T --> nat_T --> nat_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
408 |
((@{const_name minus_class.minus}, nat_T --> nat_T --> nat_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
409 |
((@{const_name times_class.times}, nat_T --> nat_T --> nat_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
410 |
((@{const_name div_class.div}, nat_T --> nat_T --> nat_T), 0), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
411 |
((@{const_name ord_class.less}, nat_T --> nat_T --> bool_T), 2), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
412 |
((@{const_name ord_class.less_eq}, nat_T --> nat_T --> bool_T), 2), |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
413 |
((@{const_name of_nat}, nat_T --> int_T), 0)] |
33192 | 414 |
val built_in_set_consts = |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
415 |
[(@{const_name ord_class.less_eq}, 2)] |
33192 | 416 |
|
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
417 |
fun unarize_type @{typ "unsigned_bit word"} = nat_T |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
418 |
| unarize_type @{typ "signed_bit word"} = int_T |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
419 |
| unarize_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_type Ts) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
420 |
| unarize_type T = T |
41052
3db267a01c1d
remove the "fin_fun" optimization in Nitpick -- it was always a hack and didn't help much
blanchet
parents:
41049
diff
changeset
|
421 |
fun unarize_unbox_etc_type (Type (@{type_name fun_box}, Ts)) = |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
422 |
unarize_unbox_etc_type (Type (@{type_name fun}, Ts)) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
423 |
| unarize_unbox_etc_type (Type (@{type_name pair_box}, Ts)) = |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
424 |
Type (@{type_name prod}, map unarize_unbox_etc_type Ts) |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
425 |
| unarize_unbox_etc_type @{typ "unsigned_bit word"} = nat_T |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
426 |
| unarize_unbox_etc_type @{typ "signed_bit word"} = int_T |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
427 |
| unarize_unbox_etc_type (Type (s, Ts as _ :: _)) = |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
428 |
Type (s, map unarize_unbox_etc_type Ts) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
429 |
| unarize_unbox_etc_type T = T |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
430 |
fun uniterize_type (Type (s, Ts as _ :: _)) = Type (s, map uniterize_type Ts) |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
431 |
| uniterize_type @{typ bisim_iterator} = nat_T |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
432 |
| uniterize_type T = T |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
433 |
val uniterize_unarize_unbox_etc_type = uniterize_type o unarize_unbox_etc_type |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
434 |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
435 |
fun string_for_type ctxt = Syntax.string_of_typ ctxt o unarize_unbox_etc_type |
38188 | 436 |
fun pretty_for_type ctxt = Syntax.pretty_typ ctxt o unarize_unbox_etc_type |
33192 | 437 |
|
438 |
val prefix_name = Long_Name.qualify o Long_Name.base_name |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
439 |
fun shortest_name s = List.last (space_explode "." s) handle List.Empty => "" |
33192 | 440 |
val prefix_abs_vars = Term.map_abs_vars o prefix_name |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
441 |
fun short_name s = |
33192 | 442 |
case space_explode name_sep s of |
443 |
[_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
444 |
| ss => map shortest_name ss |> space_implode "_" |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
445 |
fun shorten_names_in_type (Type (s, Ts)) = |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
446 |
Type (short_name s, map shorten_names_in_type Ts) |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
447 |
| shorten_names_in_type T = T |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
448 |
val shorten_names_in_term = |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
449 |
map_aterms (fn Const (s, T) => Const (short_name s, T) | t => t) |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
450 |
#> map_types shorten_names_in_type |
33192 | 451 |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
452 |
fun strict_type_match thy (T1, T2) = |
33192 | 453 |
(Sign.typ_match thy (T2, T1) Vartab.empty; true) |
454 |
handle Type.TYPE_MATCH => false |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
455 |
fun type_match thy = strict_type_match thy o pairself unarize_unbox_etc_type |
33192 | 456 |
fun const_match thy ((s1, T1), (s2, T2)) = |
457 |
s1 = s2 andalso type_match thy (T1, T2) |
|
458 |
fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2) |
|
459 |
| term_match thy (Free (s1, T1), Free (s2, T2)) = |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
460 |
const_match thy ((shortest_name s1, T1), (shortest_name s2, T2)) |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
461 |
| term_match _ (t1, t2) = t1 aconv t2 |
33192 | 462 |
|
35711
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
463 |
fun frac_from_term_pair T t1 t2 = |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
464 |
case snd (HOLogic.dest_number t1) of |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
465 |
0 => HOLogic.mk_number T 0 |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
466 |
| n1 => case snd (HOLogic.dest_number t2) of |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
467 |
1 => HOLogic.mk_number T n1 |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
468 |
| n2 => Const (@{const_name divide}, T --> T --> T) |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
469 |
$ HOLogic.mk_number T n1 $ HOLogic.mk_number T n2 |
548d3f16404b
added term postprocessor to Nitpick, to provide custom syntax for typedefs
blanchet
parents:
35671
diff
changeset
|
470 |
|
33192 | 471 |
fun is_TFree (TFree _) = true |
472 |
| is_TFree _ = false |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
473 |
fun is_fun_type (Type (@{type_name fun}, _)) = true |
33192 | 474 |
| is_fun_type _ = false |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
475 |
fun is_set_type (Type (@{type_name fun}, [_, @{typ bool}])) = true |
33192 | 476 |
| is_set_type _ = false |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
477 |
fun is_pair_type (Type (@{type_name prod}, _)) = true |
33192 | 478 |
| is_pair_type _ = false |
479 |
fun is_lfp_iterator_type (Type (s, _)) = String.isPrefix lfp_iterator_prefix s |
|
480 |
| is_lfp_iterator_type _ = false |
|
481 |
fun is_gfp_iterator_type (Type (s, _)) = String.isPrefix gfp_iterator_prefix s |
|
482 |
| is_gfp_iterator_type _ = false |
|
483 |
val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
484 |
fun is_iterator_type T = |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
485 |
(T = @{typ bisim_iterator} orelse is_fp_iterator_type T) |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
486 |
fun is_boolean_type T = (T = prop_T orelse T = bool_T) |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
487 |
fun is_integer_type T = (T = nat_T orelse T = int_T) |
34124
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
488 |
fun is_bit_type T = (T = @{typ unsigned_bit} orelse T = @{typ signed_bit}) |
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
489 |
fun is_word_type (Type (@{type_name word}, _)) = true |
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
490 |
| is_word_type _ = false |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
491 |
val is_integer_like_type = is_iterator_type orf is_integer_type orf is_word_type |
33192 | 492 |
val is_record_type = not o null o Record.dest_recTs |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
493 |
fun is_frac_type ctxt (Type (s, [])) = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
494 |
s |> AList.lookup (op =) (#frac_types (Data.get (Context.Proof ctxt))) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
495 |
|> these |> null |> not |
33192 | 496 |
| is_frac_type _ _ = false |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
497 |
fun is_number_type ctxt = is_integer_like_type orf is_frac_type ctxt |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
498 |
fun is_higher_order_type (Type (@{type_name fun}, _)) = true |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
499 |
| is_higher_order_type (Type (_, Ts)) = exists is_higher_order_type Ts |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
500 |
| is_higher_order_type _ = false |
33192 | 501 |
|
502 |
fun iterator_type_for_const gfp (s, T) = |
|
503 |
Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s, |
|
504 |
binder_types T) |
|
35718 | 505 |
fun const_for_iterator_type (Type (s, Ts)) = |
506 |
(strip_first_name_sep s |> snd, Ts ---> bool_T) |
|
33192 | 507 |
| const_for_iterator_type T = |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
508 |
raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], []) |
33192 | 509 |
|
510 |
fun strip_n_binders 0 T = ([], T) |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
511 |
| strip_n_binders n (Type (@{type_name fun}, [T1, T2])) = |
33192 | 512 |
strip_n_binders (n - 1) T2 |>> cons T1 |
513 |
| strip_n_binders n (Type (@{type_name fun_box}, Ts)) = |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
514 |
strip_n_binders n (Type (@{type_name fun}, Ts)) |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
515 |
| strip_n_binders _ T = raise TYPE ("Nitpick_HOL.strip_n_binders", [T], []) |
33192 | 516 |
val nth_range_type = snd oo strip_n_binders |
517 |
||
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
518 |
fun num_factors_in_type (Type (@{type_name prod}, [T1, T2])) = |
33192 | 519 |
fold (Integer.add o num_factors_in_type) [T1, T2] 0 |
520 |
| num_factors_in_type _ = 1 |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
521 |
fun num_binder_types (Type (@{type_name fun}, [_, T2])) = |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
522 |
1 + num_binder_types T2 |
33192 | 523 |
| num_binder_types _ = 0 |
524 |
val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types |
|
525 |
fun maybe_curried_binder_types T = |
|
526 |
(if is_pair_type (body_type T) then binder_types else curried_binder_types) T |
|
527 |
||
528 |
fun mk_flat_tuple _ [t] = t |
|
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
529 |
| mk_flat_tuple (Type (@{type_name prod}, [T1, T2])) (t :: ts) = |
33192 | 530 |
HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts) |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
531 |
| mk_flat_tuple T ts = raise TYPE ("Nitpick_HOL.mk_flat_tuple", [T], ts) |
33192 | 532 |
fun dest_n_tuple 1 t = [t] |
533 |
| dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op :: |
|
534 |
||
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
535 |
type typedef_info = |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
536 |
{rep_type: typ, abs_type: typ, Rep_name: string, Abs_name: string, |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
537 |
set_def: thm option, prop_of_Rep: thm, set_name: string, |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
538 |
Abs_inverse: thm option, Rep_inverse: thm option} |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
539 |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
540 |
fun typedef_info ctxt s = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
541 |
if is_frac_type ctxt (Type (s, [])) then |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
542 |
SOME {abs_type = Type (s, []), rep_type = @{typ "int * int"}, |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
543 |
Abs_name = @{const_name Abs_Frac}, Rep_name = @{const_name Rep_Frac}, |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
544 |
set_def = NONE, prop_of_Rep = @{prop "Rep_Frac x \<in> Frac"} |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
545 |
|> Logic.varify_global, |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
546 |
set_name = @{const_name Frac}, Abs_inverse = NONE, Rep_inverse = NONE} |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
547 |
else case Typedef.get_info ctxt s of |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
548 |
(* When several entries are returned, it shouldn't matter much which one |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
549 |
we take (according to Florian Haftmann). *) |
39315
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
550 |
(* The "Logic.varifyT_global" calls are a temporary hack because these |
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
551 |
types's type variables sometimes clash with locally fixed type variables. |
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
552 |
Remove these calls once "Typedef" is fully localized. *) |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
553 |
({abs_type, rep_type, Abs_name, Rep_name, ...}, |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
554 |
{set_def, Rep, Abs_inverse, Rep_inverse, ...}) :: _ => |
39315
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
555 |
SOME {abs_type = Logic.varifyT_global abs_type, |
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
556 |
rep_type = Logic.varifyT_global rep_type, Abs_name = Abs_name, |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
557 |
Rep_name = Rep_name, set_def = set_def, prop_of_Rep = prop_of Rep, |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
558 |
set_name = set_prefix ^ s, Abs_inverse = SOME Abs_inverse, |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
559 |
Rep_inverse = SOME Rep_inverse} |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
560 |
| _ => NONE |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
561 |
|
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
562 |
val is_typedef = is_some oo typedef_info |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
563 |
val is_real_datatype = is_some oo Datatype.get_info |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
564 |
fun is_standard_datatype thy = the oo triple_lookup (type_match thy) |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
565 |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
566 |
(* FIXME: Use antiquotation for "code_numeral" below or detect "rep_datatype", |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
567 |
e.g., by adding a field to "Datatype_Aux.info". *) |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
568 |
fun is_basic_datatype thy stds s = |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
569 |
member (op =) [@{type_name prod}, @{type_name bool}, @{type_name int}, |
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
570 |
"Code_Numeral.code_numeral"] s orelse |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
571 |
(s = @{type_name nat} andalso is_standard_datatype thy stds nat_T) |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
572 |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
573 |
(* TODO: use "Term_Subst.instantiateT" instead? *) |
33192 | 574 |
fun instantiate_type thy T1 T1' T2 = |
575 |
Same.commit (Envir.subst_type_same |
|
35311 | 576 |
(Sign.typ_match thy (T1, T1') Vartab.empty)) T2 |
33192 | 577 |
handle Type.TYPE_MATCH => |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
578 |
raise TYPE ("Nitpick_HOL.instantiate_type", [T1, T1'], []) |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
579 |
fun varify_and_instantiate_type ctxt T1 T1' T2 = |
42361 | 580 |
let val thy = Proof_Context.theory_of ctxt in |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
581 |
instantiate_type thy (varify_type ctxt T1) T1' (varify_type ctxt T2) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
582 |
end |
33192 | 583 |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
584 |
fun repair_constr_type ctxt body_T' T = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
585 |
varify_and_instantiate_type ctxt (body_type T) body_T' T |
33192 | 586 |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
587 |
fun register_frac_type_generic frac_s ersaetze generic = |
33192 | 588 |
let |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
589 |
val {frac_types, codatatypes} = Data.get generic |
33192 | 590 |
val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
591 |
in Data.put {frac_types = frac_types, codatatypes = codatatypes} generic end |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
592 |
(* TODO: Consider morphism. *) |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
593 |
fun register_frac_type frac_s ersaetze (_ : morphism) = |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
594 |
register_frac_type_generic frac_s ersaetze |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
595 |
val register_frac_type_global = Context.theory_map oo register_frac_type_generic |
33192 | 596 |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
597 |
fun unregister_frac_type_generic frac_s = register_frac_type_generic frac_s [] |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
598 |
(* TODO: Consider morphism. *) |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
599 |
fun unregister_frac_type frac_s (_ : morphism) = |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
600 |
unregister_frac_type_generic frac_s |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
601 |
val unregister_frac_type_global = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
602 |
Context.theory_map o unregister_frac_type_generic |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
603 |
|
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
604 |
fun register_codatatype_generic co_T case_name constr_xs generic = |
33192 | 605 |
let |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
606 |
val ctxt = Context.proof_of generic |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
607 |
val thy = Context.theory_of generic |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
608 |
val {frac_types, codatatypes} = Data.get generic |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
609 |
val constr_xs = map (apsnd (repair_constr_type ctxt co_T)) constr_xs |
33192 | 610 |
val (co_s, co_Ts) = dest_Type co_T |
611 |
val _ = |
|
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
612 |
if forall is_TFree co_Ts andalso not (has_duplicates (op =) co_Ts) andalso |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
613 |
co_s <> @{type_name fun} andalso |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
614 |
not (is_basic_datatype thy [(NONE, true)] co_s) then |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
615 |
() |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
616 |
else |
38242 | 617 |
raise TYPE ("Nitpick_HOL.register_codatatype_generic", [co_T], []) |
33192 | 618 |
val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs)) |
619 |
codatatypes |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
620 |
in Data.put {frac_types = frac_types, codatatypes = codatatypes} generic end |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
621 |
(* TODO: Consider morphism. *) |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
622 |
fun register_codatatype co_T case_name constr_xs (_ : morphism) = |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
623 |
register_codatatype_generic co_T case_name constr_xs |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
624 |
val register_codatatype_global = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
625 |
Context.theory_map ooo register_codatatype_generic |
33192 | 626 |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
627 |
fun unregister_codatatype_generic co_T = register_codatatype_generic co_T "" [] |
38284
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
628 |
(* TODO: Consider morphism. *) |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
629 |
fun unregister_codatatype co_T (_ : morphism) = |
9f98107ad8b4
use "declaration" instead of "setup" to register Nitpick extensions
blanchet
parents:
38282
diff
changeset
|
630 |
unregister_codatatype_generic co_T |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
631 |
val unregister_codatatype_global = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
632 |
Context.theory_map o unregister_codatatype_generic |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
633 |
|
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
634 |
fun is_codatatype ctxt (Type (s, _)) = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
635 |
s |> AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt))) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
636 |
|> Option.map snd |> these |> null |> not |
33192 | 637 |
| is_codatatype _ _ = false |
38215
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
638 |
fun is_real_quot_type thy (Type (s, _)) = |
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
639 |
is_some (Quotient_Info.quotdata_lookup_raw thy s) |
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
640 |
| is_real_quot_type _ _ = false |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
641 |
fun is_quot_type ctxt T = |
42361 | 642 |
let val thy = Proof_Context.theory_of ctxt in |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
643 |
is_real_quot_type thy T andalso not (is_codatatype ctxt T) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
644 |
end |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
645 |
fun is_pure_typedef ctxt (T as Type (s, _)) = |
42361 | 646 |
let val thy = Proof_Context.theory_of ctxt in |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
647 |
is_typedef ctxt s andalso |
38215
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
648 |
not (is_real_datatype thy s orelse is_real_quot_type thy T orelse |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
649 |
is_codatatype ctxt T orelse is_record_type T orelse |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
650 |
is_integer_like_type T) |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
651 |
end |
33192 | 652 |
| is_pure_typedef _ _ = false |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
653 |
fun is_univ_typedef ctxt (Type (s, _)) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
654 |
(case typedef_info ctxt s of |
33192 | 655 |
SOME {set_def, prop_of_Rep, ...} => |
35332
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
656 |
let |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
657 |
val t_opt = |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
658 |
case set_def of |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
659 |
SOME thm => try (snd o Logic.dest_equals o prop_of) thm |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
660 |
| NONE => try (snd o HOLogic.dest_mem o HOLogic.dest_Trueprop) |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
661 |
prop_of_Rep |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
662 |
in |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
663 |
case t_opt of |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
664 |
SOME (Const (@{const_name top}, _)) => true |
35386
45a4e19d3ebd
more work on the new monotonicity stuff in Nitpick
blanchet
parents:
35385
diff
changeset
|
665 |
(* "Multiset.multiset" *) |
35332
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
666 |
| SOME (Const (@{const_name Collect}, _) |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
667 |
$ Abs (_, _, Const (@{const_name finite}, _) $ _)) => true |
35386
45a4e19d3ebd
more work on the new monotonicity stuff in Nitpick
blanchet
parents:
35385
diff
changeset
|
668 |
(* "FinFun.finfun" *) |
45a4e19d3ebd
more work on the new monotonicity stuff in Nitpick
blanchet
parents:
35385
diff
changeset
|
669 |
| SOME (Const (@{const_name Collect}, _) $ Abs (_, _, |
45a4e19d3ebd
more work on the new monotonicity stuff in Nitpick
blanchet
parents:
35385
diff
changeset
|
670 |
Const (@{const_name Ex}, _) $ Abs (_, _, |
45a4e19d3ebd
more work on the new monotonicity stuff in Nitpick
blanchet
parents:
35385
diff
changeset
|
671 |
Const (@{const_name finite}, _) $ _))) => true |
35332
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
672 |
| _ => false |
22442ab3e7a3
optimized multisets in Nitpick by fishing "finite"
blanchet
parents:
35311
diff
changeset
|
673 |
end |
33192 | 674 |
| NONE => false) |
675 |
| is_univ_typedef _ _ = false |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
676 |
fun is_datatype ctxt stds (T as Type (s, _)) = |
42361 | 677 |
let val thy = Proof_Context.theory_of ctxt in |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
678 |
(is_typedef ctxt s orelse is_codatatype ctxt T orelse |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
679 |
T = @{typ ind} orelse is_real_quot_type thy T) andalso |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
680 |
not (is_basic_datatype thy stds s) |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
681 |
end |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
682 |
| is_datatype _ _ _ = false |
33192 | 683 |
|
684 |
fun all_record_fields thy T = |
|
685 |
let val (recs, more) = Record.get_extT_fields thy T in |
|
686 |
recs @ more :: all_record_fields thy (snd more) |
|
687 |
end |
|
688 |
handle TYPE _ => [] |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
689 |
fun is_record_constr (s, T) = |
33192 | 690 |
String.isSuffix Record.extN s andalso |
691 |
let val dataT = body_type T in |
|
692 |
is_record_type dataT andalso |
|
693 |
s = unsuffix Record.ext_typeN (fst (dest_Type dataT)) ^ Record.extN |
|
694 |
end |
|
695 |
val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields |
|
696 |
fun no_of_record_field thy s T1 = |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
697 |
find_index (curry (op =) s o fst) |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
698 |
(Record.get_extT_fields thy T1 ||> single |> op @) |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
699 |
fun is_record_get thy (s, Type (@{type_name fun}, [T1, _])) = |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
700 |
exists (curry (op =) s o fst) (all_record_fields thy T1) |
33192 | 701 |
| is_record_get _ _ = false |
702 |
fun is_record_update thy (s, T) = |
|
703 |
String.isSuffix Record.updateN s andalso |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
704 |
exists (curry (op =) (unsuffix Record.updateN s) o fst) |
33192 | 705 |
(all_record_fields thy (body_type T)) |
706 |
handle TYPE _ => false |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
707 |
fun is_abs_fun ctxt (s, Type (@{type_name fun}, [_, Type (s', _)])) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
708 |
(case typedef_info ctxt s' of |
33192 | 709 |
SOME {Abs_name, ...} => s = Abs_name |
710 |
| NONE => false) |
|
711 |
| is_abs_fun _ _ = false |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
712 |
fun is_rep_fun ctxt (s, Type (@{type_name fun}, [Type (s', _), _])) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
713 |
(case typedef_info ctxt s' of |
33192 | 714 |
SOME {Rep_name, ...} => s = Rep_name |
715 |
| NONE => false) |
|
716 |
| is_rep_fun _ _ = false |
|
38215
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
717 |
fun is_quot_abs_fun ctxt (x as (_, Type (@{type_name fun}, |
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
718 |
[_, abs_T as Type (s', _)]))) = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
719 |
try (Quotient_Term.absrep_const_chk Quotient_Term.AbsF ctxt) s' |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
720 |
= SOME (Const x) andalso not (is_codatatype ctxt abs_T) |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
721 |
| is_quot_abs_fun _ _ = false |
38215
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
722 |
fun is_quot_rep_fun ctxt (x as (_, Type (@{type_name fun}, |
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
723 |
[abs_T as Type (s', _), _]))) = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
724 |
try (Quotient_Term.absrep_const_chk Quotient_Term.RepF ctxt) s' |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
725 |
= SOME (Const x) andalso not (is_codatatype ctxt abs_T) |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
726 |
| is_quot_rep_fun _ _ = false |
33192 | 727 |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
728 |
fun mate_of_rep_fun ctxt (x as (_, Type (@{type_name fun}, |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
729 |
[T1 as Type (s', _), T2]))) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
730 |
(case typedef_info ctxt s' of |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
731 |
SOME {Abs_name, ...} => (Abs_name, Type (@{type_name fun}, [T2, T1])) |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
732 |
| NONE => raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x])) |
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
733 |
| mate_of_rep_fun _ x = raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x]) |
35284
9edc2bd6d2bd
enabled Nitpick's support for quotient types + shortened the Nitpick tests a bit
blanchet
parents:
35283
diff
changeset
|
734 |
fun rep_type_for_quot_type thy (T as Type (s, _)) = |
39345 | 735 |
let val {qtyp, rtyp, ...} = Quotient_Info.quotdata_lookup thy s in |
736 |
instantiate_type thy qtyp T rtyp |
|
737 |
end |
|
738 |
| rep_type_for_quot_type _ T = |
|
739 |
raise TYPE ("Nitpick_HOL.rep_type_for_quot_type", [T], []) |
|
35284
9edc2bd6d2bd
enabled Nitpick's support for quotient types + shortened the Nitpick tests a bit
blanchet
parents:
35283
diff
changeset
|
740 |
fun equiv_relation_for_quot_type thy (Type (s, Ts)) = |
9edc2bd6d2bd
enabled Nitpick's support for quotient types + shortened the Nitpick tests a bit
blanchet
parents:
35283
diff
changeset
|
741 |
let |
38243 | 742 |
val {qtyp, equiv_rel, equiv_thm, ...} = |
743 |
Quotient_Info.quotdata_lookup thy s |
|
744 |
val partial = |
|
745 |
case prop_of equiv_thm of |
|
746 |
@{const Trueprop} $ (Const (@{const_name equivp}, _) $ _) => false |
|
747 |
| @{const Trueprop} $ (Const (@{const_name part_equivp}, _) $ _) => true |
|
748 |
| _ => raise NOT_SUPPORTED "Ill-formed quotient type equivalence \ |
|
749 |
\relation theorem" |
|
35284
9edc2bd6d2bd
enabled Nitpick's support for quotient types + shortened the Nitpick tests a bit
blanchet
parents:
35283
diff
changeset
|
750 |
val Ts' = qtyp |> dest_Type |> snd |
38243 | 751 |
in (subst_atomic_types (Ts' ~~ Ts) equiv_rel, partial) end |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
752 |
| equiv_relation_for_quot_type _ T = |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
753 |
raise TYPE ("Nitpick_HOL.equiv_relation_for_quot_type", [T], []) |
33192 | 754 |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
755 |
fun is_coconstr ctxt (s, T) = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
756 |
case body_type T of |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
757 |
co_T as Type (co_s, _) => |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
758 |
let val {codatatypes, ...} = Data.get (Context.Proof ctxt) in |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
759 |
exists (fn (s', T') => s = s' andalso repair_constr_type ctxt co_T T' = T) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
760 |
(AList.lookup (op =) codatatypes co_s |> Option.map snd |> these) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
761 |
end |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
762 |
| _ => false |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
763 |
fun is_constr_like ctxt (s, T) = |
41052
3db267a01c1d
remove the "fin_fun" optimization in Nitpick -- it was always a hack and didn't help much
blanchet
parents:
41049
diff
changeset
|
764 |
member (op =) [@{const_name FunBox}, @{const_name PairBox}, |
3db267a01c1d
remove the "fin_fun" optimization in Nitpick -- it was always a hack and didn't help much
blanchet
parents:
41049
diff
changeset
|
765 |
@{const_name Quot}, @{const_name Zero_Rep}, |
3db267a01c1d
remove the "fin_fun" optimization in Nitpick -- it was always a hack and didn't help much
blanchet
parents:
41049
diff
changeset
|
766 |
@{const_name Suc_Rep}] s orelse |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
767 |
let |
42361 | 768 |
val thy = Proof_Context.theory_of ctxt |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
769 |
val (x as (_, T)) = (s, unarize_unbox_etc_type T) |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
770 |
in |
37260
dde817e6dfb1
added "atoms" option to Nitpick (request from Karlsruhe) + wrap Refute. functions to "nitpick_util.ML"
blanchet
parents:
37258
diff
changeset
|
771 |
is_real_constr thy x orelse is_record_constr x orelse |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
772 |
(is_abs_fun ctxt x andalso is_pure_typedef ctxt (range_type T)) orelse |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
773 |
is_coconstr ctxt x |
33192 | 774 |
end |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
775 |
fun is_stale_constr ctxt (x as (_, T)) = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
776 |
is_codatatype ctxt (body_type T) andalso is_constr_like ctxt x andalso |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
777 |
not (is_coconstr ctxt x) |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
778 |
fun is_constr ctxt stds (x as (_, T)) = |
42361 | 779 |
let val thy = Proof_Context.theory_of ctxt in |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
780 |
is_constr_like ctxt x andalso |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
781 |
not (is_basic_datatype thy stds |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
782 |
(fst (dest_Type (unarize_type (body_type T))))) andalso |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
783 |
not (is_stale_constr ctxt x) |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
784 |
end |
33192 | 785 |
val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix |
786 |
val is_sel_like_and_no_discr = |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
787 |
String.isPrefix sel_prefix orf |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
788 |
(member (op =) [@{const_name fst}, @{const_name snd}]) |
33192 | 789 |
|
790 |
fun in_fun_lhs_for InConstr = InSel |
|
791 |
| in_fun_lhs_for _ = InFunLHS |
|
792 |
fun in_fun_rhs_for InConstr = InConstr |
|
793 |
| in_fun_rhs_for InSel = InSel |
|
794 |
| in_fun_rhs_for InFunRHS1 = InFunRHS2 |
|
795 |
| in_fun_rhs_for _ = InFunRHS1 |
|
796 |
||
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
797 |
fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T = |
33192 | 798 |
case T of |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
799 |
Type (@{type_name fun}, _) => |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
800 |
(boxy = InPair orelse boxy = InFunLHS) andalso |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
801 |
not (is_boolean_type (body_type T)) |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
802 |
| Type (@{type_name prod}, Ts) => |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
803 |
boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
804 |
((boxy = InExpr orelse boxy = InFunLHS) andalso |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
805 |
exists (is_boxing_worth_it hol_ctxt InPair) |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
806 |
(map (box_type hol_ctxt InPair) Ts)) |
33192 | 807 |
| _ => false |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
808 |
and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy z = |
33192 | 809 |
case triple_lookup (type_match thy) boxes (Type z) of |
810 |
SOME (SOME box_me) => box_me |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
811 |
| _ => is_boxing_worth_it hol_ctxt boxy (Type z) |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
812 |
and box_type hol_ctxt boxy T = |
33192 | 813 |
case T of |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
814 |
Type (z as (@{type_name fun}, [T1, T2])) => |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
815 |
if boxy <> InConstr andalso boxy <> InSel andalso |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
816 |
should_box_type hol_ctxt boxy z then |
33192 | 817 |
Type (@{type_name fun_box}, |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
818 |
[box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2]) |
33192 | 819 |
else |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
820 |
box_type hol_ctxt (in_fun_lhs_for boxy) T1 |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
821 |
--> box_type hol_ctxt (in_fun_rhs_for boxy) T2 |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
822 |
| Type (z as (@{type_name prod}, Ts)) => |
34982
7b8c366e34a2
added support for nonstandard models to Nitpick (based on an idea by Koen Claessen) and did other fixes to Nitpick
blanchet
parents:
34936
diff
changeset
|
823 |
if boxy <> InConstr andalso boxy <> InSel |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
824 |
andalso should_box_type hol_ctxt boxy z then |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
825 |
Type (@{type_name pair_box}, map (box_type hol_ctxt InSel) Ts) |
33192 | 826 |
else |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
827 |
Type (@{type_name prod}, |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
828 |
map (box_type hol_ctxt |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
829 |
(if boxy = InConstr orelse boxy = InSel then boxy |
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
830 |
else InPair)) Ts) |
33192 | 831 |
| _ => T |
832 |
||
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
833 |
fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"} |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
834 |
| binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"} |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
835 |
| binarize_nat_and_int_in_type (Type (s, Ts)) = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
836 |
Type (s, map binarize_nat_and_int_in_type Ts) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
837 |
| binarize_nat_and_int_in_type T = T |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
838 |
val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
839 |
|
33192 | 840 |
fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T) |
841 |
||
842 |
fun num_sels_for_constr_type T = length (maybe_curried_binder_types T) |
|
843 |
fun nth_sel_name_for_constr_name s n = |
|
844 |
if s = @{const_name Pair} then |
|
845 |
if n = 0 then @{const_name fst} else @{const_name snd} |
|
846 |
else |
|
847 |
sel_prefix_for n ^ s |
|
848 |
fun nth_sel_for_constr x ~1 = discr_for_constr x |
|
849 |
| nth_sel_for_constr (s, T) n = |
|
850 |
(nth_sel_name_for_constr_name s n, |
|
851 |
body_type T --> nth (maybe_curried_binder_types T) n) |
|
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
852 |
fun binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
853 |
apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InSel) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
854 |
oo nth_sel_for_constr |
33192 | 855 |
|
856 |
fun sel_no_from_name s = |
|
857 |
if String.isPrefix discr_prefix s then |
|
858 |
~1 |
|
859 |
else if String.isPrefix sel_prefix s then |
|
860 |
s |> unprefix sel_prefix |> Int.fromString |> the |
|
861 |
else if s = @{const_name snd} then |
|
862 |
1 |
|
863 |
else |
|
864 |
0 |
|
865 |
||
35078
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
866 |
val close_form = |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
867 |
let |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
868 |
fun close_up zs zs' = |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
869 |
fold (fn (z as ((s, _), T)) => fn t' => |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
870 |
Term.all T $ Abs (s, T, abstract_over (Var z, t'))) |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
871 |
(take (length zs' - length zs) zs') |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
872 |
fun aux zs (@{const "==>"} $ t1 $ t2) = |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
873 |
let val zs' = Term.add_vars t1 zs in |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
874 |
close_up zs zs' (Logic.mk_implies (t1, aux zs' t2)) |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
875 |
end |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
876 |
| aux zs t = close_up zs (Term.add_vars t zs) t |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
877 |
in aux [] end |
6fd1052fe463
optimization to quantifiers in Nitpick's handling of simp rules + renamed some SAT solvers
blanchet
parents:
35075
diff
changeset
|
878 |
|
33192 | 879 |
fun distinctness_formula T = |
880 |
all_distinct_unordered_pairs_of |
|
881 |
#> map (fn (t1, t2) => @{const Not} $ (HOLogic.eq_const T $ t1 $ t2)) |
|
882 |
#> List.foldr (s_conj o swap) @{const True} |
|
883 |
||
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
884 |
fun zero_const T = Const (@{const_name zero_class.zero}, T) |
33192 | 885 |
fun suc_const T = Const (@{const_name Suc}, T --> T) |
886 |
||
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
887 |
fun uncached_datatype_constrs ({thy, ctxt, stds, ...} : hol_context) |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
888 |
(T as Type (s, Ts)) = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
889 |
(case AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt))) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
890 |
s of |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
891 |
SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type ctxt T)) xs' |
33581
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
892 |
| _ => |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
893 |
if is_datatype ctxt stds T then |
33581
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
894 |
case Datatype.get_info thy s of |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
895 |
SOME {index, descr, ...} => |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
896 |
let |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
897 |
val (_, dtyps, constrs) = AList.lookup (op =) descr index |> the |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
898 |
in |
37260
dde817e6dfb1
added "atoms" option to Nitpick (request from Karlsruhe) + wrap Refute. functions to "nitpick_util.ML"
blanchet
parents:
37258
diff
changeset
|
899 |
map (apsnd (fn Us => |
dde817e6dfb1
added "atoms" option to Nitpick (request from Karlsruhe) + wrap Refute. functions to "nitpick_util.ML"
blanchet
parents:
37258
diff
changeset
|
900 |
map (typ_of_dtyp descr (dtyps ~~ Ts)) Us ---> T)) |
dde817e6dfb1
added "atoms" option to Nitpick (request from Karlsruhe) + wrap Refute. functions to "nitpick_util.ML"
blanchet
parents:
37258
diff
changeset
|
901 |
constrs |
33581
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
902 |
end |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
903 |
| NONE => |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
904 |
if is_record_type T then |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
905 |
let |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
906 |
val s' = unsuffix Record.ext_typeN s ^ Record.extN |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
907 |
val T' = (Record.get_extT_fields thy T |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
908 |
|> apsnd single |> uncurry append |> map snd) ---> T |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
909 |
in [(s', T')] end |
38215
1c7d7eaebdf2
quotient types registered as codatatypes are no longer quotient types
blanchet
parents:
38212
diff
changeset
|
910 |
else if is_real_quot_type thy T then |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
911 |
[(@{const_name Quot}, rep_type_for_quot_type thy T --> T)] |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
912 |
else case typedef_info ctxt s of |
33581
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
913 |
SOME {abs_type, rep_type, Abs_name, ...} => |
35311 | 914 |
[(Abs_name, |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
915 |
varify_and_instantiate_type ctxt abs_type T rep_type --> T)] |
33581
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
916 |
| NONE => |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
917 |
if T = @{typ ind} then |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
918 |
[dest_Const @{const Zero_Rep}, dest_Const @{const Suc_Rep}] |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
919 |
else |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
920 |
[] |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
921 |
else |
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
922 |
[]) |
33580
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
923 |
| uncached_datatype_constrs _ _ = [] |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
924 |
fun datatype_constrs (hol_ctxt as {constr_cache, ...}) T = |
33580
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
925 |
case AList.lookup (op =) (!constr_cache) T of |
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
926 |
SOME xs => xs |
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
927 |
| NONE => |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
928 |
let val xs = uncached_datatype_constrs hol_ctxt T in |
33580
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
929 |
(Unsynchronized.change constr_cache (cons (T, xs)); xs) |
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
930 |
end |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
931 |
fun binarized_and_boxed_datatype_constrs hol_ctxt binarize = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
932 |
map (apsnd ((binarize ? binarize_nat_and_int_in_type) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
933 |
o box_type hol_ctxt InConstr)) o datatype_constrs hol_ctxt |
33192 | 934 |
val num_datatype_constrs = length oo datatype_constrs |
935 |
||
936 |
fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair} |
|
937 |
| constr_name_for_sel_like @{const_name snd} = @{const_name Pair} |
|
938 |
| constr_name_for_sel_like s' = original_name s' |
|
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
939 |
fun binarized_and_boxed_constr_for_sel hol_ctxt binarize (s', T') = |
33192 | 940 |
let val s = constr_name_for_sel_like s' in |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
941 |
AList.lookup (op =) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
942 |
(binarized_and_boxed_datatype_constrs hol_ctxt binarize (domain_type T')) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
943 |
s |
33192 | 944 |
|> the |> pair s |
945 |
end |
|
34982
7b8c366e34a2
added support for nonstandard models to Nitpick (based on an idea by Koen Claessen) and did other fixes to Nitpick
blanchet
parents:
34936
diff
changeset
|
946 |
|
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
947 |
fun card_of_type assigns (Type (@{type_name fun}, [T1, T2])) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
948 |
reasonable_power (card_of_type assigns T2) (card_of_type assigns T1) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
949 |
| card_of_type assigns (Type (@{type_name prod}, [T1, T2])) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
950 |
card_of_type assigns T1 * card_of_type assigns T2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
951 |
| card_of_type _ (Type (@{type_name itself}, _)) = 1 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
952 |
| card_of_type _ @{typ prop} = 2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
953 |
| card_of_type _ @{typ bool} = 2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
954 |
| card_of_type assigns T = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
955 |
case AList.lookup (op =) assigns T of |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
956 |
SOME k => k |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
957 |
| NONE => if T = @{typ bisim_iterator} then 0 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
958 |
else raise TYPE ("Nitpick_HOL.card_of_type", [T], []) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
959 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
960 |
fun bounded_card_of_type max default_card assigns |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
961 |
(Type (@{type_name fun}, [T1, T2])) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
962 |
let |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
963 |
val k1 = bounded_card_of_type max default_card assigns T1 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
964 |
val k2 = bounded_card_of_type max default_card assigns T2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
965 |
in |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
966 |
if k1 = max orelse k2 = max then max |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
967 |
else Int.min (max, reasonable_power k2 k1) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
968 |
end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
969 |
| bounded_card_of_type max default_card assigns |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
970 |
(Type (@{type_name prod}, [T1, T2])) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
971 |
let |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
972 |
val k1 = bounded_card_of_type max default_card assigns T1 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
973 |
val k2 = bounded_card_of_type max default_card assigns T2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
974 |
in if k1 = max orelse k2 = max then max else Int.min (max, k1 * k2) end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
975 |
| bounded_card_of_type max default_card assigns T = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
976 |
Int.min (max, if default_card = ~1 then |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
977 |
card_of_type assigns T |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
978 |
else |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
979 |
card_of_type assigns T |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
980 |
handle TYPE ("Nitpick_HOL.card_of_type", _, _) => |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
981 |
default_card) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
982 |
|
42679 | 983 |
(* Similar to similarly named function in "Sledgehammer_ATP_Translate". *) |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
984 |
fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
985 |
assigns T = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
986 |
let |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
987 |
fun aux avoid T = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
988 |
(if member (op =) avoid T then |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
989 |
0 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
990 |
else if member (op =) finitizable_dataTs T then |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
991 |
raise SAME () |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
992 |
else case T of |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
993 |
Type (@{type_name fun}, [T1, T2]) => |
42679 | 994 |
(case (aux avoid T1, aux avoid T2) of |
995 |
(_, 1) => 1 |
|
996 |
| (0, _) => 0 |
|
997 |
| (_, 0) => 0 |
|
998 |
| (k1, k2) => |
|
999 |
if k1 >= max orelse k2 >= max then max |
|
1000 |
else Int.min (max, reasonable_power k2 k1)) |
|
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1001 |
| Type (@{type_name prod}, [T1, T2]) => |
42679 | 1002 |
(case (aux avoid T1, aux avoid T2) of |
1003 |
(0, _) => 0 |
|
1004 |
| (_, 0) => 0 |
|
1005 |
| (k1, k2) => |
|
1006 |
if k1 >= max orelse k2 >= max then max |
|
1007 |
else Int.min (max, k1 * k2)) |
|
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1008 |
| Type (@{type_name itself}, _) => 1 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1009 |
| @{typ prop} => 2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1010 |
| @{typ bool} => 2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1011 |
| Type _ => |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1012 |
(case datatype_constrs hol_ctxt T of |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1013 |
[] => if is_integer_type T orelse is_bit_type T then 0 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1014 |
else raise SAME () |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1015 |
| constrs => |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1016 |
let |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1017 |
val constr_cards = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1018 |
map (Integer.prod o map (aux (T :: avoid)) o binder_types o snd) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1019 |
constrs |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1020 |
in |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1021 |
if exists (curry (op =) 0) constr_cards then 0 |
42679 | 1022 |
else Int.min (max, Integer.sum constr_cards) |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1023 |
end) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1024 |
| _ => raise SAME ()) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1025 |
handle SAME () => |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1026 |
AList.lookup (op =) assigns T |> the_default default_card |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1027 |
in Int.min (max, aux [] T) end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1028 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1029 |
val typical_atomic_card = 4 |
41898
55d981e1232a
improved formula for specialization, to prevent needless specializations -- and removed dead code
blanchet
parents:
41876
diff
changeset
|
1030 |
val typical_card_of_type = bounded_card_of_type 16777217 typical_atomic_card [] |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1031 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1032 |
fun is_finite_type hol_ctxt T = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1033 |
bounded_exact_card_of_type hol_ctxt [] 1 2 [] T > 0 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1034 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1035 |
fun is_special_eligible_arg strict Ts t = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1036 |
case map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) of |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1037 |
[] => true |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1038 |
| bad_Ts => |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1039 |
let |
41898
55d981e1232a
improved formula for specialization, to prevent needless specializations -- and removed dead code
blanchet
parents:
41876
diff
changeset
|
1040 |
val bad_Ts_cost = |
55d981e1232a
improved formula for specialization, to prevent needless specializations -- and removed dead code
blanchet
parents:
41876
diff
changeset
|
1041 |
if strict then fold (curry (op *) o typical_card_of_type) bad_Ts 1 |
55d981e1232a
improved formula for specialization, to prevent needless specializations -- and removed dead code
blanchet
parents:
41876
diff
changeset
|
1042 |
else fold (Integer.max o typical_card_of_type) bad_Ts 0 |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1043 |
val T_cost = typical_card_of_type (fastype_of1 (Ts, t)) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1044 |
in (bad_Ts_cost, T_cost) |> (if strict then op < else op <=) end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1045 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1046 |
fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body)) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1047 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1048 |
fun let_var s = (nitpick_prefix ^ s, 999) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1049 |
val let_inline_threshold = 20 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1050 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1051 |
fun s_let Ts s n abs_T body_T f t = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1052 |
if (n - 1) * (size_of_term t - 1) <= let_inline_threshold orelse |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1053 |
is_special_eligible_arg false Ts t then |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1054 |
f t |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1055 |
else |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1056 |
let val z = (let_var s, abs_T) in |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1057 |
Const (@{const_name Let}, abs_T --> (abs_T --> body_T) --> body_T) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1058 |
$ t $ abs_var z (incr_boundvars 1 (f (Var z))) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1059 |
end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1060 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1061 |
fun loose_bvar1_count (Bound i, k) = if i = k then 1 else 0 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1062 |
| loose_bvar1_count (t1 $ t2, k) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1063 |
loose_bvar1_count (t1, k) + loose_bvar1_count (t2, k) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1064 |
| loose_bvar1_count (Abs (_, _, t), k) = loose_bvar1_count (t, k + 1) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1065 |
| loose_bvar1_count _ = 0 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1066 |
|
42414
9465651c0db7
optimize trivial equalities early in Nitpick -- it shouldn't be the job of the peephole optimizer
blanchet
parents:
42361
diff
changeset
|
1067 |
fun s_betapply _ (t1 as Const (@{const_name "=="}, _) $ t1', t2) = |
9465651c0db7
optimize trivial equalities early in Nitpick -- it shouldn't be the job of the peephole optimizer
blanchet
parents:
42361
diff
changeset
|
1068 |
if t1' aconv t2 then @{prop True} else t1 $ t2 |
9465651c0db7
optimize trivial equalities early in Nitpick -- it shouldn't be the job of the peephole optimizer
blanchet
parents:
42361
diff
changeset
|
1069 |
| s_betapply _ (t1 as Const (@{const_name HOL.eq}, _) $ t1', t2) = |
9465651c0db7
optimize trivial equalities early in Nitpick -- it shouldn't be the job of the peephole optimizer
blanchet
parents:
42361
diff
changeset
|
1070 |
if t1' aconv t2 then @{term True} else t1 $ t2 |
9465651c0db7
optimize trivial equalities early in Nitpick -- it shouldn't be the job of the peephole optimizer
blanchet
parents:
42361
diff
changeset
|
1071 |
| s_betapply _ (Const (@{const_name If}, _) $ @{const True} $ t1', _) = t1' |
41860
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1072 |
| s_betapply _ (Const (@{const_name If}, _) $ @{const False} $ _, t2) = t2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1073 |
| s_betapply Ts (Const (@{const_name Let}, |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1074 |
Type (_, [bound_T, Type (_, [_, body_T])])) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1075 |
$ t12 $ Abs (s, T, t13'), t2) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1076 |
let val body_T' = range_type body_T in |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1077 |
Const (@{const_name Let}, bound_T --> (bound_T --> body_T') --> body_T') |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1078 |
$ t12 $ Abs (s, T, s_betapply (T :: Ts) (t13', incr_boundvars 1 t2)) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1079 |
end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1080 |
| s_betapply Ts (t1 as Abs (s1, T1, t1'), t2) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1081 |
(s_let Ts s1 (loose_bvar1_count (t1', 0)) T1 (fastype_of1 (T1 :: Ts, t1')) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1082 |
(curry betapply t1) t2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1083 |
handle TERM _ => betapply (t1, t2)) (* FIXME: fix all uses *) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1084 |
| s_betapply _ (t1, t2) = t1 $ t2 |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1085 |
fun s_betapplys Ts = Library.foldl (s_betapply Ts) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1086 |
|
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1087 |
fun s_beta_norm Ts t = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1088 |
let |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1089 |
fun aux _ (Var _) = raise Same.SAME |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1090 |
| aux Ts (Abs (s, T, t')) = Abs (s, T, aux (T :: Ts) t') |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1091 |
| aux Ts ((t1 as Abs _) $ t2) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1092 |
Same.commit (aux Ts) (s_betapply Ts (t1, t2)) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1093 |
| aux Ts (t1 $ t2) = |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1094 |
((case aux Ts t1 of |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1095 |
t1 as Abs _ => Same.commit (aux Ts) (s_betapply Ts (t1, t2)) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1096 |
| t1 => t1 $ Same.commit (aux Ts) t2) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1097 |
handle Same.SAME => t1 $ aux Ts t2) |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1098 |
| aux _ _ = raise Same.SAME |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1099 |
in aux Ts t handle Same.SAME => t end |
49d0fc8c418c
improved "is_special_eligible_arg" further, by approximating the cardinality of the argument (as is done quite successfully elsewhere)
blanchet
parents:
41859
diff
changeset
|
1100 |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1101 |
fun discr_term_for_constr hol_ctxt (x as (s, T)) = |
33192 | 1102 |
let val dataT = body_type T in |
1103 |
if s = @{const_name Suc} then |
|
1104 |
Abs (Name.uu, dataT, |
|
1105 |
@{const Not} $ HOLogic.mk_eq (zero_const dataT, Bound 0)) |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1106 |
else if num_datatype_constrs hol_ctxt dataT >= 2 then |
33192 | 1107 |
Const (discr_for_constr x) |
1108 |
else |
|
1109 |
Abs (Name.uu, dataT, @{const True}) |
|
1110 |
end |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1111 |
fun discriminate_value (hol_ctxt as {ctxt, ...}) x t = |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1112 |
case head_of t of |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1113 |
Const x' => |
33192 | 1114 |
if x = x' then @{const True} |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1115 |
else if is_constr_like ctxt x' then @{const False} |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1116 |
else s_betapply [] (discr_term_for_constr hol_ctxt x, t) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1117 |
| _ => s_betapply [] (discr_term_for_constr hol_ctxt x, t) |
33192 | 1118 |
|
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1119 |
fun nth_arg_sel_term_for_constr thy stds (x as (s, T)) n = |
33192 | 1120 |
let val (arg_Ts, dataT) = strip_type T in |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1121 |
if dataT = nat_T andalso is_standard_datatype thy stds nat_T then |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1122 |
@{term "%n::nat. n - 1"} |
33192 | 1123 |
else if is_pair_type dataT then |
1124 |
Const (nth_sel_for_constr x n) |
|
1125 |
else |
|
1126 |
let |
|
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
1127 |
fun aux m (Type (@{type_name prod}, [T1, T2])) = |
33192 | 1128 |
let |
1129 |
val (m, t1) = aux m T1 |
|
1130 |
val (m, t2) = aux m T2 |
|
1131 |
in (m, HOLogic.mk_prod (t1, t2)) end |
|
1132 |
| aux m T = |
|
1133 |
(m + 1, Const (nth_sel_name_for_constr_name s m, dataT --> T) |
|
1134 |
$ Bound 0) |
|
1135 |
val m = fold (Integer.add o num_factors_in_type) |
|
1136 |
(List.take (arg_Ts, n)) 0 |
|
1137 |
in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end |
|
1138 |
end |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1139 |
fun select_nth_constr_arg ctxt stds x t n res_T = |
42361 | 1140 |
let val thy = Proof_Context.theory_of ctxt in |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1141 |
(case strip_comb t of |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1142 |
(Const x', args) => |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1143 |
if x = x' then nth args n |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1144 |
else if is_constr_like ctxt x' then Const (@{const_name unknown}, res_T) |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1145 |
else raise SAME () |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1146 |
| _ => raise SAME()) |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1147 |
handle SAME () => |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1148 |
s_betapply [] (nth_arg_sel_term_for_constr thy stds x n, t) |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1149 |
end |
33192 | 1150 |
|
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1151 |
fun construct_value _ _ x [] = Const x |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1152 |
| construct_value ctxt stds (x as (s, _)) args = |
33192 | 1153 |
let val args = map Envir.eta_contract args in |
1154 |
case hd args of |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1155 |
Const (s', _) $ t => |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1156 |
if is_sel_like_and_no_discr s' andalso |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1157 |
constr_name_for_sel_like s' = s andalso |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1158 |
forall (fn (n, t') => |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1159 |
select_nth_constr_arg ctxt stds x t n dummyT = t') |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1160 |
(index_seq 0 (length args) ~~ args) then |
33192 | 1161 |
t |
1162 |
else |
|
1163 |
list_comb (Const x, args) |
|
1164 |
| _ => list_comb (Const x, args) |
|
1165 |
end |
|
1166 |
||
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1167 |
fun constr_expand (hol_ctxt as {ctxt, stds, ...}) T t = |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1168 |
(case head_of t of |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1169 |
Const x => if is_constr_like ctxt x then t else raise SAME () |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1170 |
| _ => raise SAME ()) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1171 |
handle SAME () => |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1172 |
let |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1173 |
val x' as (_, T') = |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1174 |
if is_pair_type T then |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1175 |
let val (T1, T2) = HOLogic.dest_prodT T in |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1176 |
(@{const_name Pair}, T1 --> T2 --> T) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1177 |
end |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1178 |
else |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1179 |
datatype_constrs hol_ctxt T |> hd |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1180 |
val arg_Ts = binder_types T' |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1181 |
in |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1182 |
list_comb (Const x', map2 (select_nth_constr_arg ctxt stds x' t) |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1183 |
(index_seq 0 (length arg_Ts)) arg_Ts) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1184 |
end |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1185 |
|
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1186 |
fun coerce_bound_no f j t = |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1187 |
case t of |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1188 |
t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2 |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1189 |
| Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t') |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1190 |
| Bound j' => if j' = j then f t else t |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1191 |
| _ => t |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1192 |
fun coerce_bound_0_in_term hol_ctxt new_T old_T = |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1193 |
old_T <> new_T ? coerce_bound_no (coerce_term hol_ctxt [new_T] old_T new_T) 0 |
39345 | 1194 |
and coerce_term (hol_ctxt as {ctxt, stds, ...}) Ts new_T old_T t = |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1195 |
if old_T = new_T then |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1196 |
t |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1197 |
else |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1198 |
case (new_T, old_T) of |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1199 |
(Type (new_s, new_Ts as [new_T1, new_T2]), |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1200 |
Type (@{type_name fun}, [old_T1, old_T2])) => |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1201 |
(case eta_expand Ts t 1 of |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1202 |
Abs (s, _, t') => |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1203 |
Abs (s, new_T1, |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1204 |
t' |> coerce_bound_0_in_term hol_ctxt new_T1 old_T1 |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1205 |
|> coerce_term hol_ctxt (new_T1 :: Ts) new_T2 old_T2) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1206 |
|> Envir.eta_contract |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1207 |
|> new_s <> @{type_name fun} |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1208 |
? construct_value ctxt stds |
41052
3db267a01c1d
remove the "fin_fun" optimization in Nitpick -- it was always a hack and didn't help much
blanchet
parents:
41049
diff
changeset
|
1209 |
(@{const_name FunBox}, |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1210 |
Type (@{type_name fun}, new_Ts) --> new_T) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1211 |
o single |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1212 |
| t' => raise TERM ("Nitpick_HOL.coerce_term", [t'])) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1213 |
| (Type (new_s, new_Ts as [new_T1, new_T2]), |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1214 |
Type (old_s, old_Ts as [old_T1, old_T2])) => |
41052
3db267a01c1d
remove the "fin_fun" optimization in Nitpick -- it was always a hack and didn't help much
blanchet
parents:
41049
diff
changeset
|
1215 |
if old_s = @{type_name fun_box} orelse |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
1216 |
old_s = @{type_name pair_box} orelse old_s = @{type_name prod} then |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1217 |
case constr_expand hol_ctxt old_T t of |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1218 |
Const (old_s, _) $ t1 => |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1219 |
if new_s = @{type_name fun} then |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1220 |
coerce_term hol_ctxt Ts new_T (Type (@{type_name fun}, old_Ts)) t1 |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1221 |
else |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1222 |
construct_value ctxt stds |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1223 |
(old_s, Type (@{type_name fun}, new_Ts) --> new_T) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1224 |
[coerce_term hol_ctxt Ts (Type (@{type_name fun}, new_Ts)) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1225 |
(Type (@{type_name fun}, old_Ts)) t1] |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1226 |
| Const _ $ t1 $ t2 => |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1227 |
construct_value ctxt stds |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
1228 |
(if new_s = @{type_name prod} then @{const_name Pair} |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1229 |
else @{const_name PairBox}, new_Ts ---> new_T) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1230 |
(map3 (coerce_term hol_ctxt Ts) [new_T1, new_T2] [old_T1, old_T2] |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1231 |
[t1, t2]) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1232 |
| t' => raise TERM ("Nitpick_HOL.coerce_term", [t']) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1233 |
else |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1234 |
raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t]) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1235 |
| _ => raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t]) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1236 |
|
33192 | 1237 |
fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2 |
1238 |
| is_ground_term (Const _) = true |
|
1239 |
| is_ground_term _ = false |
|
1240 |
||
36062 | 1241 |
fun hashw_term (t1 $ t2) = hashw (hashw_term t1, hashw_term t2) |
1242 |
| hashw_term (Const (s, _)) = hashw_string (s, 0w0) |
|
33192 | 1243 |
| hashw_term _ = 0w0 |
1244 |
val hash_term = Word.toInt o hashw_term |
|
1245 |
||
1246 |
fun special_bounds ts = |
|
35408 | 1247 |
fold Term.add_vars ts [] |> sort (Term_Ord.fast_indexname_ord o pairself fst) |
33192 | 1248 |
|
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
1249 |
(* FIXME: detect "rep_datatype"? *) |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1250 |
fun is_funky_typedef_name ctxt s = |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
1251 |
member (op =) [@{type_name unit}, @{type_name prod}, |
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
1252 |
@{type_name Sum_Type.sum}, @{type_name int}] s orelse |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1253 |
is_frac_type ctxt (Type (s, [])) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1254 |
fun is_funky_typedef ctxt (Type (s, _)) = is_funky_typedef_name ctxt s |
33571 | 1255 |
| is_funky_typedef _ _ = false |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1256 |
fun is_typedef_axiom ctxt boring (@{const "==>"} $ _ $ t2) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1257 |
is_typedef_axiom ctxt boring t2 |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1258 |
| is_typedef_axiom ctxt boring |
33192 | 1259 |
(@{const Trueprop} $ (Const (@{const_name Typedef.type_definition}, _) |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1260 |
$ Const (_, Type (@{type_name fun}, [Type (s, _), _])) |
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1261 |
$ Const _ $ _)) = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1262 |
boring <> is_funky_typedef_name ctxt s andalso is_typedef ctxt s |
33192 | 1263 |
| is_typedef_axiom _ _ _ = false |
1264 |
||
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1265 |
fun all_defs_of thy subst = |
33192 | 1266 |
let |
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1267 |
val def_names = |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1268 |
thy |> Theory.defs_of |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1269 |
|> Defs.all_specifications_of |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1270 |
|> maps snd |> map_filter #def |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1271 |
|> Ord_List.make fast_string_ord |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1272 |
in |
42425 | 1273 |
Theory.nodes_of thy |
42418
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1274 |
|> maps Thm.axioms_of |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1275 |
|> map (apsnd (subst_atomic subst o prop_of)) |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1276 |
|> sort (fast_string_ord o pairself fst) |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1277 |
|> Ord_List.inter (fast_string_ord o apsnd fst) def_names |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1278 |
|> map snd |
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1279 |
end |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1280 |
|
42418
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1281 |
(* Ideally we would check against "Complex_Main", not "Refute", but any theory |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1282 |
will do as long as it contains all the "axioms" and "axiomatization" |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1283 |
commands. *) |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1284 |
fun is_built_in_theory thy = Theory.subthy (thy, @{theory Refute}) |
508acf776ebf
avoid relying on "Thm.definitionK" to pick up definitions -- this was an old hack related to locales (to avoid expanding locale constants to their low-level definition) that is no longer necessary
blanchet
parents:
42415
diff
changeset
|
1285 |
|
42415
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1286 |
fun all_nondefs_of ctxt subst = |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1287 |
ctxt |> Spec_Rules.get |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1288 |
|> filter (curry (op =) Spec_Rules.Unknown o fst) |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1289 |
|> maps (snd o snd) |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1290 |
|> filter_out (is_built_in_theory o theory_of_thm) |
10accf397ab6
use "Spec_Rules" for finding axioms -- more reliable and cleaner
blanchet
parents:
42414
diff
changeset
|
1291 |
|> map (subst_atomic subst o prop_of) |
33192 | 1292 |
|
39359 | 1293 |
fun arity_of_built_in_const thy stds (s, T) = |
33192 | 1294 |
if s = @{const_name If} then |
1295 |
if nth_range_type 3 T = @{typ bool} then NONE else SOME 3 |
|
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1296 |
else |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1297 |
let val std_nats = is_standard_datatype thy stds nat_T in |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1298 |
case AList.lookup (op =) |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1299 |
(built_in_consts |
39359 | 1300 |
|> std_nats ? append built_in_nat_consts) s of |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1301 |
SOME n => SOME n |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1302 |
| NONE => |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1303 |
case AList.lookup (op =) |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1304 |
(built_in_typed_consts |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1305 |
|> std_nats ? append built_in_typed_nat_consts) |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1306 |
(s, unarize_type T) of |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1307 |
SOME n => SOME n |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1308 |
| NONE => |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1309 |
case s of |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1310 |
@{const_name zero_class.zero} => |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1311 |
if is_iterator_type T then SOME 0 else NONE |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1312 |
| @{const_name Suc} => |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1313 |
if is_iterator_type (domain_type T) then SOME 0 else NONE |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1314 |
| _ => if is_fun_type T andalso is_set_type (domain_type T) then |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1315 |
AList.lookup (op =) built_in_set_consts s |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1316 |
else |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1317 |
NONE |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1318 |
end |
39359 | 1319 |
val is_built_in_const = is_some ooo arity_of_built_in_const |
33192 | 1320 |
|
1321 |
(* This function is designed to work for both real definition axioms and |
|
1322 |
simplification rules (equational specifications). *) |
|
1323 |
fun term_under_def t = |
|
1324 |
case t of |
|
1325 |
@{const "==>"} $ _ $ t2 => term_under_def t2 |
|
1326 |
| Const (@{const_name "=="}, _) $ t1 $ _ => term_under_def t1 |
|
1327 |
| @{const Trueprop} $ t1 => term_under_def t1 |
|
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
1328 |
| Const (@{const_name HOL.eq}, _) $ t1 $ _ => term_under_def t1 |
33192 | 1329 |
| Abs (_, _, t') => term_under_def t' |
1330 |
| t1 $ _ => term_under_def t1 |
|
1331 |
| _ => t |
|
1332 |
||
36555
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1333 |
(* Here we crucially rely on "specialize_type" performing a preorder traversal |
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1334 |
of the term, without which the wrong occurrence of a constant could be |
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1335 |
matched in the face of overloading. *) |
39359 | 1336 |
fun def_props_for_const thy stds table (x as (s, _)) = |
1337 |
if is_built_in_const thy stds x then |
|
33192 | 1338 |
[] |
1339 |
else |
|
1340 |
these (Symtab.lookup table s) |
|
36555
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1341 |
|> map_filter (try (specialize_type thy x)) |
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
1342 |
|> filter (curry (op =) (Const x) o term_under_def) |
33192 | 1343 |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1344 |
fun normalized_rhs_of t = |
33192 | 1345 |
let |
33743
a58893035742
made "NitpickHOL.normalized_rhs_of" more robust in the face of locale definitions
blanchet
parents:
33706
diff
changeset
|
1346 |
fun aux (v as Var _) (SOME t) = SOME (lambda v t) |
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1347 |
| aux (c as Const (@{const_name TYPE}, _)) (SOME t) = SOME (lambda c t) |
33743
a58893035742
made "NitpickHOL.normalized_rhs_of" more robust in the face of locale definitions
blanchet
parents:
33706
diff
changeset
|
1348 |
| aux _ _ = NONE |
33192 | 1349 |
val (lhs, rhs) = |
1350 |
case t of |
|
1351 |
Const (@{const_name "=="}, _) $ t1 $ t2 => (t1, t2) |
|
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
1352 |
| @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ t1 $ t2) => |
33192 | 1353 |
(t1, t2) |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
1354 |
| _ => raise TERM ("Nitpick_HOL.normalized_rhs_of", [t]) |
33192 | 1355 |
val args = strip_comb lhs |> snd |
33743
a58893035742
made "NitpickHOL.normalized_rhs_of" more robust in the face of locale definitions
blanchet
parents:
33706
diff
changeset
|
1356 |
in fold_rev aux args (SOME rhs) end |
33192 | 1357 |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1358 |
fun get_def_of_const thy table (x as (s, _)) = |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1359 |
x |> def_props_for_const thy [(NONE, false)] table |> List.last |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1360 |
|> normalized_rhs_of |> Option.map (prefix_abs_vars s) |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1361 |
handle List.Empty => NONE |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1362 |
|
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1363 |
fun def_of_const_ext thy (unfold_table, fallback_table) (x as (s, _)) = |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1364 |
if is_built_in_const thy [(NONE, false)] x orelse original_name s <> s then |
33192 | 1365 |
NONE |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1366 |
else case get_def_of_const thy unfold_table x of |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1367 |
SOME def => SOME (true, def) |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1368 |
| NONE => get_def_of_const thy fallback_table x |> Option.map (pair false) |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1369 |
|
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1370 |
val def_of_const = Option.map snd ooo def_of_const_ext |
33192 | 1371 |
|
1372 |
fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t |
|
1373 |
| fixpoint_kind_of_rhs (Const (@{const_name lfp}, _) $ Abs _) = Lfp |
|
1374 |
| fixpoint_kind_of_rhs (Const (@{const_name gfp}, _) $ Abs _) = Gfp |
|
1375 |
| fixpoint_kind_of_rhs _ = NoFp |
|
1376 |
||
1377 |
fun is_mutually_inductive_pred_def thy table t = |
|
1378 |
let |
|
1379 |
fun is_good_arg (Bound _) = true |
|
1380 |
| is_good_arg (Const (s, _)) = |
|
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1381 |
s = @{const_name True} orelse s = @{const_name False} orelse |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1382 |
s = @{const_name undefined} |
33192 | 1383 |
| is_good_arg _ = false |
1384 |
in |
|
1385 |
case t |> strip_abs_body |> strip_comb of |
|
1386 |
(Const x, ts as (_ :: _)) => |
|
1387 |
(case def_of_const thy table x of |
|
38180
7a88032f9265
bump up the max cardinalities, to use up more of the time given to us by the user
blanchet
parents:
38174
diff
changeset
|
1388 |
SOME t' => fixpoint_kind_of_rhs t' <> NoFp andalso |
7a88032f9265
bump up the max cardinalities, to use up more of the time given to us by the user
blanchet
parents:
38174
diff
changeset
|
1389 |
forall is_good_arg ts |
33192 | 1390 |
| NONE => false) |
1391 |
| _ => false |
|
1392 |
end |
|
1393 |
fun unfold_mutually_inductive_preds thy table = |
|
1394 |
map_aterms (fn t as Const x => |
|
1395 |
(case def_of_const thy table x of |
|
1396 |
SOME t' => |
|
1397 |
let val t' = Envir.eta_contract t' in |
|
1398 |
if is_mutually_inductive_pred_def thy table t' then t' |
|
1399 |
else t |
|
1400 |
end |
|
1401 |
| NONE => t) |
|
1402 |
| t => t) |
|
1403 |
||
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1404 |
fun case_const_names ctxt stds = |
42361 | 1405 |
let val thy = Proof_Context.theory_of ctxt in |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1406 |
Symtab.fold (fn (dtype_s, {index, descr, case_name, ...}) => |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1407 |
if is_basic_datatype thy stds dtype_s then |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1408 |
I |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1409 |
else |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1410 |
cons (case_name, AList.lookup (op =) descr index |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1411 |
|> the |> #3 |> length)) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1412 |
(Datatype.get_all thy) [] @ |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1413 |
map (apsnd length o snd) (#codatatypes (Data.get (Context.Proof ctxt))) |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1414 |
end |
33192 | 1415 |
|
35718 | 1416 |
fun fixpoint_kind_of_const thy table x = |
39359 | 1417 |
if is_built_in_const thy [(NONE, false)] x then NoFp |
1418 |
else fixpoint_kind_of_rhs (the (def_of_const thy table x)) |
|
1419 |
handle Option.Option => NoFp |
|
33192 | 1420 |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1421 |
fun is_real_inductive_pred ({thy, stds, def_tables, intro_table, ...} |
39359 | 1422 |
: hol_context) x = |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1423 |
fixpoint_kind_of_const thy def_tables x <> NoFp andalso |
39359 | 1424 |
not (null (def_props_for_const thy stds intro_table x)) |
38205
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
1425 |
fun is_inductive_pred hol_ctxt (x as (s, _)) = |
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
1426 |
is_real_inductive_pred hol_ctxt x orelse String.isPrefix ubfp_prefix s orelse |
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
1427 |
String.isPrefix lbfp_prefix s |
33192 | 1428 |
|
35718 | 1429 |
fun lhs_of_equation t = |
1430 |
case t of |
|
1431 |
Const (@{const_name all}, _) $ Abs (_, _, t1) => lhs_of_equation t1 |
|
1432 |
| Const (@{const_name "=="}, _) $ t1 $ _ => SOME t1 |
|
1433 |
| @{const "==>"} $ _ $ t2 => lhs_of_equation t2 |
|
1434 |
| @{const Trueprop} $ t1 => lhs_of_equation t1 |
|
1435 |
| Const (@{const_name All}, _) $ Abs (_, _, t1) => lhs_of_equation t1 |
|
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
1436 |
| Const (@{const_name HOL.eq}, _) $ t1 $ _ => SOME t1 |
38786
e46e7a9cb622
formerly unnamed infix impliciation now named HOL.implies
haftmann
parents:
38652
diff
changeset
|
1437 |
| @{const HOL.implies} $ _ $ t2 => lhs_of_equation t2 |
35718 | 1438 |
| _ => NONE |
1439 |
fun is_constr_pattern _ (Bound _) = true |
|
1440 |
| is_constr_pattern _ (Var _) = true |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1441 |
| is_constr_pattern ctxt t = |
35718 | 1442 |
case strip_comb t of |
1443 |
(Const x, args) => |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1444 |
is_constr_like ctxt x andalso forall (is_constr_pattern ctxt) args |
35718 | 1445 |
| _ => false |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1446 |
fun is_constr_pattern_lhs ctxt t = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1447 |
forall (is_constr_pattern ctxt) (snd (strip_comb t)) |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1448 |
fun is_constr_pattern_formula ctxt t = |
35718 | 1449 |
case lhs_of_equation t of |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1450 |
SOME t' => is_constr_pattern_lhs ctxt t' |
35718 | 1451 |
| NONE => false |
1452 |
||
36555
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1453 |
(* Similar to "specialize_type" but returns all matches rather than only the |
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1454 |
first (preorder) match. *) |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1455 |
fun multi_specialize_type thy slack (s, T) t = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1456 |
let |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1457 |
fun aux (Const (s', T')) ys = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1458 |
if s = s' then |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1459 |
ys |> (if AList.defined (op =) ys T' then |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1460 |
I |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1461 |
else |
36555
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1462 |
cons (T', monomorphic_term (Sign.typ_match thy (T', T) |
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1463 |
Vartab.empty) t) |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1464 |
handle Type.TYPE_MATCH => I |
36575 | 1465 |
| TERM _ => |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1466 |
if slack then |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1467 |
I |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1468 |
else |
37253 | 1469 |
raise NOT_SUPPORTED |
1470 |
("too much polymorphism in axiom \"" ^ |
|
1471 |
Syntax.string_of_term_global thy t ^ |
|
1472 |
"\" involving " ^ quote s)) |
|
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1473 |
else |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1474 |
ys |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1475 |
| aux _ ys = ys |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1476 |
in map snd (fold_aterms aux t []) end |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1477 |
fun nondef_props_for_const thy slack table (x as (s, _)) = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1478 |
these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1479 |
|
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1480 |
fun unvarify_term (t1 $ t2) = unvarify_term t1 $ unvarify_term t2 |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1481 |
| unvarify_term (Var ((s, 0), T)) = Free (s, T) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1482 |
| unvarify_term (Abs (s, T, t')) = Abs (s, T, unvarify_term t') |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1483 |
| unvarify_term t = t |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1484 |
fun axiom_for_choice_spec thy = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1485 |
unvarify_term |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1486 |
#> Object_Logic.atomize_term thy |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1487 |
#> Choice_Specification.close_form |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1488 |
#> HOLogic.mk_Trueprop |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1489 |
fun is_choice_spec_fun ({thy, def_tables, nondef_table, choice_spec_table, ...} |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1490 |
: hol_context) x = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1491 |
case nondef_props_for_const thy true choice_spec_table x of |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1492 |
[] => false |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1493 |
| ts => case def_of_const thy def_tables x of |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1494 |
SOME (Const (@{const_name Eps}, _) $ _) => true |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1495 |
| SOME _ => false |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1496 |
| NONE => |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1497 |
let val ts' = nondef_props_for_const thy true nondef_table x in |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1498 |
length ts' = length ts andalso |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1499 |
forall (fn t => |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1500 |
exists (curry (op aconv) (axiom_for_choice_spec thy t)) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1501 |
ts') ts |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1502 |
end |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1503 |
|
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1504 |
fun is_choice_spec_axiom thy choice_spec_table t = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1505 |
Symtab.exists (fn (_, ts) => |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1506 |
exists (curry (op aconv) t o axiom_for_choice_spec thy) ts) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1507 |
choice_spec_table |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1508 |
|
39359 | 1509 |
fun is_real_equational_fun ({thy, stds, simp_table, psimp_table, ...} |
1510 |
: hol_context) x = |
|
1511 |
exists (fn table => not (null (def_props_for_const thy stds table x))) |
|
38205
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
1512 |
[!simp_table, psimp_table] |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1513 |
fun is_equational_fun_but_no_plain_def hol_ctxt = |
38205
37a7272cb453
handle inductive predicates correctly after change in "def" semantics
blanchet
parents:
38204
diff
changeset
|
1514 |
is_real_equational_fun hol_ctxt orf is_inductive_pred hol_ctxt |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1515 |
|
35718 | 1516 |
(** Constant unfolding **) |
33192 | 1517 |
|
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1518 |
fun constr_case_body ctxt stds (func_t, (x as (_, T))) = |
33192 | 1519 |
let val arg_Ts = binder_types T in |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1520 |
s_betapplys [] (func_t, map2 (select_nth_constr_arg ctxt stds x (Bound 0)) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1521 |
(index_seq 0 (length arg_Ts)) arg_Ts) |
33192 | 1522 |
end |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1523 |
fun add_constr_case res_T (body_t, guard_t) res_t = |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1524 |
if res_T = bool_T then |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1525 |
s_conj (HOLogic.mk_imp (guard_t, body_t), res_t) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1526 |
else |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1527 |
Const (@{const_name If}, bool_T --> res_T --> res_T --> res_T) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1528 |
$ guard_t $ body_t $ res_t |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1529 |
fun optimized_case_def (hol_ctxt as {ctxt, stds, ...}) dataT res_T func_ts = |
33192 | 1530 |
let |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1531 |
val xs = datatype_constrs hol_ctxt dataT |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1532 |
val cases = |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1533 |
func_ts ~~ xs |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1534 |
|> map (fn (func_t, x) => |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1535 |
(constr_case_body ctxt stds (incr_boundvars 1 func_t, x), |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1536 |
discriminate_value hol_ctxt x (Bound 0))) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1537 |
|> AList.group (op aconv) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1538 |
|> map (apsnd (List.foldl s_disj @{const False})) |
37482 | 1539 |
|> sort (int_ord o pairself (size_of_term o snd)) |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1540 |
|> rev |
33192 | 1541 |
in |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1542 |
if res_T = bool_T then |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1543 |
if forall (member (op =) [@{const False}, @{const True}] o fst) cases then |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1544 |
case cases of |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1545 |
[(body_t, _)] => body_t |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1546 |
| [_, (@{const True}, head_t2)] => head_t2 |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1547 |
| [_, (@{const False}, head_t2)] => @{const Not} $ head_t2 |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1548 |
| _ => raise BAD ("Nitpick_HOL.optimized_case_def", "impossible cases") |
39315
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
1549 |
else |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1550 |
@{const True} |> fold_rev (add_constr_case res_T) cases |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1551 |
else |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1552 |
fst (hd cases) |> fold_rev (add_constr_case res_T) (tl cases) |
33192 | 1553 |
end |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1554 |
|> curry absdummy dataT |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1555 |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1556 |
fun optimized_record_get (hol_ctxt as {thy, ctxt, stds, ...}) s rec_T res_T t = |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1557 |
let val constr_x = hd (datatype_constrs hol_ctxt rec_T) in |
33192 | 1558 |
case no_of_record_field thy s rec_T of |
1559 |
~1 => (case rec_T of |
|
1560 |
Type (_, Ts as _ :: _) => |
|
1561 |
let |
|
1562 |
val rec_T' = List.last Ts |
|
1563 |
val j = num_record_fields thy rec_T - 1 |
|
1564 |
in |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1565 |
select_nth_constr_arg ctxt stds constr_x t j res_T |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1566 |
|> optimized_record_get hol_ctxt s rec_T' res_T |
33192 | 1567 |
end |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
1568 |
| _ => raise TYPE ("Nitpick_HOL.optimized_record_get", [rec_T], |
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
1569 |
[])) |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1570 |
| j => select_nth_constr_arg ctxt stds constr_x t j res_T |
33192 | 1571 |
end |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1572 |
fun optimized_record_update (hol_ctxt as {thy, ctxt, stds, ...}) s rec_T fun_t |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1573 |
rec_t = |
33192 | 1574 |
let |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1575 |
val constr_x as (_, constr_T) = hd (datatype_constrs hol_ctxt rec_T) |
33192 | 1576 |
val Ts = binder_types constr_T |
1577 |
val n = length Ts |
|
1578 |
val special_j = no_of_record_field thy s rec_T |
|
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1579 |
val ts = |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1580 |
map2 (fn j => fn T => |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1581 |
let val t = select_nth_constr_arg ctxt stds constr_x rec_t j T in |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1582 |
if j = special_j then |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1583 |
s_betapply [] (fun_t, t) |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1584 |
else if j = n - 1 andalso special_j = ~1 then |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1585 |
optimized_record_update hol_ctxt s |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1586 |
(rec_T |> dest_Type |> snd |> List.last) fun_t t |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1587 |
else |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1588 |
t |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1589 |
end) (index_seq 0 n) Ts |
33192 | 1590 |
in list_comb (Const constr_x, ts) end |
1591 |
||
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1592 |
(* Prevents divergence in case of cyclic or infinite definition dependencies. *) |
33747
3aa6b9911252
bump up Nitpick's axiom/definition unfolding limits, because some real-world problems (e.g. from Boogie) ran into the previous limits;
blanchet
parents:
33743
diff
changeset
|
1593 |
val unfold_max_depth = 255 |
33192 | 1594 |
|
38206 | 1595 |
(* Inline definitions or define as an equational constant? Booleans tend to |
41871
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1596 |
benefit more from inlining, due to the polarity analysis. (However, if |
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1597 |
"total_consts" is set, the polarity analysis is likely not to be so |
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1598 |
crucial.) *) |
41793
c7a2669ae75d
tweaked Nitpick based on C++ memory model example
blanchet
parents:
41792
diff
changeset
|
1599 |
val def_inline_threshold_for_booleans = 60 |
38206 | 1600 |
val def_inline_threshold_for_non_booleans = 20 |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1601 |
|
38209 | 1602 |
fun unfold_defs_in_term |
41871
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1603 |
(hol_ctxt as {thy, ctxt, stds, whacks, total_consts, case_names, |
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1604 |
def_tables, ground_thm_table, ersatz_table, ...}) = |
33192 | 1605 |
let |
1606 |
fun do_term depth Ts t = |
|
1607 |
case t of |
|
1608 |
(t0 as Const (@{const_name Int.number_class.number_of}, |
|
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1609 |
Type (@{type_name fun}, [_, ran_T]))) $ t1 => |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1610 |
((if is_number_type ctxt ran_T then |
33192 | 1611 |
let |
1612 |
val j = t1 |> HOLogic.dest_numeral |
|
33882
9db7854eafc7
fix soundness bug in Nitpick's handling of negative literals (e.g., -1::rat)
blanchet
parents:
33879
diff
changeset
|
1613 |
|> ran_T = nat_T ? Integer.max 0 |
33192 | 1614 |
val s = numeral_prefix ^ signed_string_of_int j |
1615 |
in |
|
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1616 |
if is_integer_like_type ran_T then |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1617 |
if is_standard_datatype thy stds ran_T then |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1618 |
Const (s, ran_T) |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1619 |
else |
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1620 |
funpow j (curry (op $) (suc_const ran_T)) (zero_const ran_T) |
33192 | 1621 |
else |
1622 |
do_term depth Ts (Const (@{const_name of_int}, int_T --> ran_T) |
|
1623 |
$ Const (s, int_T)) |
|
1624 |
end |
|
1625 |
handle TERM _ => raise SAME () |
|
1626 |
else |
|
1627 |
raise SAME ()) |
|
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1628 |
handle SAME () => |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1629 |
s_betapply [] (do_term depth Ts t0, do_term depth Ts t1)) |
33864
232daf7eafaf
fix Nitpick soundness bugs related to integration (in particular, "code_numeral")
blanchet
parents:
33851
diff
changeset
|
1630 |
| Const (@{const_name refl_on}, T) $ Const (@{const_name top}, _) $ t2 => |
33192 | 1631 |
do_const depth Ts t (@{const_name refl'}, range_type T) [t2] |
41046 | 1632 |
| (t0 as Const (@{const_name Sigma}, Type (_, [T1, Type (_, [T2, T3])]))) |
1633 |
$ t1 $ (t2 as Abs (_, _, t2')) => |
|
1634 |
if loose_bvar1 (t2', 0) then |
|
1635 |
s_betapplys Ts (do_term depth Ts t0, map (do_term depth Ts) [t1, t2]) |
|
1636 |
else |
|
1637 |
do_term depth Ts |
|
1638 |
(Const (@{const_name prod}, T1 --> range_type T2 --> T3) |
|
1639 |
$ t1 $ incr_boundvars ~1 t2') |
|
33192 | 1640 |
| Const (x as (@{const_name distinct}, |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
1641 |
Type (@{type_name fun}, [Type (@{type_name list}, [T']), _]))) |
33192 | 1642 |
$ (t1 as _ $ _) => |
1643 |
(t1 |> HOLogic.dest_list |> distinctness_formula T' |
|
1644 |
handle TERM _ => do_const depth Ts t x [t1]) |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
1645 |
| Const (x as (@{const_name If}, _)) $ t1 $ t2 $ t3 => |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1646 |
if is_ground_term t1 andalso |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1647 |
exists (Pattern.matches thy o rpair t1) |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1648 |
(Inttab.lookup_list ground_thm_table (hash_term t1)) then |
33192 | 1649 |
do_term depth Ts t2 |
1650 |
else |
|
1651 |
do_const depth Ts t x [t1, t2, t3] |
|
41045
2a41709f34c1
use heuristic to determine whether to keep or drop an existing "let" -- and drop all higher-order lets
blanchet
parents:
40132
diff
changeset
|
1652 |
| Const (@{const_name Let}, _) $ t1 $ t2 => |
2a41709f34c1
use heuristic to determine whether to keep or drop an existing "let" -- and drop all higher-order lets
blanchet
parents:
40132
diff
changeset
|
1653 |
s_betapply Ts (pairself (do_term depth Ts) (t2, t1)) |
33192 | 1654 |
| Const x => do_const depth Ts t x [] |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1655 |
| t1 $ t2 => |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1656 |
(case strip_comb t of |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1657 |
(Const x, ts) => do_const depth Ts t x ts |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1658 |
| _ => s_betapply [] (do_term depth Ts t1, do_term depth Ts t2)) |
33192 | 1659 |
| Bound _ => t |
1660 |
| Abs (s, T, body) => Abs (s, T, do_term depth (T :: Ts) body) |
|
38209 | 1661 |
| _ => if member (term_match thy) whacks t then |
1662 |
Const (@{const_name unknown}, fastype_of1 (Ts, t)) |
|
1663 |
else |
|
1664 |
t |
|
33192 | 1665 |
and select_nth_constr_arg_with_args _ _ (x as (_, T)) [] n res_T = |
1666 |
(Abs (Name.uu, body_type T, |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1667 |
select_nth_constr_arg ctxt stds x (Bound 0) n res_T), []) |
33192 | 1668 |
| select_nth_constr_arg_with_args depth Ts x (t :: ts) n res_T = |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1669 |
(select_nth_constr_arg ctxt stds x (do_term depth Ts t) n res_T, ts) |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1670 |
and quot_rep_of depth Ts abs_T rep_T ts = |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1671 |
select_nth_constr_arg_with_args depth Ts |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1672 |
(@{const_name Quot}, rep_T --> abs_T) ts 0 rep_T |
33192 | 1673 |
and do_const depth Ts t (x as (s, T)) ts = |
38209 | 1674 |
if member (term_match thy) whacks (Const x) then |
1675 |
Const (@{const_name unknown}, fastype_of1 (Ts, t)) |
|
1676 |
else case AList.lookup (op =) ersatz_table s of |
|
33192 | 1677 |
SOME s' => |
1678 |
do_const (depth + 1) Ts (list_comb (Const (s', T), ts)) (s', T) ts |
|
1679 |
| NONE => |
|
1680 |
let |
|
38206 | 1681 |
fun def_inline_threshold () = |
41871
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1682 |
if is_boolean_type (nth_range_type (length ts) T) andalso |
394eef237bd1
lower threshold for implicitly using "nitpick_simp" for predicate definitions when "total_consts" is on
blanchet
parents:
41860
diff
changeset
|
1683 |
total_consts <> SOME true then |
38206 | 1684 |
def_inline_threshold_for_booleans |
1685 |
else |
|
1686 |
def_inline_threshold_for_non_booleans |
|
33192 | 1687 |
val (const, ts) = |
39359 | 1688 |
if is_built_in_const thy stds x then |
33877
e779bea3d337
fix Nitpick soundness bug related to "finite (UNIV::'a set)" where "'a" is constrained by a sort to be infinite
blanchet
parents:
33876
diff
changeset
|
1689 |
(Const x, ts) |
33192 | 1690 |
else case AList.lookup (op =) case_names s of |
1691 |
SOME n => |
|
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1692 |
if length ts < n then |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1693 |
(do_term depth Ts (eta_expand Ts t (n - length ts)), []) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1694 |
else |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1695 |
let |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1696 |
val (dataT, res_T) = nth_range_type n T |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1697 |
|> pairf domain_type range_type |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1698 |
in |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1699 |
(optimized_case_def hol_ctxt dataT res_T |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1700 |
(map (do_term depth Ts) (take n ts)), |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1701 |
drop n ts) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1702 |
end |
33192 | 1703 |
| _ => |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1704 |
if is_constr ctxt stds x then |
33192 | 1705 |
(Const x, ts) |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1706 |
else if is_stale_constr ctxt x then |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1707 |
raise NOT_SUPPORTED ("(non-co)constructors of codatatypes \ |
33581
e1e77265fb1d
added possibility to register datatypes as codatatypes in Nitpick;
blanchet
parents:
33580
diff
changeset
|
1708 |
\(\"" ^ s ^ "\")") |
35284
9edc2bd6d2bd
enabled Nitpick's support for quotient types + shortened the Nitpick tests a bit
blanchet
parents:
35283
diff
changeset
|
1709 |
else if is_quot_abs_fun ctxt x then |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1710 |
let |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1711 |
val rep_T = domain_type T |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1712 |
val abs_T = range_type T |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1713 |
in |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1714 |
(Abs (Name.uu, rep_T, |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1715 |
Const (@{const_name Quot}, rep_T --> abs_T) |
35311 | 1716 |
$ (Const (quot_normal_name_for_type ctxt abs_T, |
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1717 |
rep_T --> rep_T) $ Bound 0)), ts) |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
1718 |
end |
35284
9edc2bd6d2bd
enabled Nitpick's support for quotient types + shortened the Nitpick tests a bit
blanchet
parents:
35283
diff
changeset
|
1719 |
else if is_quot_rep_fun ctxt x then |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1720 |
quot_rep_of depth Ts (domain_type T) (range_type T) ts |
33192 | 1721 |
else if is_record_get thy x then |
1722 |
case length ts of |
|
1723 |
0 => (do_term depth Ts (eta_expand Ts t 1), []) |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1724 |
| _ => (optimized_record_get hol_ctxt s (domain_type T) |
34982
7b8c366e34a2
added support for nonstandard models to Nitpick (based on an idea by Koen Claessen) and did other fixes to Nitpick
blanchet
parents:
34936
diff
changeset
|
1725 |
(range_type T) (do_term depth Ts (hd ts)), tl ts) |
33192 | 1726 |
else if is_record_update thy x then |
1727 |
case length ts of |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1728 |
2 => (optimized_record_update hol_ctxt |
33580
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
1729 |
(unsuffix Record.updateN s) (nth_range_type 2 T) |
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
1730 |
(do_term depth Ts (hd ts)) |
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
1731 |
(do_term depth Ts (nth ts 1)), []) |
33192 | 1732 |
| n => (do_term depth Ts (eta_expand Ts t (2 - n)), []) |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1733 |
else if is_abs_fun ctxt x andalso |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1734 |
is_quot_type ctxt (range_type T) then |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1735 |
let |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1736 |
val abs_T = range_type T |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1737 |
val rep_T = domain_type (domain_type T) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1738 |
val eps_fun = Const (@{const_name Eps}, |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1739 |
(rep_T --> bool_T) --> rep_T) |
39315
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
1740 |
val normal_fun = |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1741 |
Const (quot_normal_name_for_type ctxt abs_T, |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1742 |
rep_T --> rep_T) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1743 |
val abs_fun = Const (@{const_name Quot}, rep_T --> abs_T) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1744 |
in |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1745 |
(Abs (Name.uu, rep_T --> bool_T, |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1746 |
abs_fun $ (normal_fun $ (eps_fun $ Bound 0))) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1747 |
|> do_term (depth + 1) Ts, ts) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1748 |
end |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1749 |
else if is_rep_fun ctxt x then |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1750 |
let val x' = mate_of_rep_fun ctxt x in |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1751 |
if is_constr ctxt stds x' then |
33192 | 1752 |
select_nth_constr_arg_with_args depth Ts x' ts 0 |
1753 |
(range_type T) |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1754 |
else if is_quot_type ctxt (domain_type T) then |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1755 |
let |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1756 |
val abs_T = domain_type T |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1757 |
val rep_T = domain_type (range_type T) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1758 |
val (rep_fun, _) = quot_rep_of depth Ts abs_T rep_T [] |
38243 | 1759 |
val (equiv_rel, _) = |
1760 |
equiv_relation_for_quot_type thy abs_T |
|
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1761 |
in |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1762 |
(Abs (Name.uu, abs_T, equiv_rel $ (rep_fun $ Bound 0)), |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1763 |
ts) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1764 |
end |
33192 | 1765 |
else |
38208 | 1766 |
(Const x, ts) |
33192 | 1767 |
end |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1768 |
else if is_equational_fun_but_no_plain_def hol_ctxt x orelse |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1769 |
is_choice_spec_fun hol_ctxt x then |
33192 | 1770 |
(Const x, ts) |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1771 |
else case def_of_const_ext thy def_tables x of |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1772 |
SOME (unfold, def) => |
33192 | 1773 |
if depth > unfold_max_depth then |
34124
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
1774 |
raise TOO_LARGE ("Nitpick_HOL.unfold_defs_in_term", |
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
1775 |
"too many nested definitions (" ^ |
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
1776 |
string_of_int depth ^ ") while expanding " ^ |
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
1777 |
quote s) |
33192 | 1778 |
else if s = @{const_name wfrec'} then |
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1779 |
(do_term (depth + 1) Ts (s_betapplys Ts (def, ts)), []) |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1780 |
else if not unfold andalso |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1781 |
size_of_term def > def_inline_threshold () then |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1782 |
(Const x, ts) |
33192 | 1783 |
else |
1784 |
(do_term (depth + 1) Ts def, ts) |
|
1785 |
| NONE => (Const x, ts) |
|
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1786 |
in |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1787 |
s_betapplys Ts (const, map (do_term depth Ts) ts) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1788 |
|> s_beta_norm Ts |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
1789 |
end |
33192 | 1790 |
in do_term 0 [] end |
1791 |
||
35718 | 1792 |
(** Axiom extraction/generation **) |
1793 |
||
38206 | 1794 |
fun extensional_equal j (Type (@{type_name fun}, [dom_T, ran_T])) t1 t2 = |
1795 |
let val var_t = Var (("x", j), dom_T) in |
|
1796 |
extensional_equal (j + 1) ran_T (betapply (t1, var_t)) |
|
1797 |
(betapply (t2, var_t)) |
|
1798 |
end |
|
1799 |
| extensional_equal _ T t1 t2 = |
|
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
1800 |
Const (@{const_name HOL.eq}, T --> T --> bool_T) $ t1 $ t2 |
38206 | 1801 |
|
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1802 |
fun equationalize_term ctxt tag t = |
38206 | 1803 |
let |
1804 |
val j = maxidx_of_term t + 1 |
|
1805 |
val (prems, concl) = Logic.strip_horn t |
|
1806 |
in |
|
38174
c15dfe7bc077
fix newly introduced bug w.r.t. conditional equations
blanchet
parents:
38172
diff
changeset
|
1807 |
Logic.list_implies (prems, |
38200
2f531f620cb8
fix bug in Nitpick's "equationalize" function (the prems were ignored) + make it do some basic extensionalization
blanchet
parents:
38190
diff
changeset
|
1808 |
case concl of |
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
1809 |
@{const Trueprop} $ (Const (@{const_name HOL.eq}, Type (_, [T, _])) |
38206 | 1810 |
$ t1 $ t2) => |
1811 |
@{const Trueprop} $ extensional_equal j T t1 t2 |
|
38200
2f531f620cb8
fix bug in Nitpick's "equationalize" function (the prems were ignored) + make it do some basic extensionalization
blanchet
parents:
38190
diff
changeset
|
1812 |
| @{const Trueprop} $ t' => |
2f531f620cb8
fix bug in Nitpick's "equationalize" function (the prems were ignored) + make it do some basic extensionalization
blanchet
parents:
38190
diff
changeset
|
1813 |
@{const Trueprop} $ HOLogic.mk_eq (t', @{const True}) |
38201 | 1814 |
| Const (@{const_name "=="}, Type (_, [T, _])) $ t1 $ t2 => |
38206 | 1815 |
@{const Trueprop} $ extensional_equal j T t1 t2 |
38201 | 1816 |
| _ => (warning ("Ignoring " ^ quote tag ^ " for non-equation" ^ |
1817 |
quote (Syntax.string_of_term ctxt t) ^ "."); |
|
1818 |
raise SAME ())) |
|
1819 |
|> SOME |
|
38200
2f531f620cb8
fix bug in Nitpick's "equationalize" function (the prems were ignored) + make it do some basic extensionalization
blanchet
parents:
38190
diff
changeset
|
1820 |
end |
38201 | 1821 |
handle SAME () => NONE |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1822 |
|
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1823 |
fun pair_for_prop t = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1824 |
case term_under_def t of |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1825 |
Const (s, _) => (s, t) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1826 |
| t' => raise TERM ("Nitpick_HOL.pair_for_prop", [t, t']) |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1827 |
|
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1828 |
fun def_table_for get ctxt subst = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1829 |
ctxt |> get |> map (pair_for_prop o subst_atomic subst) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1830 |
|> AList.group (op =) |> Symtab.make |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1831 |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1832 |
fun const_def_tables ctxt subst ts = |
41792
ff3cb0c418b7
renamed "nitpick\_def" to "nitpick_unfold" to reflect its new semantics
blanchet
parents:
41791
diff
changeset
|
1833 |
(def_table_for (map prop_of o Nitpick_Unfolds.get) ctxt subst, |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1834 |
fold (fn (s, t) => Symtab.map_default (s, []) (cons t)) |
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1835 |
(map pair_for_prop ts) Symtab.empty) |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1836 |
|
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1837 |
fun paired_with_consts t = map (rpair t) (Term.add_const_names t []) |
35718 | 1838 |
fun const_nondef_table ts = |
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1839 |
fold (append o paired_with_consts) ts [] |> AList.group (op =) |> Symtab.make |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1840 |
|
38201 | 1841 |
fun const_simp_table ctxt = |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1842 |
def_table_for (map_filter (equationalize_term ctxt "nitpick_simp" o prop_of) |
38201 | 1843 |
o Nitpick_Simps.get) ctxt |
1844 |
fun const_psimp_table ctxt = |
|
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
1845 |
def_table_for (map_filter (equationalize_term ctxt "nitpick_psimp" o prop_of) |
38201 | 1846 |
o Nitpick_Psimps.get) ctxt |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1847 |
|
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1848 |
fun const_choice_spec_table ctxt subst = |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1849 |
map (subst_atomic subst o prop_of) (Nitpick_Choice_Specs.get ctxt) |
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1850 |
|> const_nondef_table |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1851 |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1852 |
fun inductive_intro_table ctxt subst def_tables = |
42361 | 1853 |
let val thy = Proof_Context.theory_of ctxt in |
37264
8b931fb51cc6
removed "nitpick_intro" attribute -- Nitpick noew uses Spec_Rules instead
blanchet
parents:
37261
diff
changeset
|
1854 |
def_table_for |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
1855 |
(maps (map (unfold_mutually_inductive_preds thy def_tables o prop_of) |
37264
8b931fb51cc6
removed "nitpick_intro" attribute -- Nitpick noew uses Spec_Rules instead
blanchet
parents:
37261
diff
changeset
|
1856 |
o snd o snd) |
8b931fb51cc6
removed "nitpick_intro" attribute -- Nitpick noew uses Spec_Rules instead
blanchet
parents:
37261
diff
changeset
|
1857 |
o filter (fn (cat, _) => cat = Spec_Rules.Inductive orelse |
8b931fb51cc6
removed "nitpick_intro" attribute -- Nitpick noew uses Spec_Rules instead
blanchet
parents:
37261
diff
changeset
|
1858 |
cat = Spec_Rules.Co_Inductive) |
8b931fb51cc6
removed "nitpick_intro" attribute -- Nitpick noew uses Spec_Rules instead
blanchet
parents:
37261
diff
changeset
|
1859 |
o Spec_Rules.get) ctxt subst |
8b931fb51cc6
removed "nitpick_intro" attribute -- Nitpick noew uses Spec_Rules instead
blanchet
parents:
37261
diff
changeset
|
1860 |
end |
38172
62d4bdc3f7cc
make Nitpick more flexible when parsing (p)simp rules
blanchet
parents:
38169
diff
changeset
|
1861 |
|
35718 | 1862 |
fun ground_theorem_table thy = |
1863 |
fold ((fn @{const Trueprop} $ t1 => |
|
1864 |
is_ground_term t1 ? Inttab.map_default (hash_term t1, []) (cons t1) |
|
39557
fe5722fce758
renamed structure PureThy to Pure_Thy and moved most content to Global_Theory, to emphasize that this is global-only;
wenzelm
parents:
39360
diff
changeset
|
1865 |
| _ => I) o prop_of o snd) (Global_Theory.all_thms_of thy) Inttab.empty |
35718 | 1866 |
|
35807
e4d1b5cbd429
added support for "specification" and "ax_specification" constructs to Nitpick
blanchet
parents:
35743
diff
changeset
|
1867 |
(* TODO: Move to "Nitpick.thy" *) |
35718 | 1868 |
val basic_ersatz_table = |
37213
efcad7594872
fix handling of "split" w.r.t. new definition + fix exception handling w.r.t. "expect" option
blanchet
parents:
36575
diff
changeset
|
1869 |
[(@{const_name card}, @{const_name card'}), |
35718 | 1870 |
(@{const_name setsum}, @{const_name setsum'}), |
1871 |
(@{const_name fold_graph}, @{const_name fold_graph'}), |
|
1872 |
(@{const_name wf}, @{const_name wf'}), |
|
1873 |
(@{const_name wf_wfrec}, @{const_name wf_wfrec'}), |
|
1874 |
(@{const_name wfrec}, @{const_name wfrec'})] |
|
1875 |
||
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1876 |
fun ersatz_table ctxt = |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1877 |
basic_ersatz_table |
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1878 |
|> fold (append o snd) (#frac_types (Data.get (Context.Proof ctxt))) |
35718 | 1879 |
|
1880 |
fun add_simps simp_table s eqs = |
|
1881 |
Unsynchronized.change simp_table |
|
1882 |
(Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s))) |
|
1883 |
||
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1884 |
fun inverse_axioms_for_rep_fun ctxt (x as (_, T)) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1885 |
let |
42361 | 1886 |
val thy = Proof_Context.theory_of ctxt |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1887 |
val abs_T = domain_type T |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1888 |
in |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1889 |
typedef_info ctxt (fst (dest_Type abs_T)) |> the |
35718 | 1890 |
|> pairf #Abs_inverse #Rep_inverse |
36555
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1891 |
|> pairself (specialize_type thy x o prop_of o the) |
35718 | 1892 |
||> single |> op :: |
1893 |
end |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1894 |
fun optimized_typedef_axioms ctxt (abs_z as (abs_s, _)) = |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1895 |
let |
42361 | 1896 |
val thy = Proof_Context.theory_of ctxt |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1897 |
val abs_T = Type abs_z |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1898 |
in |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1899 |
if is_univ_typedef ctxt abs_T then |
35718 | 1900 |
[] |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1901 |
else case typedef_info ctxt abs_s of |
35718 | 1902 |
SOME {abs_type, rep_type, Rep_name, prop_of_Rep, set_name, ...} => |
1903 |
let |
|
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1904 |
val rep_T = varify_and_instantiate_type ctxt abs_type abs_T rep_type |
35718 | 1905 |
val rep_t = Const (Rep_name, abs_T --> rep_T) |
1906 |
val set_t = Const (set_name, rep_T --> bool_T) |
|
1907 |
val set_t' = |
|
1908 |
prop_of_Rep |> HOLogic.dest_Trueprop |
|
36555
8ff45c2076da
expand combinators in Isar proofs constructed by Sledgehammer;
blanchet
parents:
36391
diff
changeset
|
1909 |
|> specialize_type thy (dest_Const rep_t) |
35718 | 1910 |
|> HOLogic.dest_mem |> snd |
1911 |
in |
|
1912 |
[HOLogic.all_const abs_T |
|
1913 |
$ Abs (Name.uu, abs_T, set_t $ (rep_t $ Bound 0))] |
|
1914 |
|> set_t <> set_t' ? cons (HOLogic.mk_eq (set_t, set_t')) |
|
1915 |
|> map HOLogic.mk_Trueprop |
|
1916 |
end |
|
1917 |
| NONE => [] |
|
1918 |
end |
|
1919 |
fun optimized_quot_type_axioms ctxt stds abs_z = |
|
1920 |
let |
|
42361 | 1921 |
val thy = Proof_Context.theory_of ctxt |
35718 | 1922 |
val abs_T = Type abs_z |
1923 |
val rep_T = rep_type_for_quot_type thy abs_T |
|
38243 | 1924 |
val (equiv_rel, partial) = equiv_relation_for_quot_type thy abs_T |
35718 | 1925 |
val a_var = Var (("a", 0), abs_T) |
1926 |
val x_var = Var (("x", 0), rep_T) |
|
1927 |
val y_var = Var (("y", 0), rep_T) |
|
1928 |
val x = (@{const_name Quot}, rep_T --> abs_T) |
|
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1929 |
val sel_a_t = select_nth_constr_arg ctxt stds x a_var 0 rep_T |
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1930 |
val normal_fun = |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1931 |
Const (quot_normal_name_for_type ctxt abs_T, rep_T --> rep_T) |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1932 |
val normal_x = normal_fun $ x_var |
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1933 |
val normal_y = normal_fun $ y_var |
35718 | 1934 |
val is_unknown_t = Const (@{const_name is_unknown}, rep_T --> bool_T) |
1935 |
in |
|
38207
792b78e355e7
added support for "Abs_" and "Rep_" functions on quotient types
blanchet
parents:
38206
diff
changeset
|
1936 |
[Logic.mk_equals (normal_fun $ sel_a_t, sel_a_t), |
35718 | 1937 |
Logic.list_implies |
1938 |
([@{const Not} $ (is_unknown_t $ normal_x), |
|
1939 |
@{const Not} $ (is_unknown_t $ normal_y), |
|
1940 |
equiv_rel $ x_var $ y_var] |> map HOLogic.mk_Trueprop, |
|
1941 |
Logic.mk_equals (normal_x, normal_y)), |
|
1942 |
Logic.list_implies |
|
1943 |
([HOLogic.mk_Trueprop (@{const Not} $ (is_unknown_t $ normal_x)), |
|
1944 |
HOLogic.mk_Trueprop (@{const Not} $ HOLogic.mk_eq (normal_x, x_var))], |
|
1945 |
HOLogic.mk_Trueprop (equiv_rel $ x_var $ normal_x))] |
|
38243 | 1946 |
|> partial ? cons (HOLogic.mk_Trueprop (equiv_rel $ sel_a_t $ sel_a_t)) |
35718 | 1947 |
end |
1948 |
||
39345 | 1949 |
fun codatatype_bisim_axioms (hol_ctxt as {ctxt, stds, ...}) T = |
33192 | 1950 |
let |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1951 |
val xs = datatype_constrs hol_ctxt T |
33192 | 1952 |
val set_T = T --> bool_T |
1953 |
val iter_T = @{typ bisim_iterator} |
|
1954 |
val bisim_max = @{const bisim_iterator_max} |
|
1955 |
val n_var = Var (("n", 0), iter_T) |
|
1956 |
val n_var_minus_1 = |
|
35671
ed2c3830d881
improved Nitpick's precision for "card" and "setsum" + fix incorrect outcome code w.r.t. "bisim_depth = -1"
blanchet
parents:
35665
diff
changeset
|
1957 |
Const (@{const_name safe_The}, (iter_T --> bool_T) --> iter_T) |
33192 | 1958 |
$ Abs ("m", iter_T, HOLogic.eq_const iter_T |
1959 |
$ (suc_const iter_T $ Bound 0) $ n_var) |
|
1960 |
val x_var = Var (("x", 0), T) |
|
1961 |
val y_var = Var (("y", 0), T) |
|
38161
c1cf80763eff
fix bug with mutually recursive and nested codatatypes
blanchet
parents:
37678
diff
changeset
|
1962 |
fun bisim_const T = |
c1cf80763eff
fix bug with mutually recursive and nested codatatypes
blanchet
parents:
37678
diff
changeset
|
1963 |
Const (@{const_name bisim}, iter_T --> T --> T --> bool_T) |
33192 | 1964 |
fun nth_sub_bisim x n nth_T = |
38240
a44d108a8d39
local versions of Nitpick.register_xxx functions
blanchet
parents:
38215
diff
changeset
|
1965 |
(if is_codatatype ctxt nth_T then bisim_const nth_T $ n_var_minus_1 |
33192 | 1966 |
else HOLogic.eq_const nth_T) |
37256
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1967 |
$ select_nth_constr_arg ctxt stds x x_var n nth_T |
0dca1ec52999
thread along context instead of theory for typedef lookup
blanchet
parents:
37253
diff
changeset
|
1968 |
$ select_nth_constr_arg ctxt stds x y_var n nth_T |
33192 | 1969 |
fun case_func (x as (_, T)) = |
1970 |
let |
|
1971 |
val arg_Ts = binder_types T |
|
1972 |
val core_t = |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
1973 |
discriminate_value hol_ctxt x y_var :: |
33192 | 1974 |
map2 (nth_sub_bisim x) (index_seq 0 (length arg_Ts)) arg_Ts |
1975 |
|> foldr1 s_conj |
|
1976 |
in List.foldr absdummy core_t arg_Ts end |
|
1977 |
in |
|
38163
bc546396b818
prefer implication to equality, to be more SAT solver friendly
blanchet
parents:
38161
diff
changeset
|
1978 |
[HOLogic.mk_imp |
bc546396b818
prefer implication to equality, to be more SAT solver friendly
blanchet
parents:
38161
diff
changeset
|
1979 |
(HOLogic.mk_disj (HOLogic.eq_const iter_T $ n_var $ zero_const iter_T, |
bc546396b818
prefer implication to equality, to be more SAT solver friendly
blanchet
parents:
38161
diff
changeset
|
1980 |
s_betapply [] (optimized_case_def hol_ctxt T bool_T |
bc546396b818
prefer implication to equality, to be more SAT solver friendly
blanchet
parents:
38161
diff
changeset
|
1981 |
(map case_func xs), x_var)), |
bc546396b818
prefer implication to equality, to be more SAT solver friendly
blanchet
parents:
38161
diff
changeset
|
1982 |
bisim_const T $ n_var $ x_var $ y_var), |
38161
c1cf80763eff
fix bug with mutually recursive and nested codatatypes
blanchet
parents:
37678
diff
changeset
|
1983 |
HOLogic.eq_const set_T $ (bisim_const T $ bisim_max $ x_var) |
34124
c4628a1dcf75
added support for binary nat/int representation to Nitpick
blanchet
parents:
34123
diff
changeset
|
1984 |
$ (Const (@{const_name insert}, T --> set_T --> set_T) |
35220
2bcdae5f4fdb
added support for nonstandard "nat"s to Nitpick and fixed bugs in binary "nat"s and "int"s
blanchet
parents:
35190
diff
changeset
|
1985 |
$ x_var $ Const (@{const_name bot_class.bot}, set_T))] |
33192 | 1986 |
|> map HOLogic.mk_Trueprop |
1987 |
end |
|
1988 |
||
1989 |
exception NO_TRIPLE of unit |
|
1990 |
||
1991 |
fun triple_for_intro_rule thy x t = |
|
1992 |
let |
|
35625 | 1993 |
val prems = Logic.strip_imp_prems t |> map (Object_Logic.atomize_term thy) |
1994 |
val concl = Logic.strip_imp_concl t |> Object_Logic.atomize_term thy |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
1995 |
val (main, side) = List.partition (exists_Const (curry (op =) x)) prems |
36385 | 1996 |
val is_good_head = curry (op =) (Const x) o head_of |
33192 | 1997 |
in |
1998 |
if forall is_good_head main then (side, main, concl) else raise NO_TRIPLE () |
|
1999 |
end |
|
2000 |
||
2001 |
val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb |
|
2002 |
fun wf_constraint_for rel side concl main = |
|
2003 |
let |
|
37269 | 2004 |
val core = HOLogic.mk_mem (HOLogic.mk_prod |
2005 |
(pairself tuple_for_args (main, concl)), Var rel) |
|
33192 | 2006 |
val t = List.foldl HOLogic.mk_imp core side |
37269 | 2007 |
val vars = filter_out (curry (op =) rel) (Term.add_vars t []) |
33192 | 2008 |
in |
2009 |
Library.foldl (fn (t', ((x, j), T)) => |
|
2010 |
HOLogic.all_const T |
|
2011 |
$ Abs (x, T, abstract_over (Var ((x, j), T), t'))) |
|
2012 |
(t, vars) |
|
2013 |
end |
|
2014 |
fun wf_constraint_for_triple rel (side, main, concl) = |
|
2015 |
map (wf_constraint_for rel side concl) main |> foldr1 s_conj |
|
2016 |
||
2017 |
fun terminates_by ctxt timeout goal tac = |
|
2018 |
can (SINGLE (Classical.safe_tac (claset_of ctxt)) #> the |
|
2019 |
#> SINGLE (DETERM_TIMEOUT timeout |
|
2020 |
(tac ctxt (auto_tac (clasimpset_of ctxt)))) |
|
2021 |
#> the #> Goal.finish ctxt) goal |
|
2022 |
||
35181
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2023 |
val max_cached_wfs = 50 |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2024 |
val cached_timeout = |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2025 |
Synchronized.var "Nitpick_HOL.cached_timeout" (SOME Time.zeroTime) |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2026 |
val cached_wf_props = |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2027 |
Synchronized.var "Nitpick_HOL.cached_wf_props" ([] : (term * bool) list) |
33192 | 2028 |
|
33351 | 2029 |
val termination_tacs = [Lexicographic_Order.lex_order_tac true, |
33192 | 2030 |
ScnpReconstruct.sizechange_tac] |
2031 |
||
33580
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
2032 |
fun uncached_is_well_founded_inductive_pred |
39359 | 2033 |
({thy, ctxt, stds, debug, tac_timeout, intro_table, ...} : hol_context) |
2034 |
(x as (_, T)) = |
|
2035 |
case def_props_for_const thy stds intro_table x of |
|
33580
45c33e97cb86
added datatype constructor cache in Nitpick (to speed up the scope enumeration) and never test more than 4096 scopes
blanchet
parents:
33578
diff
changeset
|
2036 |
[] => raise TERM ("Nitpick_HOL.uncached_is_well_founded_inductive", |
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
2037 |
[Const x]) |
33192 | 2038 |
| intro_ts => |
2039 |
(case map (triple_for_intro_rule thy x) intro_ts |
|
2040 |
|> filter_out (null o #2) of |
|
2041 |
[] => true |
|
2042 |
| triples => |
|
2043 |
let |
|
2044 |
val binders_T = HOLogic.mk_tupleT (binder_types T) |
|
2045 |
val rel_T = HOLogic.mk_prodT (binders_T, binders_T) --> bool_T |
|
33882
9db7854eafc7
fix soundness bug in Nitpick's handling of negative literals (e.g., -1::rat)
blanchet
parents:
33879
diff
changeset
|
2046 |
val j = fold Integer.max (map maxidx_of_term intro_ts) 0 + 1 |
33192 | 2047 |
val rel = (("R", j), rel_T) |
2048 |
val prop = Const (@{const_name wf}, rel_T --> bool_T) $ Var rel :: |
|
2049 |
map (wf_constraint_for_triple rel) triples |
|
2050 |
|> foldr1 s_conj |> HOLogic.mk_Trueprop |
|
2051 |
val _ = if debug then |
|
40132
7ee65dbffa31
renamed Output.priority to Output.urgent_message to emphasize its special role more clearly;
wenzelm
parents:
39687
diff
changeset
|
2052 |
Output.urgent_message ("Wellfoundedness goal: " ^ |
33192 | 2053 |
Syntax.string_of_term ctxt prop ^ ".") |
2054 |
else |
|
2055 |
() |
|
2056 |
in |
|
35181
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2057 |
if tac_timeout = Synchronized.value cached_timeout andalso |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2058 |
length (Synchronized.value cached_wf_props) < max_cached_wfs then |
33557
107f3df799f6
clean Nitpick's wellfoundedness cache once in a while, to avoid potential memory leak
blanchet
parents:
33556
diff
changeset
|
2059 |
() |
107f3df799f6
clean Nitpick's wellfoundedness cache once in a while, to avoid potential memory leak
blanchet
parents:
33556
diff
changeset
|
2060 |
else |
35181
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2061 |
(Synchronized.change cached_wf_props (K []); |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2062 |
Synchronized.change cached_timeout (K tac_timeout)); |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2063 |
case AList.lookup (op =) (Synchronized.value cached_wf_props) prop of |
33192 | 2064 |
SOME wf => wf |
2065 |
| NONE => |
|
2066 |
let |
|
2067 |
val goal = prop |> cterm_of thy |> Goal.init |
|
33705
947184dc75c9
removed a few global names in Nitpick (styp, nat_less, pairf)
blanchet
parents:
33583
diff
changeset
|
2068 |
val wf = exists (terminates_by ctxt tac_timeout goal) |
947184dc75c9
removed a few global names in Nitpick (styp, nat_less, pairf)
blanchet
parents:
33583
diff
changeset
|
2069 |
termination_tacs |
35181
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2070 |
in Synchronized.change cached_wf_props (cons (prop, wf)); wf end |
33192 | 2071 |
end) |
35309
997aa3a3e4bb
catch IO errors in Nitpick's "kodkodi" invocation + shorten execution time of "Manual_Nits" example
blanchet
parents:
35284
diff
changeset
|
2072 |
handle List.Empty => false | NO_TRIPLE () => false |
33192 | 2073 |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2074 |
(* The type constraint below is a workaround for a Poly/ML crash. *) |
33192 | 2075 |
|
2076 |
fun is_well_founded_inductive_pred |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2077 |
(hol_ctxt as {thy, wfs, def_tables, wf_cache, ...} : hol_context) |
33192 | 2078 |
(x as (s, _)) = |
2079 |
case triple_lookup (const_match thy) wfs x of |
|
2080 |
SOME (SOME b) => b |
|
34936
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
2081 |
| _ => s = @{const_name Nats} orelse s = @{const_name fold_graph'} orelse |
c4f04bee79f3
some work on Nitpick's support for quotient types;
blanchet
parents:
34126
diff
changeset
|
2082 |
case AList.lookup (op =) (!wf_cache) x of |
35181
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2083 |
SOME (_, wf) => wf |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2084 |
| NONE => |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2085 |
let |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2086 |
val gfp = (fixpoint_kind_of_const thy def_tables x = Gfp) |
35181
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2087 |
val wf = uncached_is_well_founded_inductive_pred hol_ctxt x |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2088 |
in |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2089 |
Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf |
92d857a4e5e0
synchronize Nitpick's wellfoundedness formulas caching
blanchet
parents:
35179
diff
changeset
|
2090 |
end |
33192 | 2091 |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
2092 |
fun ap_curry [_] _ t = t |
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
2093 |
| ap_curry arg_Ts tuple_T t = |
33192 | 2094 |
let val n = length arg_Ts in |
2095 |
list_abs (map (pair "c") arg_Ts, |
|
2096 |
incr_boundvars n t |
|
2097 |
$ mk_flat_tuple tuple_T (map Bound (n - 1 downto 0))) |
|
2098 |
end |
|
2099 |
||
2100 |
fun num_occs_of_bound_in_term j (t1 $ t2) = |
|
2101 |
op + (pairself (num_occs_of_bound_in_term j) (t1, t2)) |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
2102 |
| num_occs_of_bound_in_term j (Abs (_, _, t')) = |
33192 | 2103 |
num_occs_of_bound_in_term (j + 1) t' |
2104 |
| num_occs_of_bound_in_term j (Bound j') = if j' = j then 1 else 0 |
|
2105 |
| num_occs_of_bound_in_term _ _ = 0 |
|
2106 |
||
2107 |
val is_linear_inductive_pred_def = |
|
2108 |
let |
|
2109 |
fun do_disjunct j (Const (@{const_name Ex}, _) $ Abs (_, _, t2)) = |
|
2110 |
do_disjunct (j + 1) t2 |
|
2111 |
| do_disjunct j t = |
|
2112 |
case num_occs_of_bound_in_term j t of |
|
2113 |
0 => true |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2114 |
| 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts_of t) |
33192 | 2115 |
| _ => false |
2116 |
fun do_lfp_def (Const (@{const_name lfp}, _) $ t2) = |
|
2117 |
let val (xs, body) = strip_abs t2 in |
|
2118 |
case length xs of |
|
2119 |
1 => false |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2120 |
| n => forall (do_disjunct (n - 1)) (disjuncts_of body) |
33192 | 2121 |
end |
2122 |
| do_lfp_def _ = false |
|
2123 |
in do_lfp_def o strip_abs_body end |
|
2124 |
||
33851
ab6ecae44033
fixed error in Nitpick's "star_linear_preds" optimization, which resulted in an ill-typed term;
blanchet
parents:
33747
diff
changeset
|
2125 |
fun n_ptuple_paths 0 = [] |
ab6ecae44033
fixed error in Nitpick's "star_linear_preds" optimization, which resulted in an ill-typed term;
blanchet
parents:
33747
diff
changeset
|
2126 |
| n_ptuple_paths 1 = [] |
ab6ecae44033
fixed error in Nitpick's "star_linear_preds" optimization, which resulted in an ill-typed term;
blanchet
parents:
33747
diff
changeset
|
2127 |
| n_ptuple_paths n = [] :: map (cons 2) (n_ptuple_paths (n - 1)) |
ab6ecae44033
fixed error in Nitpick's "star_linear_preds" optimization, which resulted in an ill-typed term;
blanchet
parents:
33747
diff
changeset
|
2128 |
val ap_n_split = HOLogic.mk_psplits o n_ptuple_paths |
33192 | 2129 |
|
2130 |
val linear_pred_base_and_step_rhss = |
|
2131 |
let |
|
2132 |
fun aux (Const (@{const_name lfp}, _) $ t2) = |
|
2133 |
let |
|
2134 |
val (xs, body) = strip_abs t2 |
|
2135 |
val arg_Ts = map snd (tl xs) |
|
2136 |
val tuple_T = HOLogic.mk_tupleT arg_Ts |
|
2137 |
val j = length arg_Ts |
|
2138 |
fun repair_rec j (Const (@{const_name Ex}, T1) $ Abs (s2, T2, t2')) = |
|
2139 |
Const (@{const_name Ex}, T1) |
|
2140 |
$ Abs (s2, T2, repair_rec (j + 1) t2') |
|
38795
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
2141 |
| repair_rec j (@{const HOL.conj} $ t1 $ t2) = |
848be46708dc
formerly unnamed infix conjunction and disjunction now named HOL.conj and HOL.disj
haftmann
parents:
38786
diff
changeset
|
2142 |
@{const HOL.conj} $ repair_rec j t1 $ repair_rec j t2 |
33192 | 2143 |
| repair_rec j t = |
2144 |
let val (head, args) = strip_comb t in |
|
2145 |
if head = Bound j then |
|
2146 |
HOLogic.eq_const tuple_T $ Bound j |
|
2147 |
$ mk_flat_tuple tuple_T args |
|
2148 |
else |
|
2149 |
t |
|
2150 |
end |
|
2151 |
val (nonrecs, recs) = |
|
34121
5e831d805118
get rid of polymorphic equality in Nitpick's code + a few minor cleanups
blanchet
parents:
33978
diff
changeset
|
2152 |
List.partition (curry (op =) 0 o num_occs_of_bound_in_term j) |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2153 |
(disjuncts_of body) |
33192 | 2154 |
val base_body = nonrecs |> List.foldl s_disj @{const False} |
2155 |
val step_body = recs |> map (repair_rec j) |
|
39315
27f7b7748425
always handle type variables in typedefs as global
blanchet
parents:
38864
diff
changeset
|
2156 |
|> List.foldl s_disj @{const False} |
33192 | 2157 |
in |
2158 |
(list_abs (tl xs, incr_bv (~1, j, base_body)) |
|
33851
ab6ecae44033
fixed error in Nitpick's "star_linear_preds" optimization, which resulted in an ill-typed term;
blanchet
parents:
33747
diff
changeset
|
2159 |
|> ap_n_split (length arg_Ts) tuple_T bool_T, |
33192 | 2160 |
Abs ("y", tuple_T, list_abs (tl xs, step_body) |
33851
ab6ecae44033
fixed error in Nitpick's "star_linear_preds" optimization, which resulted in an ill-typed term;
blanchet
parents:
33747
diff
changeset
|
2161 |
|> ap_n_split (length arg_Ts) tuple_T bool_T)) |
33192 | 2162 |
end |
2163 |
| aux t = |
|
33232
f93390060bbe
internal renaming in Nitpick and fixed Kodkodi invokation on Linux;
blanchet
parents:
33202
diff
changeset
|
2164 |
raise TERM ("Nitpick_HOL.linear_pred_base_and_step_rhss.aux", [t]) |
33192 | 2165 |
in aux end |
2166 |
||
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
2167 |
fun starred_linear_pred_const (hol_ctxt as {simp_table, ...}) (s, T) def = |
33192 | 2168 |
let |
2169 |
val j = maxidx_of_term def + 1 |
|
2170 |
val (outer, fp_app) = strip_abs def |
|
2171 |
val outer_bounds = map Bound (length outer - 1 downto 0) |
|
2172 |
val outer_vars = map (fn (s, T) => Var ((s, j), T)) outer |
|
2173 |
val fp_app = subst_bounds (rev outer_vars, fp_app) |
|
2174 |
val (outer_Ts, rest_T) = strip_n_binders (length outer) T |
|
2175 |
val tuple_arg_Ts = strip_type rest_T |> fst |
|
2176 |
val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts |
|
2177 |
val set_T = tuple_T --> bool_T |
|
2178 |
val curried_T = tuple_T --> set_T |
|
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
2179 |
val uncurried_T = Type (@{type_name prod}, [tuple_T, tuple_T]) --> bool_T |
33192 | 2180 |
val (base_rhs, step_rhs) = linear_pred_base_and_step_rhss fp_app |
2181 |
val base_x as (base_s, _) = (base_prefix ^ s, outer_Ts ---> set_T) |
|
2182 |
val base_eq = HOLogic.mk_eq (list_comb (Const base_x, outer_vars), base_rhs) |
|
2183 |
|> HOLogic.mk_Trueprop |
|
2184 |
val _ = add_simps simp_table base_s [base_eq] |
|
2185 |
val step_x as (step_s, _) = (step_prefix ^ s, outer_Ts ---> curried_T) |
|
2186 |
val step_eq = HOLogic.mk_eq (list_comb (Const step_x, outer_vars), step_rhs) |
|
2187 |
|> HOLogic.mk_Trueprop |
|
2188 |
val _ = add_simps simp_table step_s [step_eq] |
|
2189 |
in |
|
2190 |
list_abs (outer, |
|
2191 |
Const (@{const_name Image}, uncurried_T --> set_T --> set_T) |
|
2192 |
$ (Const (@{const_name rtrancl}, uncurried_T --> uncurried_T) |
|
37591 | 2193 |
$ (Const (@{const_name prod_case}, curried_T --> uncurried_T) |
33192 | 2194 |
$ list_comb (Const step_x, outer_bounds))) |
2195 |
$ list_comb (Const base_x, outer_bounds) |
|
35280
54ab4921f826
fixed a few bugs in Nitpick and removed unreferenced variables
blanchet
parents:
35220
diff
changeset
|
2196 |
|> ap_curry tuple_arg_Ts tuple_T) |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2197 |
|> unfold_defs_in_term hol_ctxt |
33192 | 2198 |
end |
2199 |
||
38168
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2200 |
fun is_good_starred_linear_pred_type (Type (@{type_name fun}, Ts)) = |
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2201 |
forall (not o (is_fun_type orf is_pair_type)) Ts |
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2202 |
| is_good_starred_linear_pred_type _ = false |
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2203 |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2204 |
fun unrolled_inductive_pred_const (hol_ctxt as {thy, star_linear_preds, |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2205 |
def_tables, simp_table, ...}) |
33192 | 2206 |
gfp (x as (s, T)) = |
2207 |
let |
|
2208 |
val iter_T = iterator_type_for_const gfp x |
|
2209 |
val x' as (s', _) = (unrolled_prefix ^ s, iter_T --> T) |
|
2210 |
val unrolled_const = Const x' $ zero_const iter_T |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2211 |
val def = the (def_of_const thy def_tables x) |
33192 | 2212 |
in |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2213 |
if is_equational_fun_but_no_plain_def hol_ctxt x' then |
33192 | 2214 |
unrolled_const (* already done *) |
38168
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2215 |
else if not gfp andalso star_linear_preds andalso |
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2216 |
is_linear_inductive_pred_def def andalso |
e5978befb951
careful about which linear inductive predicates should be starred
blanchet
parents:
38163
diff
changeset
|
2217 |
is_good_starred_linear_pred_type T then |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2218 |
starred_linear_pred_const hol_ctxt x def |
33192 | 2219 |
else |
2220 |
let |
|
2221 |
val j = maxidx_of_term def + 1 |
|
2222 |
val (outer, fp_app) = strip_abs def |
|
2223 |
val outer_bounds = map Bound (length outer - 1 downto 0) |
|
2224 |
val cur = Var ((iter_var_prefix, j + 1), iter_T) |
|
2225 |
val next = suc_const iter_T $ cur |
|
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2226 |
val rhs = |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2227 |
case fp_app of |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2228 |
Const _ $ t => |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2229 |
s_betapply [] (t, list_comb (Const x', next :: outer_bounds)) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2230 |
| _ => raise TERM ("Nitpick_HOL.unrolled_inductive_pred_const", |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2231 |
[fp_app]) |
33192 | 2232 |
val (inner, naked_rhs) = strip_abs rhs |
2233 |
val all = outer @ inner |
|
2234 |
val bounds = map Bound (length all - 1 downto 0) |
|
2235 |
val vars = map (fn (s, T) => Var ((s, j), T)) all |
|
2236 |
val eq = HOLogic.mk_eq (list_comb (Const x', cur :: bounds), naked_rhs) |
|
2237 |
|> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars) |
|
2238 |
val _ = add_simps simp_table s' [eq] |
|
2239 |
in unrolled_const end |
|
2240 |
end |
|
2241 |
||
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2242 |
fun raw_inductive_pred_axiom ({thy, def_tables, ...} : hol_context) x = |
33192 | 2243 |
let |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2244 |
val def = the (def_of_const thy def_tables x) |
33192 | 2245 |
val (outer, fp_app) = strip_abs def |
2246 |
val outer_bounds = map Bound (length outer - 1 downto 0) |
|
37476
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2247 |
val rhs = |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2248 |
case fp_app of |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2249 |
Const _ $ t => s_betapply [] (t, list_comb (Const x, outer_bounds)) |
0681e46b4022
optimized code generated for datatype cases + more;
blanchet
parents:
37269
diff
changeset
|
2250 |
| _ => raise TERM ("Nitpick_HOL.raw_inductive_pred_axiom", [fp_app]) |
33192 | 2251 |
val (inner, naked_rhs) = strip_abs rhs |
2252 |
val all = outer @ inner |
|
2253 |
val bounds = map Bound (length all - 1 downto 0) |
|
2254 |
val j = maxidx_of_term def + 1 |
|
2255 |
val vars = map (fn (s, T) => Var ((s, j), T)) all |
|
2256 |
in |
|
2257 |
HOLogic.mk_eq (list_comb (Const x, bounds), naked_rhs) |
|
2258 |
|> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars) |
|
2259 |
end |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2260 |
fun inductive_pred_axiom hol_ctxt (x as (s, T)) = |
33192 | 2261 |
if String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s then |
35718 | 2262 |
let val x' = (strip_first_name_sep s |> snd, T) in |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2263 |
raw_inductive_pred_axiom hol_ctxt x' |> subst_atomic [(Const x', Const x)] |
33192 | 2264 |
end |
2265 |
else |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2266 |
raw_inductive_pred_axiom hol_ctxt x |
33192 | 2267 |
|
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2268 |
fun equational_fun_axioms (hol_ctxt as {thy, ctxt, stds, def_tables, simp_table, |
39359 | 2269 |
psimp_table, ...}) x = |
2270 |
case def_props_for_const thy stds (!simp_table) x of |
|
2271 |
[] => (case def_props_for_const thy stds psimp_table x of |
|
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2272 |
[] => (if is_inductive_pred hol_ctxt x then |
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2273 |
[inductive_pred_axiom hol_ctxt x] |
41791
01d722707a36
always unfold constant defitions marked with "nitpick_def" -- to prevent unfolding, there's already "nitpick_simp"
blanchet
parents:
41472
diff
changeset
|
2274 |
else case def_of_const thy def_tables x of |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2275 |
SOME def => |
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2276 |
@{const Trueprop} $ HOLogic.mk_eq (Const x, def) |
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2277 |
|> equationalize_term ctxt "" |> the |> single |
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2278 |
| NONE => []) |
33192 | 2279 |
| psimps => psimps) |
2280 |
| simps => simps |
|
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2281 |
fun is_equational_fun_surely_complete hol_ctxt x = |
38202
379fb08da97b
prevent the expansion of too large definitions -- use equations for these instead
blanchet
parents:
38201
diff
changeset
|
2282 |
case equational_fun_axioms hol_ctxt x of |
38864
4abe644fcea5
formerly unnamed infix equality now named HOL.eq
haftmann
parents:
38795
diff
changeset
|
2283 |
[@{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ t1 $ _)] => |
35070
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2284 |
strip_comb t1 |> snd |> forall is_Var |
96136eb6218f
split "nitpick_hol.ML" into two files to make it more manageable;
blanchet
parents:
34998
diff
changeset
|
2285 |
| _ => false |
33192 | 2286 |
|
35718 | 2287 |
(** Type preprocessing **) |
2288 |
||
38212
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2289 |
fun merged_type_var_table_for_terms thy ts = |
33192 | 2290 |
let |
38212
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2291 |
fun add (s, S) table = |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2292 |
table |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2293 |
|> (case AList.lookup (Sign.subsort thy o swap) table S of |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2294 |
SOME _ => I |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2295 |
| NONE => |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2296 |
filter_out (fn (S', _) => Sign.subsort thy (S, S')) |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2297 |
#> cons (S, s)) |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2298 |
val tfrees = [] |> fold Term.add_tfrees ts |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2299 |
|> sort (string_ord o pairself fst) |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2300 |
in [] |> fold add tfrees |> rev end |
38169
b51784515471
optimize local "def"s by treating them as definitions
blanchet
parents:
38168
diff
changeset
|
2301 |
|
38212
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2302 |
fun merge_type_vars_in_term thy merge_type_vars table = |
38169
b51784515471
optimize local "def"s by treating them as definitions
blanchet
parents:
38168
diff
changeset
|
2303 |
merge_type_vars |
b51784515471
optimize local "def"s by treating them as definitions
blanchet
parents:
38168
diff
changeset
|
2304 |
? map_types (map_atyps |
38212
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2305 |
(fn TFree (_, S) => |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2306 |
TFree (table |> find_first (fn (S', _) => Sign.subsort thy (S', S)) |
a7e92239922f
improved "merge_type_vars" option: map supersorts to subsorts, to avoid distinguishing, say, "{}", and "HOL.type"
blanchet
parents:
38209
diff
changeset
|
2307 |
|> the |> swap) |
38169
b51784515471
optimize local "def"s by treating them as definitions
blanchet
parents:
38168
diff
changeset
|
2308 |
| T => T)) |
33192 | 2309 |
|
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2310 |
fun add_ground_types hol_ctxt binarize = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2311 |
let |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2312 |
fun aux T accum = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2313 |
case T of |
35665
ff2bf50505ab
added "finitize" option to Nitpick + remove dependency on "Coinductive_List"
blanchet
parents:
35625
diff
changeset
|
2314 |
Type (@{type_name fun}, Ts) => fold aux Ts accum |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
2315 |
| Type (@{type_name prod}, Ts) => fold aux Ts accum |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2316 |
| Type (@{type_name itself}, [T1]) => aux T1 accum |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2317 |
| Type (_, Ts) => |
38190
b02e204b613a
get rid of all "optimizations" regarding "unit" and other cardinality-1 types
blanchet
parents:
38188
diff
changeset
|
2318 |
if member (op =) (@{typ prop} :: @{typ bool} :: accum) T then |
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2319 |
accum |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2320 |
else |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2321 |
T :: accum |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2322 |
|> fold aux (case binarized_and_boxed_datatype_constrs hol_ctxt |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2323 |
binarize T of |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2324 |
[] => Ts |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2325 |
| xs => map snd xs) |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2326 |
| _ => insert (op =) T accum |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2327 |
in aux end |
33192 | 2328 |
|
35190
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2329 |
fun ground_types_in_type hol_ctxt binarize T = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2330 |
add_ground_types hol_ctxt binarize T [] |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2331 |
fun ground_types_in_terms hol_ctxt binarize ts = |
ce653cc27a94
make sure that Nitpick uses binary notation consistently if "binary_ints" is enabled
blanchet
parents:
35181
diff
changeset
|
2332 |
fold (fold_types (add_ground_types hol_ctxt binarize)) ts [] |
33192 | 2333 |
|
2334 |
end; |