author | wenzelm |
Fri, 14 Aug 2020 14:40:24 +0200 | |
changeset 72154 | 2b41b710f6ef |
parent 70494 | 41108e3e9ca5 |
child 72450 | 24bd1316eaae |
permissions | -rw-r--r-- |
55061 | 1 |
(* Title: HOL/Tools/BNF/bnf_def.ML |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2 |
Author: Dmitriy Traytel, TU Muenchen |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
3 |
Author: Jasmin Blanchette, TU Muenchen |
57668 | 4 |
Author: Martin Desharnais, TU Muenchen |
5 |
Copyright 2012, 2013, 2014 |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
6 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
7 |
Definition of bounded natural functors. |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
8 |
*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
9 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
10 |
signature BNF_DEF = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
11 |
sig |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
12 |
type bnf |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
13 |
type nonemptiness_witness = {I: int list, wit: term, prop: thm list} |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
14 |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
15 |
val morph_bnf: morphism -> bnf -> bnf |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
16 |
val morph_bnf_defs: morphism -> bnf -> bnf |
64440 | 17 |
val permute_deads: (typ list -> typ list) -> bnf -> bnf |
58175 | 18 |
val transfer_bnf: theory -> bnf -> bnf |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
19 |
val bnf_of: Proof.context -> string -> bnf option |
58116 | 20 |
val bnf_of_global: theory -> string -> bnf option |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
21 |
val bnf_interpretation: string -> (bnf -> local_theory -> local_theory) -> theory -> theory |
58188 | 22 |
val interpret_bnf: (string -> bool) -> bnf -> local_theory -> local_theory |
58177
166131276380
introduced local interpretation mechanism for BNFs, to solve issues with datatypes in locales
blanchet
parents:
58175
diff
changeset
|
23 |
val register_bnf_raw: string -> bnf -> local_theory -> local_theory |
58188 | 24 |
val register_bnf: (string -> bool) -> string -> bnf -> local_theory -> local_theory |
49434
433dc7e028c8
separated registration of BNFs from bnf_def (BNFs are now stored only for bnf_def and (co)data commands)
traytel
parents:
49430
diff
changeset
|
25 |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
26 |
val name_of_bnf: bnf -> binding |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
27 |
val T_of_bnf: bnf -> typ |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
28 |
val live_of_bnf: bnf -> int |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
29 |
val lives_of_bnf: bnf -> typ list |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
30 |
val dead_of_bnf: bnf -> int |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
31 |
val deads_of_bnf: bnf -> typ list |
56346 | 32 |
val bd_of_bnf: bnf -> term |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
33 |
val nwits_of_bnf: bnf -> int |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
34 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
35 |
val mapN: string |
62324 | 36 |
val predN: string |
49507 | 37 |
val relN: string |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
38 |
val setN: string |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
39 |
val mk_setN: int -> string |
55025
1ac0a0194428
support declaration of nonemptiness witnesses in bnf_decl
traytel
parents:
54921
diff
changeset
|
40 |
val mk_witN: int -> string |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
41 |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
42 |
val map_of_bnf: bnf -> term |
62324 | 43 |
val pred_of_bnf: bnf -> term |
44 |
val rel_of_bnf: bnf -> term |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
45 |
val sets_of_bnf: bnf -> term list |
49214
2a3cb4c71b87
construct the right iterator theorem in the recursive case
blanchet
parents:
49123
diff
changeset
|
46 |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
47 |
val mk_T_of_bnf: typ list -> typ list -> bnf -> typ |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
48 |
val mk_bd_of_bnf: typ list -> typ list -> bnf -> term |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
49 |
val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term |
62324 | 50 |
val mk_pred_of_bnf: typ list -> typ list -> bnf -> term |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
51 |
val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
52 |
val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
53 |
val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
54 |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
55 |
val bd_Card_order_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
56 |
val bd_Cinfinite_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
57 |
val bd_Cnotzero_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
58 |
val bd_card_order_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
59 |
val bd_cinfinite_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
60 |
val collect_set_map_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
61 |
val in_bd_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
62 |
val in_cong_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
63 |
val in_mono_of_bnf: bnf -> thm |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
64 |
val in_rel_of_bnf: bnf -> thm |
56635 | 65 |
val inj_map_of_bnf: bnf -> thm |
57970 | 66 |
val inj_map_strong_of_bnf: bnf -> thm |
62324 | 67 |
val le_rel_OO_of_bnf: bnf -> thm |
53287 | 68 |
val map_comp0_of_bnf: bnf -> thm |
53288 | 69 |
val map_comp_of_bnf: bnf -> thm |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
70 |
val map_cong0_of_bnf: bnf -> thm |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
71 |
val map_cong_of_bnf: bnf -> thm |
62324 | 72 |
val map_cong_pred_of_bnf: bnf -> thm |
57981 | 73 |
val map_cong_simp_of_bnf: bnf -> thm |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
74 |
val map_def_of_bnf: bnf -> thm |
53270 | 75 |
val map_id0_of_bnf: bnf -> thm |
53285 | 76 |
val map_id_of_bnf: bnf -> thm |
57399 | 77 |
val map_ident0_of_bnf: bnf -> thm |
56903 | 78 |
val map_ident_of_bnf: bnf -> thm |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
79 |
val map_transfer_of_bnf: bnf -> thm |
62324 | 80 |
val pred_cong0_of_bnf: bnf -> thm |
81 |
val pred_cong_of_bnf: bnf -> thm |
|
82 |
val pred_cong_simp_of_bnf: bnf -> thm |
|
83 |
val pred_def_of_bnf: bnf -> thm |
|
84 |
val pred_map_of_bnf: bnf -> thm |
|
85 |
val pred_mono_strong0_of_bnf: bnf -> thm |
|
86 |
val pred_mono_strong_of_bnf: bnf -> thm |
|
63714 | 87 |
val pred_mono_of_bnf: bnf -> thm |
62324 | 88 |
val pred_set_of_bnf: bnf -> thm |
89 |
val pred_rel_of_bnf: bnf -> thm |
|
62329 | 90 |
val pred_transfer_of_bnf: bnf -> thm |
91 |
val pred_True_of_bnf: bnf -> thm |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
92 |
val rel_Grp_of_bnf: bnf -> thm |
62324 | 93 |
val rel_OO_Grp_of_bnf: bnf -> thm |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
94 |
val rel_OO_of_bnf: bnf -> thm |
61242 | 95 |
val rel_cong0_of_bnf: bnf -> thm |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
96 |
val rel_cong_of_bnf: bnf -> thm |
61242 | 97 |
val rel_cong_simp_of_bnf: bnf -> thm |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
98 |
val rel_conversep_of_bnf: bnf -> thm |
62324 | 99 |
val rel_def_of_bnf: bnf -> thm |
100 |
val rel_eq_of_bnf: bnf -> thm |
|
101 |
val rel_flip_of_bnf: bnf -> thm |
|
102 |
val rel_map_of_bnf: bnf -> thm list |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
103 |
val rel_mono_of_bnf: bnf -> thm |
57967 | 104 |
val rel_mono_strong0_of_bnf: bnf -> thm |
57968 | 105 |
val rel_mono_strong_of_bnf: bnf -> thm |
62324 | 106 |
val rel_eq_onp_of_bnf: bnf -> thm |
59726 | 107 |
val rel_refl_of_bnf: bnf -> thm |
61240 | 108 |
val rel_refl_strong_of_bnf: bnf -> thm |
109 |
val rel_reflp_of_bnf: bnf -> thm |
|
110 |
val rel_symp_of_bnf: bnf -> thm |
|
62324 | 111 |
val rel_transfer_of_bnf: bnf -> thm |
61240 | 112 |
val rel_transp_of_bnf: bnf -> thm |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
113 |
val set_bd_of_bnf: bnf -> thm list |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
114 |
val set_defs_of_bnf: bnf -> thm list |
53289 | 115 |
val set_map0_of_bnf: bnf -> thm list |
53290 | 116 |
val set_map_of_bnf: bnf -> thm list |
58106 | 117 |
val set_transfer_of_bnf: bnf -> thm list |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
118 |
val wit_thms_of_bnf: bnf -> thm list |
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
119 |
val wit_thmss_of_bnf: bnf -> thm list list |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
120 |
|
54236 | 121 |
val mk_map: int -> typ list -> typ list -> term -> term |
62326
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62324
diff
changeset
|
122 |
val mk_pred: typ list -> term -> term |
54236 | 123 |
val mk_rel: int -> typ list -> typ list -> term -> term |
63851 | 124 |
val mk_set: typ list -> term -> term |
64627
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
125 |
val build_map: Proof.context -> typ list -> typ list -> (typ * typ -> term) -> typ * typ -> term |
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
126 |
val build_rel: (string * (int * term)) list -> Proof.context -> typ list -> typ list -> |
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
127 |
(typ * typ -> term) -> typ * typ -> term |
63851 | 128 |
val build_set: Proof.context -> typ -> typ -> term |
54246
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
129 |
val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
130 |
val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list -> |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
131 |
'a list |
54236 | 132 |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
133 |
val mk_witness: int list * term -> thm list -> nonemptiness_witness |
60918
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
134 |
val mk_wit_goals: term list -> term list -> term list -> int list * term -> term list |
49103 | 135 |
val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
136 |
val wits_of_bnf: bnf -> nonemptiness_witness list |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
137 |
|
62324 | 138 |
val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list |
49456 | 139 |
|
55854
ee270328a781
make 'typedef' optional, depending on size of original type
blanchet
parents:
55480
diff
changeset
|
140 |
datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline |
49538 | 141 |
datatype fact_policy = Dont_Note | Note_Some | Note_All |
142 |
||
62093 | 143 |
val bnf_internals: bool Config.T |
53143
ba80154a1118
configuration option to control timing output for (co)datatypes
traytel
parents:
53126
diff
changeset
|
144 |
val bnf_timing: bool Config.T |
49435 | 145 |
val user_policy: fact_policy -> Proof.context -> fact_policy |
66272
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
146 |
val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> local_theory -> |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
147 |
bnf * local_theory |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
148 |
val note_bnf_defs: bnf -> local_theory -> bnf * local_theory |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
149 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
150 |
val print_bnfs: Proof.context -> unit |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
151 |
val prepare_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
152 |
(binding -> binding) -> (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> |
62324 | 153 |
typ list option -> binding -> binding -> binding -> binding list -> |
154 |
((((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option) * 'b option -> |
|
155 |
Proof.context -> |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
156 |
string * term list * ((Proof.context -> thm list -> tactic) option * term list list) * |
54601
91a1e4aa7c80
command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents:
54490
diff
changeset
|
157 |
((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) * |
91a1e4aa7c80
command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents:
54490
diff
changeset
|
158 |
local_theory * thm list |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
159 |
val define_bnf_consts: inline_policy -> fact_policy -> bool -> typ list option -> |
62324 | 160 |
binding -> binding -> binding -> binding list -> |
161 |
((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option -> |
|
162 |
local_theory -> |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
163 |
((typ list * typ list * typ list * typ) * |
62324 | 164 |
(term * term list * term * (int list * term) list * term * term) * |
165 |
(thm * thm list * thm * thm list * thm * thm) * |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
166 |
((typ list -> typ list -> typ list -> term) * |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
167 |
(typ list -> typ list -> term -> term) * |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
168 |
(typ list -> typ list -> typ -> typ) * |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
169 |
(typ list -> typ list -> typ list -> term) * |
62324 | 170 |
(typ list -> typ list -> term) * |
171 |
(typ list -> typ list -> typ list -> term) * |
|
172 |
(typ list -> typ list -> term))) * local_theory |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
173 |
|
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
174 |
val bnf_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> (binding -> binding) -> |
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
175 |
(Proof.context -> tactic) list -> (Proof.context -> tactic) -> typ list option -> binding -> |
62324 | 176 |
binding -> binding -> binding list -> |
177 |
((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option -> |
|
178 |
local_theory -> bnf * local_theory |
|
179 |
val bnf_cmd: (((((((binding * string) * string) * string list) * string) * string list) |
|
180 |
* string option) * string option) * (Proof.context -> Plugin_Name.filter) -> |
|
61301 | 181 |
Proof.context -> Proof.state |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
182 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
183 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
184 |
structure BNF_Def : BNF_DEF = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
185 |
struct |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
186 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
187 |
open BNF_Util |
49463 | 188 |
open BNF_Tactics |
49284 | 189 |
open BNF_Def_Tactics |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
190 |
|
54624
36301c99ed26
revert making 'map_cong' a 'cong' -- it breaks too many proofs in the AFP
blanchet
parents:
54620
diff
changeset
|
191 |
val fundefcong_attrs = @{attributes [fundef_cong]}; |
58344 | 192 |
val mono_attrs = @{attributes [mono]}; |
51765 | 193 |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
194 |
type axioms = { |
53270 | 195 |
map_id0: thm, |
53287 | 196 |
map_comp0: thm, |
51761
4c9f08836d87
renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents:
51758
diff
changeset
|
197 |
map_cong0: thm, |
53289 | 198 |
set_map0: thm list, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
199 |
bd_card_order: thm, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
200 |
bd_cinfinite: thm, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
201 |
set_bd: thm list, |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
202 |
le_rel_OO: thm, |
62324 | 203 |
rel_OO_Grp: thm, |
204 |
pred_set: thm |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
205 |
}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
206 |
|
62324 | 207 |
fun mk_axioms' (((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel), pred) = |
53289 | 208 |
{map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o, |
62324 | 209 |
bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel, pred_set = pred}; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
210 |
|
51930
52fd62618631
prefer explicitly qualified exceptions, which is particular important for robust handlers;
wenzelm
parents:
51917
diff
changeset
|
211 |
fun dest_cons [] = raise List.Empty |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
212 |
| dest_cons (x :: xs) = (x, xs); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
213 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
214 |
fun mk_axioms n thms = thms |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
215 |
|> map the_single |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
216 |
|> dest_cons |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
217 |
||>> dest_cons |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
218 |
||>> dest_cons |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
219 |
||>> chop n |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
220 |
||>> dest_cons |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
221 |
||>> dest_cons |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
222 |
||>> chop n |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
223 |
||>> dest_cons |
62324 | 224 |
||>> dest_cons |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
225 |
||> the_single |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
226 |
|> mk_axioms'; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
227 |
|
62324 | 228 |
fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel pred = |
229 |
[mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel, pred]; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
230 |
|
53289 | 231 |
fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd, |
62482 | 232 |
le_rel_OO, rel_OO_Grp, pred_set} = |
53270 | 233 |
{map_id0 = f map_id0, |
53287 | 234 |
map_comp0 = f map_comp0, |
51761
4c9f08836d87
renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents:
51758
diff
changeset
|
235 |
map_cong0 = f map_cong0, |
53289 | 236 |
set_map0 = map f set_map0, |
49463 | 237 |
bd_card_order = f bd_card_order, |
238 |
bd_cinfinite = f bd_cinfinite, |
|
239 |
set_bd = map f set_bd, |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
240 |
le_rel_OO = f le_rel_OO, |
62324 | 241 |
rel_OO_Grp = f rel_OO_Grp, |
242 |
pred_set = f pred_set}; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
243 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
244 |
val morph_axioms = map_axioms o Morphism.thm; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
245 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
246 |
type defs = { |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
247 |
map_def: thm, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
248 |
set_defs: thm list, |
62324 | 249 |
rel_def: thm, |
250 |
pred_def: thm |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
251 |
} |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
252 |
|
62324 | 253 |
fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred}; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
254 |
|
62324 | 255 |
fun map_defs f {map_def, set_defs, rel_def, pred_def} = |
256 |
{map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def, pred_def = f pred_def}; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
257 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
258 |
val morph_defs = map_defs o Morphism.thm; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
259 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
260 |
type facts = { |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
261 |
bd_Card_order: thm, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
262 |
bd_Cinfinite: thm, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
263 |
bd_Cnotzero: thm, |
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
264 |
collect_set_map: thm lazy, |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
265 |
in_bd: thm lazy, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
266 |
in_cong: thm lazy, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
267 |
in_mono: thm lazy, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
268 |
in_rel: thm lazy, |
56635 | 269 |
inj_map: thm lazy, |
57970 | 270 |
inj_map_strong: thm lazy, |
53288 | 271 |
map_comp: thm lazy, |
51762 | 272 |
map_cong: thm lazy, |
57981 | 273 |
map_cong_simp: thm lazy, |
62324 | 274 |
map_cong_pred: thm lazy, |
53285 | 275 |
map_id: thm lazy, |
57399 | 276 |
map_ident0: thm lazy, |
56903 | 277 |
map_ident: thm lazy, |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
278 |
map_transfer: thm lazy, |
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49585
diff
changeset
|
279 |
rel_eq: thm lazy, |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
280 |
rel_flip: thm lazy, |
53290 | 281 |
set_map: thm lazy list, |
61242 | 282 |
rel_cong0: thm lazy, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
283 |
rel_cong: thm lazy, |
61242 | 284 |
rel_cong_simp: thm lazy, |
57932 | 285 |
rel_map: thm list lazy, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
286 |
rel_mono: thm lazy, |
57967 | 287 |
rel_mono_strong0: thm lazy, |
57968 | 288 |
rel_mono_strong: thm lazy, |
58106 | 289 |
set_transfer: thm list lazy, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
290 |
rel_Grp: thm lazy, |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
291 |
rel_conversep: thm lazy, |
58106 | 292 |
rel_OO: thm lazy, |
59726 | 293 |
rel_refl: thm lazy, |
61240 | 294 |
rel_refl_strong: thm lazy, |
295 |
rel_reflp: thm lazy, |
|
296 |
rel_symp: thm lazy, |
|
297 |
rel_transp: thm lazy, |
|
62324 | 298 |
rel_transfer: thm lazy, |
299 |
rel_eq_onp: thm lazy, |
|
62329 | 300 |
pred_transfer: thm lazy, |
62324 | 301 |
pred_True: thm lazy, |
302 |
pred_map: thm lazy, |
|
303 |
pred_rel: thm lazy, |
|
304 |
pred_mono_strong0: thm lazy, |
|
305 |
pred_mono_strong: thm lazy, |
|
63714 | 306 |
pred_mono: thm lazy, |
62324 | 307 |
pred_cong0: thm lazy, |
308 |
pred_cong: thm lazy, |
|
309 |
pred_cong_simp: thm lazy |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
310 |
}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
311 |
|
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
312 |
fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel |
62324 | 313 |
inj_map inj_map_strong map_comp map_cong map_cong_simp map_cong_pred map_id map_ident0 map_ident |
314 |
map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp rel_map rel_mono |
|
315 |
rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep rel_OO rel_refl |
|
62329 | 316 |
rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp pred_transfer pred_True |
63714 | 317 |
pred_map pred_rel pred_mono_strong0 pred_mono_strong pred_mono pred_cong0 pred_cong |
318 |
pred_cong_simp = { |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
319 |
bd_Card_order = bd_Card_order, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
320 |
bd_Cinfinite = bd_Cinfinite, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
321 |
bd_Cnotzero = bd_Cnotzero, |
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
322 |
collect_set_map = collect_set_map, |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
323 |
in_bd = in_bd, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
324 |
in_cong = in_cong, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
325 |
in_mono = in_mono, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
326 |
in_rel = in_rel, |
56635 | 327 |
inj_map = inj_map, |
57970 | 328 |
inj_map_strong = inj_map_strong, |
53288 | 329 |
map_comp = map_comp, |
51762 | 330 |
map_cong = map_cong, |
57981 | 331 |
map_cong_simp = map_cong_simp, |
62324 | 332 |
map_cong_pred = map_cong_pred, |
53285 | 333 |
map_id = map_id, |
57399 | 334 |
map_ident0 = map_ident0, |
56903 | 335 |
map_ident = map_ident, |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
336 |
map_transfer = map_transfer, |
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49585
diff
changeset
|
337 |
rel_eq = rel_eq, |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
338 |
rel_flip = rel_flip, |
53290 | 339 |
set_map = set_map, |
61242 | 340 |
rel_cong0 = rel_cong0, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
341 |
rel_cong = rel_cong, |
61242 | 342 |
rel_cong_simp = rel_cong_simp, |
57932 | 343 |
rel_map = rel_map, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
344 |
rel_mono = rel_mono, |
57967 | 345 |
rel_mono_strong0 = rel_mono_strong0, |
57968 | 346 |
rel_mono_strong = rel_mono_strong, |
58104 | 347 |
rel_transfer = rel_transfer, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
348 |
rel_Grp = rel_Grp, |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
349 |
rel_conversep = rel_conversep, |
58106 | 350 |
rel_OO = rel_OO, |
59726 | 351 |
rel_refl = rel_refl, |
61240 | 352 |
rel_refl_strong = rel_refl_strong, |
353 |
rel_reflp = rel_reflp, |
|
354 |
rel_symp = rel_symp, |
|
355 |
rel_transp = rel_transp, |
|
62324 | 356 |
set_transfer = set_transfer, |
357 |
rel_eq_onp = rel_eq_onp, |
|
62329 | 358 |
pred_transfer = pred_transfer, |
62324 | 359 |
pred_True = pred_True, |
360 |
pred_map = pred_map, |
|
361 |
pred_rel = pred_rel, |
|
362 |
pred_mono_strong0 = pred_mono_strong0, |
|
363 |
pred_mono_strong = pred_mono_strong, |
|
63714 | 364 |
pred_mono = pred_mono, |
62324 | 365 |
pred_cong0 = pred_cong0, |
366 |
pred_cong = pred_cong, |
|
367 |
pred_cong_simp = pred_cong_simp}; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
368 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
369 |
fun map_facts f { |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
370 |
bd_Card_order, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
371 |
bd_Cinfinite, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
372 |
bd_Cnotzero, |
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
373 |
collect_set_map, |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
374 |
in_bd, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
375 |
in_cong, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
376 |
in_mono, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
377 |
in_rel, |
56635 | 378 |
inj_map, |
57970 | 379 |
inj_map_strong, |
53288 | 380 |
map_comp, |
51762 | 381 |
map_cong, |
57981 | 382 |
map_cong_simp, |
62324 | 383 |
map_cong_pred, |
53285 | 384 |
map_id, |
57399 | 385 |
map_ident0, |
56903 | 386 |
map_ident, |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
387 |
map_transfer, |
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49585
diff
changeset
|
388 |
rel_eq, |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
389 |
rel_flip, |
53290 | 390 |
set_map, |
61242 | 391 |
rel_cong0, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
392 |
rel_cong, |
61242 | 393 |
rel_cong_simp, |
57932 | 394 |
rel_map, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
395 |
rel_mono, |
57967 | 396 |
rel_mono_strong0, |
57968 | 397 |
rel_mono_strong, |
58104 | 398 |
rel_transfer, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
399 |
rel_Grp, |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
400 |
rel_conversep, |
58106 | 401 |
rel_OO, |
59726 | 402 |
rel_refl, |
61240 | 403 |
rel_refl_strong, |
404 |
rel_reflp, |
|
405 |
rel_symp, |
|
406 |
rel_transp, |
|
62324 | 407 |
set_transfer, |
408 |
rel_eq_onp, |
|
62329 | 409 |
pred_transfer, |
62324 | 410 |
pred_True, |
411 |
pred_map, |
|
412 |
pred_rel, |
|
413 |
pred_mono_strong0, |
|
414 |
pred_mono_strong, |
|
63714 | 415 |
pred_mono, |
62324 | 416 |
pred_cong0, |
417 |
pred_cong, |
|
418 |
pred_cong_simp} = |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
419 |
{bd_Card_order = f bd_Card_order, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
420 |
bd_Cinfinite = f bd_Cinfinite, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
421 |
bd_Cnotzero = f bd_Cnotzero, |
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
422 |
collect_set_map = Lazy.map f collect_set_map, |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
423 |
in_bd = Lazy.map f in_bd, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
424 |
in_cong = Lazy.map f in_cong, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
425 |
in_mono = Lazy.map f in_mono, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
426 |
in_rel = Lazy.map f in_rel, |
56635 | 427 |
inj_map = Lazy.map f inj_map, |
57970 | 428 |
inj_map_strong = Lazy.map f inj_map_strong, |
53288 | 429 |
map_comp = Lazy.map f map_comp, |
51762 | 430 |
map_cong = Lazy.map f map_cong, |
57981 | 431 |
map_cong_simp = Lazy.map f map_cong_simp, |
62324 | 432 |
map_cong_pred = Lazy.map f map_cong_pred, |
53285 | 433 |
map_id = Lazy.map f map_id, |
57399 | 434 |
map_ident0 = Lazy.map f map_ident0, |
56903 | 435 |
map_ident = Lazy.map f map_ident, |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
436 |
map_transfer = Lazy.map f map_transfer, |
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49585
diff
changeset
|
437 |
rel_eq = Lazy.map f rel_eq, |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
438 |
rel_flip = Lazy.map f rel_flip, |
53290 | 439 |
set_map = map (Lazy.map f) set_map, |
61242 | 440 |
rel_cong0 = Lazy.map f rel_cong0, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
441 |
rel_cong = Lazy.map f rel_cong, |
61242 | 442 |
rel_cong_simp = Lazy.map f rel_cong_simp, |
57932 | 443 |
rel_map = Lazy.map (map f) rel_map, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
444 |
rel_mono = Lazy.map f rel_mono, |
57967 | 445 |
rel_mono_strong0 = Lazy.map f rel_mono_strong0, |
57968 | 446 |
rel_mono_strong = Lazy.map f rel_mono_strong, |
58104 | 447 |
rel_transfer = Lazy.map f rel_transfer, |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
448 |
rel_Grp = Lazy.map f rel_Grp, |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
449 |
rel_conversep = Lazy.map f rel_conversep, |
58106 | 450 |
rel_OO = Lazy.map f rel_OO, |
59726 | 451 |
rel_refl = Lazy.map f rel_refl, |
61240 | 452 |
rel_refl_strong = Lazy.map f rel_refl_strong, |
453 |
rel_reflp = Lazy.map f rel_reflp, |
|
454 |
rel_symp = Lazy.map f rel_symp, |
|
455 |
rel_transp = Lazy.map f rel_transp, |
|
62324 | 456 |
set_transfer = Lazy.map (map f) set_transfer, |
457 |
rel_eq_onp = Lazy.map f rel_eq_onp, |
|
62329 | 458 |
pred_transfer = Lazy.map f pred_transfer, |
62324 | 459 |
pred_True = Lazy.map f pred_True, |
460 |
pred_map = Lazy.map f pred_map, |
|
461 |
pred_rel = Lazy.map f pred_rel, |
|
462 |
pred_mono_strong0 = Lazy.map f pred_mono_strong0, |
|
463 |
pred_mono_strong = Lazy.map f pred_mono_strong, |
|
63714 | 464 |
pred_mono = Lazy.map f pred_mono, |
62324 | 465 |
pred_cong0 = Lazy.map f pred_cong0, |
466 |
pred_cong = Lazy.map f pred_cong, |
|
467 |
pred_cong_simp = Lazy.map f pred_cong_simp}; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
468 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
469 |
val morph_facts = map_facts o Morphism.thm; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
470 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
471 |
type nonemptiness_witness = { |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
472 |
I: int list, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
473 |
wit: term, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
474 |
prop: thm list |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
475 |
}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
476 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
477 |
fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
478 |
fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
479 |
fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
480 |
|
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
481 |
datatype bnf = BNF of { |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
482 |
name: binding, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
483 |
T: typ, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
484 |
live: int, |
53261 | 485 |
lives: typ list, (*source type variables of map*) |
486 |
lives': typ list, (*target type variables of map*) |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
487 |
dead: int, |
53261 | 488 |
deads: typ list, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
489 |
map: term, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
490 |
sets: term list, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
491 |
bd: term, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
492 |
axioms: axioms, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
493 |
defs: defs, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
494 |
facts: facts, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
495 |
nwits: int, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
496 |
wits: nonemptiness_witness list, |
62324 | 497 |
rel: term, |
498 |
pred: term |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
499 |
}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
500 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
501 |
(* getters *) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
502 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
503 |
fun rep_bnf (BNF bnf) = bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
504 |
val name_of_bnf = #name o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
505 |
val T_of_bnf = #T o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
506 |
fun mk_T_of_bnf Ds Ts bnf = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
507 |
let val bnf_rep = rep_bnf bnf |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
508 |
in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
509 |
val live_of_bnf = #live o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
510 |
val lives_of_bnf = #lives o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
511 |
val dead_of_bnf = #dead o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
512 |
val deads_of_bnf = #deads o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
513 |
val axioms_of_bnf = #axioms o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
514 |
val facts_of_bnf = #facts o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
515 |
val nwits_of_bnf = #nwits o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
516 |
val wits_of_bnf = #wits o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
517 |
|
53031 | 518 |
fun flatten_type_args_of_bnf bnf dead_x xs = |
519 |
let |
|
520 |
val Type (_, Ts) = T_of_bnf bnf; |
|
521 |
val lives = lives_of_bnf bnf; |
|
522 |
val deads = deads_of_bnf bnf; |
|
523 |
in |
|
55480
59cc4a8bc28a
allow different functions to recurse on the same type, like in the old package
blanchet
parents:
55444
diff
changeset
|
524 |
permute_like_unique (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs) |
53031 | 525 |
end; |
526 |
||
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
527 |
(*terms*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
528 |
val map_of_bnf = #map o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
529 |
val sets_of_bnf = #sets o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
530 |
fun mk_map_of_bnf Ds Ts Us bnf = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
531 |
let val bnf_rep = rep_bnf bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
532 |
in |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
533 |
Term.subst_atomic_types |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
534 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
535 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
536 |
fun mk_sets_of_bnf Dss Tss bnf = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
537 |
let val bnf_rep = rep_bnf bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
538 |
in |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
539 |
map2 (fn (Ds, Ts) => Term.subst_atomic_types |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
540 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
541 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
542 |
val bd_of_bnf = #bd o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
543 |
fun mk_bd_of_bnf Ds Ts bnf = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
544 |
let val bnf_rep = rep_bnf bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
545 |
in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
546 |
fun mk_wits_of_bnf Dss Tss bnf = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
547 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
548 |
val bnf_rep = rep_bnf bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
549 |
val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
550 |
in |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
551 |
map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
552 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
553 |
end; |
49507 | 554 |
val rel_of_bnf = #rel o rep_bnf; |
555 |
fun mk_rel_of_bnf Ds Ts Us bnf = |
|
49462 | 556 |
let val bnf_rep = rep_bnf bnf; |
557 |
in |
|
558 |
Term.subst_atomic_types |
|
49507 | 559 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep) |
49462 | 560 |
end; |
62324 | 561 |
val pred_of_bnf = #pred o rep_bnf; |
562 |
fun mk_pred_of_bnf Ds Ts bnf = |
|
563 |
let val bnf_rep = rep_bnf bnf; |
|
564 |
in |
|
565 |
Term.subst_atomic_types |
|
566 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#pred bnf_rep) |
|
567 |
end; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
568 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
569 |
(*thms*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
570 |
val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
571 |
val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
572 |
val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf; |
62324 | 573 |
val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf; |
574 |
val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf; |
|
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
575 |
val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf; |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
576 |
val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
577 |
val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
578 |
val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf; |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
579 |
val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf; |
56635 | 580 |
val inj_map_of_bnf = Lazy.force o #inj_map o #facts o rep_bnf; |
57970 | 581 |
val inj_map_strong_of_bnf = Lazy.force o #inj_map_strong o #facts o rep_bnf; |
62324 | 582 |
val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf; |
583 |
val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf; |
|
584 |
val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf; |
|
585 |
val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf; |
|
586 |
val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf; |
|
587 |
val map_cong_pred_of_bnf = Lazy.force o #map_cong_pred o #facts o rep_bnf; |
|
588 |
val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
589 |
val map_def_of_bnf = #map_def o #defs o rep_bnf; |
53270 | 590 |
val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf; |
53285 | 591 |
val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf; |
57399 | 592 |
val map_ident0_of_bnf = Lazy.force o #map_ident0 o #facts o rep_bnf; |
56903 | 593 |
val map_ident_of_bnf = Lazy.force o #map_ident o #facts o rep_bnf; |
52731 | 594 |
val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf; |
62324 | 595 |
val rel_eq_onp_of_bnf = Lazy.force o #rel_eq_onp o #facts o rep_bnf; |
62329 | 596 |
val pred_def_of_bnf = #pred_def o #defs o rep_bnf; |
62324 | 597 |
val pred_map_of_bnf = Lazy.force o #pred_map o #facts o rep_bnf; |
598 |
val pred_mono_strong0_of_bnf = Lazy.force o #pred_mono_strong0 o #facts o rep_bnf; |
|
599 |
val pred_mono_strong_of_bnf = Lazy.force o #pred_mono_strong o #facts o rep_bnf; |
|
63714 | 600 |
val pred_mono_of_bnf = Lazy.force o #pred_mono o #facts o rep_bnf; |
62324 | 601 |
val pred_cong0_of_bnf = Lazy.force o #pred_cong0 o #facts o rep_bnf; |
602 |
val pred_cong_of_bnf = Lazy.force o #pred_cong o #facts o rep_bnf; |
|
603 |
val pred_cong_simp_of_bnf = Lazy.force o #pred_cong_simp o #facts o rep_bnf; |
|
62329 | 604 |
val pred_rel_of_bnf = Lazy.force o #pred_rel o #facts o rep_bnf; |
62324 | 605 |
val pred_set_of_bnf = #pred_set o #axioms o rep_bnf; |
62329 | 606 |
val pred_transfer_of_bnf = Lazy.force o #pred_transfer o #facts o rep_bnf; |
607 |
val pred_True_of_bnf = Lazy.force o #pred_True o #facts o rep_bnf; |
|
62324 | 608 |
val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf; |
609 |
val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf; |
|
610 |
val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf; |
|
611 |
val rel_cong0_of_bnf = Lazy.force o #rel_cong0 o #facts o rep_bnf; |
|
612 |
val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf; |
|
613 |
val rel_cong_simp_of_bnf = Lazy.force o #rel_cong_simp o #facts o rep_bnf; |
|
614 |
val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf; |
|
49507 | 615 |
val rel_def_of_bnf = #rel_def o #defs o rep_bnf; |
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49585
diff
changeset
|
616 |
val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf; |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
617 |
val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf; |
62324 | 618 |
val rel_map_of_bnf = Lazy.force o #rel_map o #facts o rep_bnf; |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
619 |
val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf; |
57967 | 620 |
val rel_mono_strong0_of_bnf = Lazy.force o #rel_mono_strong0 o #facts o rep_bnf; |
57968 | 621 |
val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf; |
59726 | 622 |
val rel_refl_of_bnf = Lazy.force o #rel_refl o #facts o rep_bnf; |
61240 | 623 |
val rel_refl_strong_of_bnf = Lazy.force o #rel_refl_strong o #facts o rep_bnf; |
624 |
val rel_reflp_of_bnf = Lazy.force o #rel_reflp o #facts o rep_bnf; |
|
625 |
val rel_symp_of_bnf = Lazy.force o #rel_symp o #facts o rep_bnf; |
|
62324 | 626 |
val rel_transfer_of_bnf = Lazy.force o #rel_transfer o #facts o rep_bnf; |
61240 | 627 |
val rel_transp_of_bnf = Lazy.force o #rel_transp o #facts o rep_bnf; |
62324 | 628 |
val set_bd_of_bnf = #set_bd o #axioms o rep_bnf; |
629 |
val set_defs_of_bnf = #set_defs o #defs o rep_bnf; |
|
630 |
val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf; |
|
631 |
val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf; |
|
632 |
val set_transfer_of_bnf = Lazy.force o #set_transfer o #facts o rep_bnf; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
633 |
val wit_thms_of_bnf = maps #prop o wits_of_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
634 |
val wit_thmss_of_bnf = map #prop o wits_of_bnf; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
635 |
|
62324 | 636 |
fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
637 |
BNF {name = name, T = T, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
638 |
live = live, lives = lives, lives' = lives', dead = dead, deads = deads, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
639 |
map = map, sets = sets, bd = bd, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
640 |
axioms = axioms, defs = defs, facts = facts, |
62324 | 641 |
nwits = length wits, wits = wits, rel = rel, pred = pred}; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
642 |
|
62324 | 643 |
fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
644 |
(BNF {name = name, T = T, live = live, lives = lives, lives' = lives', |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
645 |
dead = dead, deads = deads, map = map, sets = sets, bd = bd, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
646 |
axioms = axioms, defs = defs, facts = facts, |
62324 | 647 |
nwits = nwits, wits = wits, rel = rel, pred = pred}) = |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
648 |
BNF {name = f1 name, T = f2 T, |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
649 |
live = f3 live, lives = f4 lives, lives' = f5 lives', dead = f6 dead, deads = f7 deads, |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
650 |
map = f8 map, sets = f9 sets, bd = f10 bd, |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
651 |
axioms = f11 axioms, defs = f12 defs, facts = f13 facts, |
62324 | 652 |
nwits = f14 nwits, wits = f15 wits, rel = f16 rel, pred = f17 pred}; |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
653 |
|
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
654 |
fun morph_bnf phi = |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
655 |
let |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
656 |
val Tphi = Morphism.typ phi; |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
657 |
val tphi = Morphism.term phi; |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
658 |
in |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
659 |
map_bnf (Morphism.binding phi) Tphi I (map Tphi) (map Tphi) I (map Tphi) tphi (map tphi) tphi |
62324 | 660 |
(morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi tphi |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
661 |
end; |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
662 |
|
62324 | 663 |
fun morph_bnf_defs phi = map_bnf I I I I I I I I I I I (morph_defs phi) I I I I I; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
664 |
|
64440 | 665 |
fun permute_deads perm = map_bnf I I I I I I perm I I I I I I I I I I; |
666 |
||
58175 | 667 |
val transfer_bnf = morph_bnf o Morphism.transfer_morphism; |
668 |
||
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
669 |
structure Data = Generic_Data |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
670 |
( |
51837
087498724486
lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents:
51836
diff
changeset
|
671 |
type T = bnf Symtab.table; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
672 |
val empty = Symtab.empty; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
673 |
val extend = I; |
55394
d5ebe055b599
more liberal merging of BNFs and constructor sugar
blanchet
parents:
55356
diff
changeset
|
674 |
fun merge data : T = Symtab.merge (K true) data; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
675 |
); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
676 |
|
58116 | 677 |
fun bnf_of_generic context = |
58175 | 678 |
Option.map (transfer_bnf (Context.theory_of context)) o Symtab.lookup (Data.get context); |
58116 | 679 |
|
680 |
val bnf_of = bnf_of_generic o Context.Proof; |
|
681 |
val bnf_of_global = bnf_of_generic o Context.Theory; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
682 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
683 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
684 |
(* Utilities *) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
685 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
686 |
fun normalize_set insts instA set = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
687 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
688 |
val (T, T') = dest_funT (fastype_of set); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
689 |
val A = fst (Term.dest_TVar (HOLogic.dest_setT T')); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
690 |
val params = Term.add_tvar_namesT T []; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
691 |
in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
692 |
|
49507 | 693 |
fun normalize_rel ctxt instTs instA instB rel = |
49462 | 694 |
let |
695 |
val thy = Proof_Context.theory_of ctxt; |
|
696 |
val tyenv = |
|
49507 | 697 |
Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB)) |
49463 | 698 |
Vartab.empty; |
49507 | 699 |
in Envir.subst_term (tyenv, Vartab.empty) rel end |
49453 | 700 |
handle Type.TYPE_MATCH => error "Bad relator"; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
701 |
|
62324 | 702 |
fun normalize_pred ctxt instTs instA pred = |
703 |
let |
|
704 |
val thy = Proof_Context.theory_of ctxt; |
|
705 |
val tyenv = |
|
706 |
Sign.typ_match thy (fastype_of pred, Library.foldr (op -->) (instTs, mk_pred1T instA)) |
|
707 |
Vartab.empty; |
|
708 |
in Envir.subst_term (tyenv, Vartab.empty) pred end |
|
709 |
handle Type.TYPE_MATCH => error "Bad predicator"; |
|
710 |
||
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
711 |
fun normalize_wit insts CA As wit = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
712 |
let |
69593 | 713 |
fun strip_param (Ts, T as Type (\<^type_name>\<open>fun\<close>, [T1, T2])) = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
714 |
if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
715 |
| strip_param x = x; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
716 |
val (Ts, T) = strip_param ([], fastype_of wit); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
717 |
val subst = Term.add_tvar_namesT T [] ~~ insts; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
718 |
fun find y = find_index (fn x => x = y) As; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
719 |
in |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
720 |
(map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
721 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
722 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
723 |
fun minimize_wits wits = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
724 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
725 |
fun minimize done [] = done |
49103 | 726 |
| minimize done ((I, wit) :: todo) = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
727 |
if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
728 |
then minimize done todo |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
729 |
else minimize ((I, wit) :: done) todo; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
730 |
in minimize [] wits end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
731 |
|
54236 | 732 |
fun mk_map live Ts Us t = |
733 |
let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in |
|
734 |
Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t |
|
735 |
end; |
|
736 |
||
62326
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62324
diff
changeset
|
737 |
fun mk_pred Ts t = |
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62324
diff
changeset
|
738 |
let val Type (_, Ts0) = domain_type (body_fun_type (fastype_of t)) in |
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62324
diff
changeset
|
739 |
Term.subst_atomic_types (Ts0 ~~ Ts) t |
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62324
diff
changeset
|
740 |
end; |
63851 | 741 |
val mk_set = mk_pred; |
62326
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62324
diff
changeset
|
742 |
|
54236 | 743 |
fun mk_rel live Ts Us t = |
744 |
let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in |
|
745 |
Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t |
|
746 |
end; |
|
747 |
||
64627
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
748 |
fun build_map_or_rel mk const of_bnf dest pre_cst_table ctxt simple_Ts simple_Us build_simple = |
54236 | 749 |
let |
750 |
fun build (TU as (T, U)) = |
|
64627
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
751 |
if exists (curry (op =) T) simple_Ts orelse exists (curry (op =) U) simple_Us then |
57301
7b997028aaac
generate 'rel_coinduct0' theorem for codatatypes
desharna
parents:
56954
diff
changeset
|
752 |
build_simple TU |
64627
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
753 |
else if T = U andalso not (exists_subtype_in simple_Ts T) andalso |
8d7cb22482e3
generalized ML function (towards nonuniform datatypes)
blanchet
parents:
64440
diff
changeset
|
754 |
not (exists_subtype_in simple_Us U) then |
54236 | 755 |
const T |
756 |
else |
|
757 |
(case TU of |
|
758 |
(Type (s, Ts), Type (s', Us)) => |
|
759 |
if s = s' then |
|
760 |
let |
|
62427 | 761 |
fun recurse (live, cst0) = |
762 |
let |
|
763 |
val cst = mk live Ts Us cst0; |
|
764 |
val TUs' = map dest (fst (strip_typeN live (fastype_of cst))); |
|
765 |
in Term.list_comb (cst, map build TUs') end; |
|
766 |
in |
|
767 |
(case AList.lookup (op =) pre_cst_table s of |
|
768 |
NONE => |
|
769 |
(case bnf_of ctxt s of |
|
770 |
SOME bnf => recurse (live_of_bnf bnf, of_bnf bnf) |
|
771 |
| NONE => build_simple TU) |
|
772 |
| SOME entry => recurse entry) |
|
773 |
end |
|
58352
37745650a3f4
register 'prod' and 'sum' as datatypes, to allow N2M through them
blanchet
parents:
58344
diff
changeset
|
774 |
else |
37745650a3f4
register 'prod' and 'sum' as datatypes, to allow N2M through them
blanchet
parents:
58344
diff
changeset
|
775 |
build_simple TU |
54236 | 776 |
| _ => build_simple TU); |
777 |
in build end; |
|
778 |
||
62482 | 779 |
val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT |
69593 | 780 |
[(\<^type_name>\<open>set\<close>, (1, \<^term>\<open>image\<close>))]; |
58104 | 781 |
val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T o append |
69593 | 782 |
[(\<^type_name>\<open>set\<close>, (1, \<^term>\<open>rel_set\<close>)), (\<^type_name>\<open>fun\<close>, (2, \<^term>\<open>rel_fun\<close>))]; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
783 |
|
63851 | 784 |
fun build_set ctxt A = |
785 |
let |
|
786 |
fun build T = |
|
787 |
Abs (Name.uu, T, |
|
788 |
if T = A then |
|
789 |
HOLogic.mk_set A [Bound 0] |
|
790 |
else |
|
791 |
(case T of |
|
792 |
Type (s, Ts) => |
|
793 |
let |
|
794 |
val sets = map (mk_set Ts) (sets_of_bnf (the (bnf_of ctxt s))) |
|
795 |
|> filter (exists_subtype_in [A] o range_type o fastype_of); |
|
796 |
val set_apps = map (fn set => Term.betapply (set, Bound 0)) sets; |
|
797 |
||
798 |
fun recurse set_app = |
|
69593 | 799 |
let val Type (\<^type_name>\<open>set\<close>, [elemT]) = fastype_of set_app in |
63851 | 800 |
if elemT = A then set_app else mk_UNION set_app (build elemT) |
801 |
end; |
|
802 |
in |
|
803 |
if null set_apps then HOLogic.mk_set A [] |
|
63862 | 804 |
else Library.foldl1 mk_union (map recurse set_apps) |
63851 | 805 |
end |
806 |
| _ => HOLogic.mk_set A [])); |
|
807 |
in build end; |
|
808 |
||
54246
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
809 |
fun map_flattened_map_args ctxt s map_args fs = |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
810 |
let |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
811 |
val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs; |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
812 |
val flat_fs' = map_args flat_fs; |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
813 |
in |
55480
59cc4a8bc28a
allow different functions to recurse on the same type, like in the old package
blanchet
parents:
55444
diff
changeset
|
814 |
permute_like_unique (op aconv) flat_fs fs flat_fs' |
54246
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
815 |
end; |
8fdb4dc08ed1
split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents:
54237
diff
changeset
|
816 |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
817 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
818 |
(* Names *) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
819 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
820 |
val mapN = "map"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
821 |
val setN = "set"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
822 |
fun mk_setN i = setN ^ nonzero_string_of_int i; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
823 |
val bdN = "bd"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
824 |
val witN = "wit"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
825 |
fun mk_witN i = witN ^ nonzero_string_of_int i; |
49507 | 826 |
val relN = "rel"; |
62324 | 827 |
val predN = "pred"; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
828 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
829 |
val bd_Card_orderN = "bd_Card_order"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
830 |
val bd_CinfiniteN = "bd_Cinfinite"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
831 |
val bd_CnotzeroN = "bd_Cnotzero"; |
62324 | 832 |
val bd_card_orderN = "bd_card_order"; |
833 |
val bd_cinfiniteN = "bd_cinfinite"; |
|
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
834 |
val collect_set_mapN = "collect_set_map"; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
835 |
val in_bdN = "in_bd"; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
836 |
val in_monoN = "in_mono"; |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
837 |
val in_relN = "in_rel"; |
56635 | 838 |
val inj_mapN = "inj_map"; |
57970 | 839 |
val inj_map_strongN = "inj_map_strong"; |
53287 | 840 |
val map_comp0N = "map_comp0"; |
53288 | 841 |
val map_compN = "map_comp"; |
51761
4c9f08836d87
renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents:
51758
diff
changeset
|
842 |
val map_cong0N = "map_cong0"; |
51762 | 843 |
val map_congN = "map_cong"; |
57981 | 844 |
val map_cong_simpN = "map_cong_simp"; |
62324 | 845 |
val map_cong_predN = "map_cong_pred"; |
846 |
val map_id0N = "map_id0"; |
|
847 |
val map_idN = "map_id"; |
|
848 |
val map_identN = "map_ident"; |
|
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
849 |
val map_transferN = "map_transfer"; |
62324 | 850 |
val pred_mono_strong0N = "pred_mono_strong0"; |
851 |
val pred_mono_strongN = "pred_mono_strong"; |
|
63714 | 852 |
val pred_monoN = "pred_mono"; |
62329 | 853 |
val pred_transferN = "pred_transfer"; |
62324 | 854 |
val pred_TrueN = "pred_True"; |
855 |
val pred_mapN = "pred_map"; |
|
856 |
val pred_relN = "pred_rel"; |
|
857 |
val pred_setN = "pred_set"; |
|
858 |
val pred_congN = "pred_cong"; |
|
859 |
val pred_cong_simpN = "pred_cong_simp"; |
|
860 |
val rel_GrpN = "rel_Grp"; |
|
861 |
val rel_comppN = "rel_compp"; |
|
862 |
val rel_compp_GrpN = "rel_compp_Grp"; |
|
863 |
val rel_congN = "rel_cong"; |
|
864 |
val rel_cong_simpN = "rel_cong_simp"; |
|
865 |
val rel_conversepN = "rel_conversep"; |
|
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49585
diff
changeset
|
866 |
val rel_eqN = "rel_eq"; |
62324 | 867 |
val rel_eq_onpN = "rel_eq_onp"; |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
868 |
val rel_flipN = "rel_flip"; |
59726 | 869 |
val rel_mapN = "rel_map"; |
870 |
val rel_monoN = "rel_mono"; |
|
871 |
val rel_mono_strong0N = "rel_mono_strong0"; |
|
872 |
val rel_mono_strongN = "rel_mono_strong"; |
|
873 |
val rel_reflN = "rel_refl"; |
|
61240 | 874 |
val rel_refl_strongN = "rel_refl_strong"; |
875 |
val rel_reflpN = "rel_reflp"; |
|
876 |
val rel_sympN = "rel_symp"; |
|
62324 | 877 |
val rel_transferN = "rel_transfer"; |
61240 | 878 |
val rel_transpN = "rel_transp"; |
62324 | 879 |
val set_bdN = "set_bd"; |
880 |
val set_map0N = "set_map0"; |
|
881 |
val set_mapN = "set_map"; |
|
882 |
val set_transferN = "set_transfer"; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
883 |
|
55854
ee270328a781
make 'typedef' optional, depending on size of original type
blanchet
parents:
55480
diff
changeset
|
884 |
datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
885 |
|
49538 | 886 |
datatype fact_policy = Dont_Note | Note_Some | Note_All; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
887 |
|
69593 | 888 |
val bnf_internals = Attrib.setup_config_bool \<^binding>\<open>bnf_internals\<close> (K false); |
889 |
val bnf_timing = Attrib.setup_config_bool \<^binding>\<open>bnf_timing\<close> (K false); |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
890 |
|
62093 | 891 |
fun user_policy policy ctxt = if Config.get ctxt bnf_internals then Note_All else policy; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
892 |
|
55854
ee270328a781
make 'typedef' optional, depending on size of original type
blanchet
parents:
55480
diff
changeset
|
893 |
val smart_max_inline_term_size = 25; (*FUDGE*) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
894 |
|
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
895 |
fun note_bnf_thms fact_policy qualify0 bnf_b bnf lthy = |
52720 | 896 |
let |
897 |
val axioms = axioms_of_bnf bnf; |
|
898 |
val facts = facts_of_bnf bnf; |
|
899 |
val wits = wits_of_bnf bnf; |
|
54045
369a4a14583a
keep the qualification of bindings when noting bnf theorems
traytel
parents:
53561
diff
changeset
|
900 |
val qualify = |
59858 | 901 |
let val qs = Binding.path_of bnf_b; |
56766 | 902 |
in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify0 end; |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
903 |
|
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
904 |
fun note_if_note_all (noted0, lthy0) = |
52720 | 905 |
let |
906 |
val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits); |
|
907 |
val notes = |
|
908 |
[(bd_card_orderN, [#bd_card_order axioms]), |
|
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
909 |
(bd_cinfiniteN, [#bd_cinfinite axioms]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
910 |
(bd_Card_orderN, [#bd_Card_order facts]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
911 |
(bd_CinfiniteN, [#bd_Cinfinite facts]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
912 |
(bd_CnotzeroN, [#bd_Cnotzero facts]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
913 |
(collect_set_mapN, [Lazy.force (#collect_set_map facts)]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
914 |
(in_bdN, [Lazy.force (#in_bd facts)]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
915 |
(in_monoN, [Lazy.force (#in_mono facts)]), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
916 |
(map_comp0N, [#map_comp0 axioms]), |
57967 | 917 |
(rel_mono_strong0N, [Lazy.force (#rel_mono_strong0 facts)]), |
62324 | 918 |
(pred_mono_strong0N, [Lazy.force (#pred_mono_strong0 facts)]), |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
919 |
(set_map0N, #set_map0 axioms), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
920 |
(set_bdN, #set_bd axioms)] @ |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
921 |
(witNs ~~ wit_thmss_of_bnf bnf) |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
922 |
|> map (fn (thmN, thms) => |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
923 |
((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
924 |
[(thms, [])])); |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
925 |
in |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
926 |
Local_Theory.notes notes lthy0 |>> append noted0 |
58104 | 927 |
end; |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
928 |
|
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
929 |
fun note_unless_dont_note (noted0, lthy0) = |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
930 |
let |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
931 |
val notes = |
59133 | 932 |
[(in_relN, [Lazy.force (#in_rel facts)], []), |
933 |
(inj_mapN, [Lazy.force (#inj_map facts)], []), |
|
57970 | 934 |
(inj_map_strongN, [Lazy.force (#inj_map_strong facts)], []), |
57969 | 935 |
(map_compN, [Lazy.force (#map_comp facts)], []), |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
936 |
(map_cong0N, [#map_cong0 axioms], []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
937 |
(map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs), |
57981 | 938 |
(map_cong_simpN, [Lazy.force (#map_cong_simp facts)], []), |
62324 | 939 |
(map_cong_predN, [Lazy.force (#map_cong_pred facts)], []), |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
940 |
(map_idN, [Lazy.force (#map_id facts)], []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
941 |
(map_id0N, [#map_id0 axioms], []), |
58102 | 942 |
(map_transferN, [Lazy.force (#map_transfer facts)], []), |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
943 |
(map_identN, [Lazy.force (#map_ident facts)], []), |
62324 | 944 |
(pred_mono_strongN, [Lazy.force (#pred_mono_strong facts)], []), |
63714 | 945 |
(pred_monoN, [Lazy.force (#pred_mono facts)], []), |
62324 | 946 |
(pred_congN, [Lazy.force (#pred_cong facts)], fundefcong_attrs), |
947 |
(pred_cong_simpN, [Lazy.force (#pred_cong_simp facts)], []), |
|
948 |
(pred_mapN, [Lazy.force (#pred_map facts)], []), |
|
949 |
(pred_relN, [Lazy.force (#pred_rel facts)], []), |
|
62329 | 950 |
(pred_transferN, [Lazy.force (#pred_transfer facts)], []), |
62324 | 951 |
(pred_TrueN, [Lazy.force (#pred_True facts)], []), |
952 |
(pred_setN, [#pred_set axioms], []), |
|
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
953 |
(rel_comppN, [Lazy.force (#rel_OO facts)], []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
954 |
(rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
955 |
(rel_conversepN, [Lazy.force (#rel_conversep facts)], []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
956 |
(rel_eqN, [Lazy.force (#rel_eq facts)], []), |
62324 | 957 |
(rel_eq_onpN, [Lazy.force (#rel_eq_onp facts)], []), |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
958 |
(rel_flipN, [Lazy.force (#rel_flip facts)], []), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
959 |
(rel_GrpN, [Lazy.force (#rel_Grp facts)], []), |
57932 | 960 |
(rel_mapN, Lazy.force (#rel_map facts), []), |
58344 | 961 |
(rel_monoN, [Lazy.force (#rel_mono facts)], mono_attrs), |
59133 | 962 |
(rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)], []), |
61242 | 963 |
(rel_congN, [Lazy.force (#rel_cong facts)], fundefcong_attrs), |
964 |
(rel_cong_simpN, [Lazy.force (#rel_cong_simp facts)], []), |
|
59726 | 965 |
(rel_reflN, [Lazy.force (#rel_refl facts)], []), |
61240 | 966 |
(rel_refl_strongN, [Lazy.force (#rel_refl_strong facts)], []), |
967 |
(rel_reflpN, [Lazy.force (#rel_reflp facts)], []), |
|
968 |
(rel_sympN, [Lazy.force (#rel_symp facts)], []), |
|
969 |
(rel_transpN, [Lazy.force (#rel_transp facts)], []), |
|
58104 | 970 |
(rel_transferN, [Lazy.force (#rel_transfer facts)], []), |
58106 | 971 |
(set_mapN, map Lazy.force (#set_map facts), []), |
972 |
(set_transferN, Lazy.force (#set_transfer facts), [])] |
|
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
973 |
|> filter_out (null o #2) |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
974 |
|> map (fn (thmN, thms, attrs) => |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
975 |
((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), attrs), |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
976 |
[(thms, [])])); |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
977 |
in |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
978 |
Local_Theory.notes notes lthy0 |>> append noted0 |
58104 | 979 |
end; |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
980 |
in |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
981 |
([], lthy) |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
982 |
|> fact_policy = Note_All ? note_if_note_all |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
983 |
|> fact_policy <> Dont_Note ? note_unless_dont_note |
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
984 |
|>> (fn [] => bnf | noted => morph_bnf (substitute_noted_thm noted) bnf) |
52720 | 985 |
end; |
986 |
||
66272
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
987 |
fun note_bnf_defs bnf lthy = |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
988 |
let |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
989 |
fun mk_def_binding cst_of = |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
990 |
Thm.def_binding (Binding.qualified_name (dest_Const (cst_of bnf) |> fst)); |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
991 |
val notes = |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
992 |
[(mk_def_binding map_of_bnf, map_def_of_bnf bnf), |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
993 |
(mk_def_binding rel_of_bnf, rel_def_of_bnf bnf), |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
994 |
(mk_def_binding pred_of_bnf, pred_def_of_bnf bnf)] @ |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
995 |
@{map 2} (pair o mk_def_binding o K) (sets_of_bnf bnf) (set_defs_of_bnf bnf) |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
996 |
|> map (fn (b, thm) => ((b, []), [([thm], [])])); |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
997 |
in |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
998 |
lthy |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
999 |
|> Local_Theory.notes notes |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
1000 |
|>> (fn noted => morph_bnf (substitute_noted_thm noted) bnf) |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
1001 |
end; |
c6714a9562ae
store the unfolded definitions of the lifted bnf constants under "_def" name
traytel
parents:
66198
diff
changeset
|
1002 |
|
60918
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1003 |
fun mk_wit_goals zs bs sets (I, wit) = |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1004 |
let |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1005 |
val xs = map (nth bs) I; |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1006 |
fun wit_goal i = |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1007 |
let |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1008 |
val z = nth zs i; |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1009 |
val set_wit = nth sets i $ Term.list_comb (wit, xs); |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1010 |
val concl = HOLogic.mk_Trueprop |
69593 | 1011 |
(if member (op =) I i then HOLogic.mk_eq (z, nth bs i) else \<^term>\<open>False\<close>); |
60918
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1012 |
in |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1013 |
fold_rev Logic.all (z :: xs) (Logic.mk_implies (mk_Trueprop_mem (z, set_wit), concl)) |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1014 |
end; |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1015 |
in |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1016 |
map wit_goal (0 upto length sets - 1) |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1017 |
end; |
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1018 |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1019 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1020 |
(* Define new BNFs *) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1021 |
|
62324 | 1022 |
fun define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b pred_b set_bs |
1023 |
(((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt), pred_rhs_opt) |
|
1024 |
no_defs_lthy = |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1025 |
let |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1026 |
val live = length set_rhss; |
53265 | 1027 |
|
61241
69a97fc33f7a
conceal only the definitional theorems of map, set, rel (and not the actual constants)
traytel
parents:
61240
diff
changeset
|
1028 |
val def_qualify = Binding.qualify false (Binding.name_of bnf_b); |
53265 | 1029 |
|
54490
930409d43211
use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents:
54426
diff
changeset
|
1030 |
fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b; |
49434
433dc7e028c8
separated registration of BNFs from bnf_def (BNFs are now stored only for bnf_def and (co)data commands)
traytel
parents:
49430
diff
changeset
|
1031 |
|
49463 | 1032 |
fun maybe_define user_specified (b, rhs) lthy = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1033 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1034 |
val inline = |
49538 | 1035 |
(user_specified orelse fact_policy = Dont_Note) andalso |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1036 |
(case const_policy of |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1037 |
Dont_Inline => false |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1038 |
| Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs |
55854
ee270328a781
make 'typedef' optional, depending on size of original type
blanchet
parents:
55480
diff
changeset
|
1039 |
| Smart_Inline => Term.size_of_term rhs <= smart_max_inline_term_size |
60154 | 1040 |
| Do_Inline => true); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1041 |
in |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1042 |
if inline then |
49460
4dd451a075ce
fixed infinite loop with trivial rel_O_Gr + tuning
blanchet
parents:
49459
diff
changeset
|
1043 |
((rhs, Drule.reflexive_thm), lthy) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1044 |
else |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1045 |
let val b = b () in |
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
1046 |
apfst (apsnd snd) |
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
1047 |
((if internal then Local_Theory.define_internal else Local_Theory.define) |
61241
69a97fc33f7a
conceal only the definitional theorems of map, set, rel (and not the actual constants)
traytel
parents:
61240
diff
changeset
|
1048 |
((b, NoSyn), ((Binding.concealed (Thm.def_binding b), []), rhs)) lthy) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1049 |
end |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1050 |
end; |
49459 | 1051 |
|
51758 | 1052 |
val map_bind_def = |
54490
930409d43211
use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents:
54426
diff
changeset
|
1053 |
(fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b), |
53265 | 1054 |
map_rhs); |
49459 | 1055 |
val set_binds_defs = |
1056 |
let |
|
51757 | 1057 |
fun set_name i get_b = |
1058 |
(case try (nth set_bs) (i - 1) of |
|
1059 |
SOME b => if Binding.is_empty b then get_b else K b |
|
53265 | 1060 |
| NONE => get_b) #> def_qualify; |
54490
930409d43211
use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents:
54426
diff
changeset
|
1061 |
val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)] |
930409d43211
use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents:
54426
diff
changeset
|
1062 |
else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live); |
51757 | 1063 |
in bs ~~ set_rhss end; |
54490
930409d43211
use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents:
54426
diff
changeset
|
1064 |
val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs); |
49459 | 1065 |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1066 |
val ((((bnf_map_term, raw_map_def), |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1067 |
(bnf_set_terms, raw_set_defs)), |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1068 |
(bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1069 |
no_defs_lthy |
72154 | 1070 |
|> Local_Theory.open_target |
49463 | 1071 |
|> maybe_define true map_bind_def |
1072 |
||>> apfst split_list o fold_map (maybe_define true) set_binds_defs |
|
1073 |
||>> maybe_define true bd_bind_def |
|
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60948
diff
changeset
|
1074 |
||> `Local_Theory.close_target; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1075 |
|
49459 | 1076 |
val phi = Proof_Context.export_morphism lthy_old lthy; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1077 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1078 |
val bnf_map_def = Morphism.thm phi raw_map_def; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1079 |
val bnf_set_defs = map (Morphism.thm phi) raw_set_defs; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1080 |
val bnf_bd_def = Morphism.thm phi raw_bd_def; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1081 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1082 |
val bnf_map = Morphism.term phi bnf_map_term; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1083 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1084 |
(*TODO: handle errors*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1085 |
(*simple shape analysis of a map function*) |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1086 |
val ((alphas, betas), (Calpha, _)) = |
49395
323414474c1f
use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents:
49386
diff
changeset
|
1087 |
fastype_of bnf_map |
323414474c1f
use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents:
49386
diff
changeset
|
1088 |
|> strip_typeN live |
323414474c1f
use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents:
49386
diff
changeset
|
1089 |
|>> map_split dest_funT |
323414474c1f
use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents:
49386
diff
changeset
|
1090 |
||> dest_funT |
323414474c1f
use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents:
49386
diff
changeset
|
1091 |
handle TYPE _ => error "Bad map function"; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1092 |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1093 |
val Calpha_params = map TVar (Term.add_tvarsT Calpha []); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1094 |
|
54426
edb87aac9cca
prohibit locally fixed type variables in bnf definitions
traytel
parents:
54425
diff
changeset
|
1095 |
val bnf_T = Morphism.typ phi T_rhs; |
edb87aac9cca
prohibit locally fixed type variables in bnf definitions
traytel
parents:
54425
diff
changeset
|
1096 |
val bad_args = Term.add_tfreesT bnf_T []; |
59281 | 1097 |
val _ = null bad_args orelse error ("Locally fixed type arguments " ^ |
54426
edb87aac9cca
prohibit locally fixed type variables in bnf definitions
traytel
parents:
54425
diff
changeset
|
1098 |
commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args)); |
edb87aac9cca
prohibit locally fixed type variables in bnf definitions
traytel
parents:
54425
diff
changeset
|
1099 |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1100 |
val bnf_sets = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1101 |
map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1102 |
val bnf_bd = |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1103 |
Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params) |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1104 |
(Morphism.term phi bnf_bd_term); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1105 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1106 |
(*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1107 |
val deads = (case Ds_opt of |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1108 |
NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map [])) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1109 |
| SOME Ds => map (Morphism.typ phi) Ds); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1110 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1111 |
(*TODO: further checks of type of bnf_map*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1112 |
(*TODO: check types of bnf_sets*) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1113 |
(*TODO: check type of bnf_bd*) |
49507 | 1114 |
(*TODO: check type of bnf_rel*) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1115 |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1116 |
fun mk_bnf_map Ds As' Bs' = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1117 |
Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1118 |
fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As')); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1119 |
fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As')); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1120 |
|
60154 | 1121 |
val (((As, Bs), unsorted_Ds), names_lthy) = lthy |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1122 |
|> mk_TFrees live |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1123 |
||>> mk_TFrees live |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1124 |
||>> mk_TFrees (length deads); |
60154 | 1125 |
|
1126 |
val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds; |
|
1127 |
||
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1128 |
val RTs = map2 (curry HOLogic.mk_prodT) As Bs; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1129 |
val pred2RTs = map2 mk_pred2T As Bs; |
60154 | 1130 |
val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1131 |
val CA = mk_bnf_T Ds As Calpha; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1132 |
val CR = mk_bnf_T Ds RTs Calpha; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1133 |
val setRs = |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1134 |
@{map 3} (fn R => fn T => fn U => |
61424
c3658c18b7bc
prod_case as canonical name for product type eliminator
haftmann
parents:
61334
diff
changeset
|
1135 |
HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_case_prod R) Rs As Bs; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1136 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1137 |
(*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1138 |
Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*) |
62324 | 1139 |
val rel_spec = |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1140 |
let |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1141 |
val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1142 |
val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1143 |
val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1144 |
in |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1145 |
mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2) |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1146 |
|> fold_rev Term.absfree Rs' |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1147 |
end; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1148 |
|
62324 | 1149 |
val rel_rhs = the_default rel_spec rel_rhs_opt; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1150 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1151 |
val rel_bind_def = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1152 |
(fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b), |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1153 |
rel_rhs); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1154 |
|
62324 | 1155 |
val pred_spec = |
69593 | 1156 |
if live = 0 then Term.absdummy (mk_bnf_T Ds As Calpha) \<^term>\<open>True\<close> else |
62324 | 1157 |
let |
1158 |
val sets = map (mk_bnf_t Ds As) bnf_sets; |
|
1159 |
val argTs = map mk_pred1T As; |
|
1160 |
val T = mk_bnf_T Ds As Calpha; |
|
1161 |
val ((Ps, Ps'), x) = lthy |
|
1162 |
|> mk_Frees' "P" argTs |
|
1163 |
||>> yield_singleton (mk_Frees "x") T |
|
1164 |
|> fst; |
|
1165 |
val conjs = map2 (fn set => fn P => mk_Ball (set $ x) P) sets Ps; |
|
1166 |
in |
|
1167 |
fold_rev Term.absfree Ps' |
|
1168 |
(Term.absfree (dest_Free x) (Library.foldr1 HOLogic.mk_conj conjs)) |
|
1169 |
end; |
|
1170 |
||
1171 |
val pred_rhs = the_default pred_spec pred_rhs_opt; |
|
1172 |
||
1173 |
val pred_bind_def = |
|
1174 |
(fn () => def_qualify (if Binding.is_empty pred_b then mk_prefix_binding predN else pred_b), |
|
1175 |
pred_rhs); |
|
1176 |
||
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1177 |
val wit_rhss = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1178 |
if null wit_rhss then |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1179 |
[fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As, |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1180 |
map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $ |
69593 | 1181 |
Const (\<^const_name>\<open>undefined\<close>, CA))] |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1182 |
else wit_rhss; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1183 |
val nwits = length wit_rhss; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1184 |
val wit_binds_defs = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1185 |
let |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1186 |
val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)] |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1187 |
else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1188 |
in bs ~~ wit_rhss end; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1189 |
|
62324 | 1190 |
val ((((bnf_rel_term, raw_rel_def), (bnf_pred_term, raw_pred_def)), |
1191 |
(bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) = |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1192 |
lthy |
72154 | 1193 |
|> Local_Theory.open_target |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1194 |
|> maybe_define (is_some rel_rhs_opt) rel_bind_def |
62324 | 1195 |
||>> maybe_define (is_some pred_rhs_opt) pred_bind_def |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1196 |
||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs |
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60948
diff
changeset
|
1197 |
||> `Local_Theory.close_target; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1198 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1199 |
val phi = Proof_Context.export_morphism lthy_old lthy; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1200 |
val bnf_rel_def = Morphism.thm phi raw_rel_def; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1201 |
val bnf_rel = Morphism.term phi bnf_rel_term; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1202 |
fun mk_bnf_rel Ds As' Bs' = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1203 |
normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha) |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1204 |
bnf_rel; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1205 |
|
62324 | 1206 |
val bnf_pred_def = Morphism.thm phi raw_pred_def; |
1207 |
val bnf_pred = Morphism.term phi bnf_pred_term; |
|
1208 |
fun mk_bnf_pred Ds As' = |
|
1209 |
normalize_pred lthy (map mk_pred1T As') (mk_bnf_T Ds As' Calpha) bnf_pred; |
|
1210 |
||
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1211 |
val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1212 |
val bnf_wits = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1213 |
map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1214 |
|
62324 | 1215 |
fun mk_rel_spec Ds' As' Bs' = |
1216 |
Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) rel_spec; |
|
1217 |
||
1218 |
fun mk_pred_spec Ds' As' = |
|
1219 |
Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As')) pred_spec; |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1220 |
in |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1221 |
(((alphas, betas, deads, Calpha), |
62324 | 1222 |
(bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel, bnf_pred), |
1223 |
(bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def, bnf_pred_def), |
|
1224 |
(mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_bnf_pred, mk_rel_spec, mk_pred_spec)), lthy) |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1225 |
end; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1226 |
|
56016
8875cdcfc85b
unfold intermediate definitions after sealing the bnf
traytel
parents:
55945
diff
changeset
|
1227 |
fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term Ds_opt map_b rel_b |
62324 | 1228 |
pred_b set_bs (((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt), |
1229 |
raw_pred_opt) no_defs_lthy = |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1230 |
let |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1231 |
val fact_policy = mk_fact_policy no_defs_lthy; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1232 |
val bnf_b = qualify raw_bnf_b; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1233 |
val live = length raw_sets; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1234 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1235 |
val T_rhs = prep_typ no_defs_lthy raw_bnf_T; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1236 |
val map_rhs = prep_term no_defs_lthy raw_map; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1237 |
val set_rhss = map (prep_term no_defs_lthy) raw_sets; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1238 |
val bd_rhs = prep_term no_defs_lthy raw_bd; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1239 |
val wit_rhss = map (prep_term no_defs_lthy) raw_wits; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1240 |
val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt; |
62324 | 1241 |
val pred_rhs_opt = Option.map (prep_term no_defs_lthy) raw_pred_opt; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1242 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1243 |
fun err T = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1244 |
error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^ |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1245 |
" as unnamed BNF"); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1246 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1247 |
val (bnf_b, key) = |
63009 | 1248 |
if Binding.is_empty bnf_b then |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1249 |
(case T_rhs of |
66198 | 1250 |
Type (C, Ts) => |
1251 |
if forall (can dest_TFree) Ts andalso not (has_duplicates (op =) Ts) then |
|
1252 |
(Binding.qualified_name C, C) |
|
1253 |
else |
|
1254 |
err T_rhs |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1255 |
| T => err T) |
66198 | 1256 |
else |
1257 |
(bnf_b, Local_Theory.full_name no_defs_lthy bnf_b); |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1258 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1259 |
val (((alphas, betas, deads, Calpha), |
62324 | 1260 |
(bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel, bnf_pred), |
1261 |
(bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def, bnf_pred_def), |
|
1262 |
(mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, _, mk_rel_spec, mk_pred_spec)), lthy) = |
|
1263 |
define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b pred_b set_bs |
|
1264 |
(((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt), pred_rhs_opt) |
|
1265 |
no_defs_lthy; |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1266 |
|
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1267 |
val dead = length deads; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1268 |
|
60154 | 1269 |
val (((((((As', Bs'), Cs), unsorted_Ds), Es), B1Ts), B2Ts), (Ts, T)) = lthy |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1270 |
|> mk_TFrees live |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1271 |
||>> mk_TFrees live |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1272 |
||>> mk_TFrees live |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1273 |
||>> mk_TFrees dead |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1274 |
||>> mk_TFrees live |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1275 |
||>> mk_TFrees live |
58104 | 1276 |
||>> mk_TFrees live |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1277 |
||> fst o mk_TFrees 1 |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1278 |
||> the_single |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1279 |
||> `(replicate live); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1280 |
|
60154 | 1281 |
val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds; |
1282 |
||
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1283 |
val mk_bnf_map = mk_bnf_map_Ds Ds; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1284 |
val mk_bnf_t = mk_bnf_t_Ds Ds; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1285 |
val mk_bnf_T = mk_bnf_T_Ds Ds; |
49453 | 1286 |
|
62324 | 1287 |
val pred1PTs = map mk_pred1T As'; |
1288 |
val pred1QTs = map mk_pred1T Bs'; |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1289 |
val pred2RTs = map2 mk_pred2T As' Bs'; |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1290 |
val pred2RTsAsCs = map2 mk_pred2T As' Cs; |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1291 |
val pred2RTsBsCs = map2 mk_pred2T Bs' Cs; |
58104 | 1292 |
val pred2RTsBsEs = map2 mk_pred2T Bs' Es; |
57932 | 1293 |
val pred2RTsCsBs = map2 mk_pred2T Cs Bs'; |
58104 | 1294 |
val pred2RTsCsEs = map2 mk_pred2T Cs Es; |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1295 |
val pred2RT's = map2 mk_pred2T Bs' As'; |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1296 |
val self_pred2RTs = map2 mk_pred2T As' As'; |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1297 |
val transfer_domRTs = map2 mk_pred2T As' B1Ts; |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1298 |
val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1299 |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1300 |
val CA' = mk_bnf_T As' Calpha; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1301 |
val CB' = mk_bnf_T Bs' Calpha; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1302 |
val CC' = mk_bnf_T Cs Calpha; |
58104 | 1303 |
val CE' = mk_bnf_T Es Calpha; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1304 |
val CB1 = mk_bnf_T B1Ts Calpha; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1305 |
val CB2 = mk_bnf_T B2Ts Calpha; |
49453 | 1306 |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1307 |
val bnf_map_AsAs = mk_bnf_map As' As'; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1308 |
val bnf_map_AsBs = mk_bnf_map As' Bs'; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1309 |
val bnf_map_AsCs = mk_bnf_map As' Cs; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1310 |
val bnf_map_BsCs = mk_bnf_map Bs' Cs; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1311 |
val bnf_sets_As = map (mk_bnf_t As') bnf_sets; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1312 |
val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1313 |
val bnf_bd_As = mk_bnf_t As' bnf_bd; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1314 |
fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel; |
62324 | 1315 |
fun mk_bnf_pred PTs CA = normalize_pred lthy PTs CA bnf_pred; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1316 |
|
62324 | 1317 |
val ((((((((((((((((((((((((((fs, fs'), gs), hs), is), x), x'), y), y'), zs), zs'), ys), As), |
1318 |
As_copy), bs), (Ps, Ps')), Ps_copy), Qs), Rs), Rs_copy), Ss), S_AsCs), S_CsBs), S_BsEs), |
|
1319 |
transfer_domRs), transfer_ranRs), _) = lthy |
|
52923 | 1320 |
|> mk_Frees "f" (map2 (curry op -->) As' Bs') |
57970 | 1321 |
||>> mk_Frees "f" (map2 (curry op -->) As' Bs') |
52923 | 1322 |
||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs) |
1323 |
||>> mk_Frees "h" (map2 (curry op -->) As' Ts) |
|
57932 | 1324 |
||>> mk_Frees "i" (map2 (curry op -->) As' Cs) |
51894 | 1325 |
||>> yield_singleton (mk_Frees "x") CA' |
57970 | 1326 |
||>> yield_singleton (mk_Frees "x") CA' |
51894 | 1327 |
||>> yield_singleton (mk_Frees "y") CB' |
61242 | 1328 |
||>> yield_singleton (mk_Frees "y") CB' |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1329 |
||>> mk_Frees "z" As' |
57970 | 1330 |
||>> mk_Frees "z" As' |
51916 | 1331 |
||>> mk_Frees "y" Bs' |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1332 |
||>> mk_Frees "A" (map HOLogic.mk_setT As') |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1333 |
||>> mk_Frees "A" (map HOLogic.mk_setT As') |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1334 |
||>> mk_Frees "b" As' |
62324 | 1335 |
||>> mk_Frees' "P" pred1PTs |
1336 |
||>> mk_Frees "P" pred1PTs |
|
1337 |
||>> mk_Frees "Q" pred1QTs |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1338 |
||>> mk_Frees "R" pred2RTs |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1339 |
||>> mk_Frees "R" pred2RTs |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1340 |
||>> mk_Frees "S" pred2RTsBsCs |
57932 | 1341 |
||>> mk_Frees "S" pred2RTsAsCs |
1342 |
||>> mk_Frees "S" pred2RTsCsBs |
|
58104 | 1343 |
||>> mk_Frees "S" pred2RTsBsEs |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1344 |
||>> mk_Frees "R" transfer_domRTs |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1345 |
||>> mk_Frees "S" transfer_ranRTs; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1346 |
|
56651 | 1347 |
val fs_copy = map2 (retype_const_or_free o fastype_of) fs gs; |
61242 | 1348 |
val x_copy = retype_const_or_free CA' y'; |
1349 |
val y_copy = retype_const_or_free CB' x'; |
|
51762 | 1350 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1351 |
val rel = mk_bnf_rel pred2RTs CA' CB'; |
62324 | 1352 |
val pred = mk_bnf_pred pred1PTs CA'; |
1353 |
val pred' = mk_bnf_pred pred1QTs CB'; |
|
58104 | 1354 |
val relCsEs = mk_bnf_rel pred2RTsCsEs CC' CE'; |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1355 |
val relAsAs = mk_bnf_rel self_pred2RTs CA' CA'; |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1356 |
val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits; |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1357 |
|
53270 | 1358 |
val map_id0_goal = |
51762 | 1359 |
let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in |
1360 |
mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA') |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1361 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1362 |
|
53287 | 1363 |
val map_comp0_goal = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1364 |
let |
49018 | 1365 |
val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1366 |
val comp_bnf_map_app = HOLogic.mk_comp |
51762 | 1367 |
(Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1368 |
in |
49123
263b0e330d8b
more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents:
49111
diff
changeset
|
1369 |
fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app)) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1370 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1371 |
|
57981 | 1372 |
fun mk_map_cong_prem mk_implies x z set f f_copy = |
58108 | 1373 |
Logic.all z (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (f $ z, f_copy $ z))); |
51762 | 1374 |
|
51761
4c9f08836d87
renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents:
51758
diff
changeset
|
1375 |
val map_cong0_goal = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1376 |
let |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1377 |
val prems = @{map 4} (mk_map_cong_prem Logic.mk_implies x) zs bnf_sets_As fs fs_copy; |
51762 | 1378 |
val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1379 |
Term.list_comb (bnf_map_AsBs, fs_copy) $ x); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1380 |
in |
51762 | 1381 |
fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq)) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1382 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1383 |
|
53289 | 1384 |
val set_map0s_goal = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1385 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1386 |
fun mk_goal setA setB f = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1387 |
let |
58108 | 1388 |
val set_comp_map = HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1389 |
val image_comp_set = HOLogic.mk_comp (mk_image f, setA); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1390 |
in |
49123
263b0e330d8b
more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents:
49111
diff
changeset
|
1391 |
fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set)) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1392 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1393 |
in |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1394 |
@{map 3} mk_goal bnf_sets_As bnf_sets_Bs fs |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1395 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1396 |
|
49458 | 1397 |
val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1398 |
|
49458 | 1399 |
val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1400 |
|
49458 | 1401 |
val set_bds_goal = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1402 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1403 |
fun mk_goal set = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1404 |
Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As)); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1405 |
in |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1406 |
map mk_goal bnf_sets_As |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1407 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1408 |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1409 |
val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC'; |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1410 |
val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC'; |
57932 | 1411 |
val relCsBs = mk_bnf_rel pred2RTsCsBs CC' CB'; |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1412 |
val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1413 |
val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss)); |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1414 |
val le_rel_OO_goal = |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1415 |
fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1416 |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1417 |
val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs), |
62324 | 1418 |
Term.list_comb (mk_rel_spec Ds As' Bs', Rs))); |
1419 |
||
1420 |
val pred_set_goal = fold_rev Logic.all Ps (mk_Trueprop_eq (Term.list_comb (pred, Ps), |
|
1421 |
Term.list_comb (mk_pred_spec Ds As', Ps))); |
|
49453 | 1422 |
|
53289 | 1423 |
val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal |
62324 | 1424 |
card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal pred_set_goal; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1425 |
|
60918
4ceef1592e8c
new command for lifting BNF structure over typedefs
traytel
parents:
60801
diff
changeset
|
1426 |
val mk_wit_goals = mk_wit_goals bs zs bnf_sets_As; |
55197 | 1427 |
fun triv_wit_tac ctxt = mk_trivial_wit_tac ctxt bnf_wit_defs; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1428 |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1429 |
val wit_goalss = |
54921
862c36b6e57c
avoid schematic variable in goal, which sometimes gets instantiated by tactic
blanchet
parents:
54841
diff
changeset
|
1430 |
(if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As); |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1431 |
|
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1432 |
fun after_qed mk_wit_thms thms lthy = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1433 |
let |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1434 |
val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1435 |
|
49109
0e5b859e1c91
no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents:
49103
diff
changeset
|
1436 |
val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]}; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1437 |
val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order]; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1438 |
val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero}; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1439 |
|
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
1440 |
fun mk_collect_set_map () = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1441 |
let |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1442 |
val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T; |
58108 | 1443 |
val collect_map = HOLogic.mk_comp (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT, |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1444 |
Term.list_comb (mk_bnf_map As' Ts, hs)); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1445 |
val image_collect = mk_collect |
58108 | 1446 |
(map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As) defT; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1447 |
(*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*) |
49123
263b0e330d8b
more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents:
49111
diff
changeset
|
1448 |
val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1449 |
in |
62324 | 1450 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
60728 | 1451 |
mk_collect_set_map_tac ctxt (#set_map0 axioms)) |
70494 | 1452 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1453 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1454 |
|
51766
f19a4d0ab1bf
renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents:
51765
diff
changeset
|
1455 |
val collect_set_map = Lazy.lazy mk_collect_set_map; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1456 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1457 |
fun mk_in_mono () = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1458 |
let |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1459 |
val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy; |
49458 | 1460 |
val in_mono_goal = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1461 |
fold_rev Logic.all (As @ As_copy) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1462 |
(Logic.list_implies (prems_mono, HOLogic.mk_Trueprop |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1463 |
(mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA')))); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1464 |
in |
60728 | 1465 |
Goal.prove_sorry lthy [] [] in_mono_goal (fn {context = ctxt, prems = _} => |
1466 |
mk_in_mono_tac ctxt live) |
|
70494 | 1467 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1468 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1469 |
|
49538 | 1470 |
val in_mono = Lazy.lazy mk_in_mono; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1471 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1472 |
fun mk_in_cong () = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1473 |
let |
51762 | 1474 |
val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy; |
49458 | 1475 |
val in_cong_goal = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1476 |
fold_rev Logic.all (As @ As_copy) |
51762 | 1477 |
(Logic.list_implies (prems_cong, |
1478 |
mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA'))); |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1479 |
in |
51798 | 1480 |
Goal.prove_sorry lthy [] [] in_cong_goal |
60728 | 1481 |
(fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1) |
70494 | 1482 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1483 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1484 |
|
49538 | 1485 |
val in_cong = Lazy.lazy mk_in_cong; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1486 |
|
53285 | 1487 |
val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms)); |
57399 | 1488 |
val map_ident0 = Lazy.lazy (fn () => mk_map_ident lthy (#map_id0 axioms)); |
56903 | 1489 |
val map_ident = Lazy.lazy (fn () => mk_map_ident lthy (Lazy.force map_id)); |
53288 | 1490 |
val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms)); |
51762 | 1491 |
|
57981 | 1492 |
fun mk_map_cong mk_implies () = |
51762 | 1493 |
let |
1494 |
val prem0 = mk_Trueprop_eq (x, x_copy); |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1495 |
val prems = @{map 4} (mk_map_cong_prem mk_implies x_copy) zs bnf_sets_As fs fs_copy; |
51762 | 1496 |
val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x, |
1497 |
Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy); |
|
1498 |
val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy) |
|
1499 |
(Logic.list_implies (prem0 :: prems, eq)); |
|
1500 |
in |
|
61271 | 1501 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
1502 |
unfold_thms_tac ctxt @{thms simp_implies_def} THEN |
|
1503 |
mk_map_cong_tac ctxt (#map_cong0 axioms)) |
|
70494 | 1504 |
|> Thm.close_derivation \<^here> |
51762 | 1505 |
end; |
1506 |
||
57981 | 1507 |
val map_cong = Lazy.lazy (mk_map_cong Logic.mk_implies); |
69593 | 1508 |
val map_cong_simp = Lazy.lazy (mk_map_cong (fn (a, b) => \<^term>\<open>simp_implies\<close> $ a $ b)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1509 |
|
56635 | 1510 |
fun mk_inj_map () = |
1511 |
let |
|
1512 |
val prems = map (HOLogic.mk_Trueprop o mk_inj) fs; |
|
1513 |
val concl = HOLogic.mk_Trueprop (mk_inj (Term.list_comb (bnf_map_AsBs, fs))); |
|
1514 |
val goal = fold_rev Logic.all fs (Logic.list_implies (prems, concl)); |
|
1515 |
in |
|
60728 | 1516 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
1517 |
mk_inj_map_tac ctxt live (Lazy.force map_id) (Lazy.force map_comp) (#map_cong0 axioms) |
|
1518 |
(Lazy.force map_cong)) |
|
70494 | 1519 |
|> Thm.close_derivation \<^here> |
56635 | 1520 |
end; |
1521 |
||
1522 |
val inj_map = Lazy.lazy mk_inj_map; |
|
1523 |
||
53290 | 1524 |
val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1525 |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1526 |
val wit_thms = |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1527 |
if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms; |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
1528 |
|
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1529 |
fun mk_in_bd () = |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1530 |
let |
52813 | 1531 |
val bdT = fst (dest_relT (fastype_of bnf_bd_As)); |
1532 |
val bdTs = replicate live bdT; |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1533 |
val bd_bnfT = mk_bnf_T bdTs Calpha; |
52813 | 1534 |
val surj_imp_ordLeq_inst = (if live = 0 then TrueI else |
1535 |
let |
|
1536 |
val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As'; |
|
1537 |
val funTs = map (fn T => bdT --> T) ranTs; |
|
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1538 |
val ran_bnfT = mk_bnf_T ranTs Calpha; |
52813 | 1539 |
val (revTs, Ts) = `rev (bd_bnfT :: funTs); |
61760 | 1540 |
val cTs = map (SOME o Thm.ctyp_of lthy) [ran_bnfT, |
1541 |
Library.foldr1 HOLogic.mk_prodT Ts]; |
|
1542 |
val tinst = fold (fn T => fn t => |
|
1543 |
HOLogic.mk_case_prod (Term.absdummy T t)) (tl revTs) |
|
1544 |
(Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs, |
|
1545 |
map Bound (live - 1 downto 0)) $ Bound live)); |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59580
diff
changeset
|
1546 |
val cts = [NONE, SOME (Thm.cterm_of lthy tinst)]; |
52813 | 1547 |
in |
60801 | 1548 |
Thm.instantiate' cTs cts @{thm surj_imp_ordLeq} |
52813 | 1549 |
end); |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1550 |
val bd = mk_cexp |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1551 |
(if live = 0 then ctwo |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1552 |
else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo) |
52813 | 1553 |
(mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT))); |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1554 |
val in_bd_goal = |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1555 |
fold_rev Logic.all As |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1556 |
(HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd)); |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1557 |
in |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1558 |
Goal.prove_sorry lthy [] [] in_bd_goal |
55197 | 1559 |
(fn {context = ctxt, prems = _} => mk_in_bd_tac ctxt live surj_imp_ordLeq_inst |
53288 | 1560 |
(Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms) |
53290 | 1561 |
(map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms) |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1562 |
bd_Card_order bd_Cinfinite bd_Cnotzero) |
70494 | 1563 |
|> Thm.close_derivation \<^here> |
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1564 |
end; |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1565 |
|
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1566 |
val in_bd = Lazy.lazy mk_in_bd; |
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
1567 |
|
53561 | 1568 |
val rel_OO_Grp = #rel_OO_Grp axioms; |
1569 |
val rel_OO_Grps = no_refl [rel_OO_Grp]; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1570 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1571 |
fun mk_rel_Grp () = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1572 |
let |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1573 |
val lhs = Term.list_comb (rel, map2 mk_Grp As fs); |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1574 |
val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs)); |
49123
263b0e330d8b
more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents:
49111
diff
changeset
|
1575 |
val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1576 |
in |
51551 | 1577 |
Goal.prove_sorry lthy [] [] goal |
55197 | 1578 |
(fn {context = ctxt, prems = _} => mk_rel_Grp_tac ctxt rel_OO_Grps (#map_id0 axioms) |
1579 |
(#map_cong0 axioms) (Lazy.force map_id) (Lazy.force map_comp) |
|
1580 |
(map Lazy.force set_map)) |
|
70494 | 1581 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1582 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1583 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1584 |
val rel_Grp = Lazy.lazy mk_rel_Grp; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1585 |
|
61242 | 1586 |
fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy; |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1587 |
fun mk_rel_concl f = HOLogic.mk_Trueprop |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1588 |
(f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy))); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1589 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1590 |
fun mk_rel_mono () = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1591 |
let |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1592 |
val mono_prems = mk_rel_prems mk_leq; |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1593 |
val mono_concl = mk_rel_concl (uncurry mk_leq); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1594 |
in |
51551 | 1595 |
Goal.prove_sorry lthy [] [] |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1596 |
(fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl))) |
60728 | 1597 |
(fn {context = ctxt, prems = _} => |
1598 |
mk_rel_mono_tac ctxt rel_OO_Grps (Lazy.force in_mono)) |
|
70494 | 1599 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1600 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1601 |
|
61242 | 1602 |
fun mk_rel_cong0 () = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1603 |
let |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1604 |
val cong_prems = mk_rel_prems (curry HOLogic.mk_eq); |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1605 |
val cong_concl = mk_rel_concl HOLogic.mk_eq; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1606 |
in |
51551 | 1607 |
Goal.prove_sorry lthy [] [] |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1608 |
(fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl))) |
60728 | 1609 |
(fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1) |
70494 | 1610 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1611 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1612 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1613 |
val rel_mono = Lazy.lazy mk_rel_mono; |
61242 | 1614 |
val rel_cong0 = Lazy.lazy mk_rel_cong0; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1615 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1616 |
fun mk_rel_eq () = |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1617 |
Goal.prove_sorry lthy [] [] |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1618 |
(mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'), |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1619 |
HOLogic.eq_const CA')) |
60728 | 1620 |
(fn {context = ctxt, prems = _} => |
61242 | 1621 |
mk_rel_eq_tac ctxt live (Lazy.force rel_Grp) (Lazy.force rel_cong0) (#map_id0 axioms)) |
70494 | 1622 |
|> Thm.close_derivation \<^here>; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1623 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1624 |
val rel_eq = Lazy.lazy mk_rel_eq; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1625 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1626 |
fun mk_rel_conversep () = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1627 |
let |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1628 |
val relBsAs = mk_bnf_rel pred2RT's CB' CA'; |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1629 |
val lhs = Term.list_comb (relBsAs, map mk_conversep Rs); |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1630 |
val rhs = mk_conversep (Term.list_comb (rel, Rs)); |
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1631 |
val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs)); |
51551 | 1632 |
val le_thm = Goal.prove_sorry lthy [] [] le_goal |
55197 | 1633 |
(fn {context = ctxt, prems = _} => mk_rel_conversep_le_tac ctxt rel_OO_Grps |
1634 |
(Lazy.force rel_eq) (#map_cong0 axioms) (Lazy.force map_comp) |
|
1635 |
(map Lazy.force set_map)) |
|
70494 | 1636 |
|> Thm.close_derivation \<^here> |
49123
263b0e330d8b
more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents:
49111
diff
changeset
|
1637 |
val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs)); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1638 |
in |
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1639 |
Goal.prove_sorry lthy [] [] goal |
60728 | 1640 |
(fn {context = ctxt, prems = _} => |
1641 |
mk_rel_conversep_tac ctxt le_thm (Lazy.force rel_mono)) |
|
70494 | 1642 |
|> Thm.close_derivation \<^here> |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1643 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1644 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1645 |
val rel_conversep = Lazy.lazy mk_rel_conversep; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1646 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1647 |
fun mk_rel_OO () = |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1648 |
Goal.prove_sorry lthy [] [] |
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1649 |
(fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs))) |
55197 | 1650 |
(fn {context = ctxt, prems = _} => mk_rel_OO_le_tac ctxt rel_OO_Grps (Lazy.force rel_eq) |
1651 |
(#map_cong0 axioms) (Lazy.force map_comp) (map Lazy.force set_map)) |
|
70494 | 1652 |
|> Thm.close_derivation \<^here> |
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
1653 |
|> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1654 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1655 |
val rel_OO = Lazy.lazy mk_rel_OO; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1656 |
|
53561 | 1657 |
fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD}; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
1658 |
|
51893
596baae88a88
got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents:
51837
diff
changeset
|
1659 |
val in_rel = Lazy.lazy mk_in_rel; |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
1660 |
|
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
1661 |
fun mk_rel_flip () = |
61760 | 1662 |
unfold_thms lthy @{thms conversep_iff} |
1663 |
(Lazy.force rel_conversep RS @{thm predicate2_eqD}); |
|
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
1664 |
|
49538 | 1665 |
val rel_flip = Lazy.lazy mk_rel_flip; |
49537
fe1deee434b6
generate "rel_as_srel" and "rel_flip" properties
blanchet
parents:
49536
diff
changeset
|
1666 |
|
57967 | 1667 |
fun mk_rel_mono_strong0 () = |
51916 | 1668 |
let |
1669 |
fun mk_prem setA setB R S a b = |
|
1670 |
HOLogic.mk_Trueprop |
|
1671 |
(mk_Ball (setA $ x) (Term.absfree (dest_Free a) |
|
1672 |
(mk_Ball (setB $ y) (Term.absfree (dest_Free b) |
|
1673 |
(HOLogic.mk_imp (R $ a $ b, S $ a $ b)))))); |
|
57301
7b997028aaac
generate 'rel_coinduct0' theorem for codatatypes
desharna
parents:
56954
diff
changeset
|
1674 |
val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) :: |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1675 |
@{map 6} mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys; |
51916 | 1676 |
val concl = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs_copy) $ x $ y); |
1677 |
in |
|
1678 |
Goal.prove_sorry lthy [] [] |
|
1679 |
(fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl))) |
|
57967 | 1680 |
(fn {context = ctxt, prems = _} => mk_rel_mono_strong0_tac ctxt (Lazy.force in_rel) |
55197 | 1681 |
(map Lazy.force set_map)) |
70494 | 1682 |
|> Thm.close_derivation \<^here> |
51916 | 1683 |
end; |
1684 |
||
57967 | 1685 |
val rel_mono_strong0 = Lazy.lazy mk_rel_mono_strong0; |
51916 | 1686 |
|
62324 | 1687 |
val rel_mono_strong = Lazy.map (Object_Logic.rulify lthy) rel_mono_strong0; |
57968 | 1688 |
|
61242 | 1689 |
fun mk_rel_cong_prem mk_implies x x' z z' set set' R R_copy = |
1690 |
Logic.all z (Logic.all z' |
|
1691 |
(mk_implies (mk_Trueprop_mem (z, set $ x), mk_implies (mk_Trueprop_mem (z', set' $ x'), |
|
1692 |
mk_Trueprop_eq (R $ z $ z', R_copy $ z $ z'))))); |
|
1693 |
||
1694 |
fun mk_rel_cong mk_implies () = |
|
1695 |
let |
|
1696 |
val prem0 = mk_Trueprop_eq (x, x_copy); |
|
1697 |
val prem1 = mk_Trueprop_eq (y, y_copy); |
|
1698 |
val prems = @{map 6} (mk_rel_cong_prem mk_implies x_copy y_copy) |
|
1699 |
zs ys bnf_sets_As bnf_sets_Bs Rs Rs_copy; |
|
1700 |
val eq = mk_Trueprop_eq (Term.list_comb (rel, Rs) $ x $ y, |
|
1701 |
Term.list_comb (rel, Rs_copy) $ x_copy $ y_copy); |
|
1702 |
in |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1703 |
fold (Variable.add_free_names lthy) (eq :: prem0 :: prem1 :: prems) [] |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1704 |
|> (fn vars => Goal.prove_sorry lthy vars (prem0 :: prem1 :: prems) eq |
61242 | 1705 |
(fn {context = ctxt, prems} => |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1706 |
mk_rel_cong_tac ctxt (chop 2 prems) (Lazy.force rel_mono_strong))) |
70494 | 1707 |
|> Thm.close_derivation \<^here> |
61242 | 1708 |
end; |
1709 |
||
1710 |
val rel_cong = Lazy.lazy (mk_rel_cong Logic.mk_implies); |
|
69593 | 1711 |
val rel_cong_simp = Lazy.lazy (mk_rel_cong (fn (a, b) => \<^term>\<open>simp_implies\<close> $ a $ b)); |
61242 | 1712 |
|
62324 | 1713 |
fun mk_pred_prems f = map2 (HOLogic.mk_Trueprop oo f) Ps Ps_copy; |
1714 |
fun mk_pred_concl f = HOLogic.mk_Trueprop |
|
1715 |
(f (Term.list_comb (pred, Ps), Term.list_comb (pred, Ps_copy))); |
|
1716 |
||
1717 |
fun mk_pred_cong0 () = |
|
1718 |
let |
|
1719 |
val cong_prems = mk_pred_prems (curry HOLogic.mk_eq); |
|
1720 |
val cong_concl = mk_pred_concl HOLogic.mk_eq; |
|
1721 |
in |
|
1722 |
Goal.prove_sorry lthy [] [] |
|
1723 |
(fold_rev Logic.all (Ps @ Ps_copy) (Logic.list_implies (cong_prems, cong_concl))) |
|
1724 |
(fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1) |
|
70494 | 1725 |
|> Thm.close_derivation \<^here> |
62324 | 1726 |
end; |
1727 |
||
1728 |
val pred_cong0 = Lazy.lazy mk_pred_cong0; |
|
1729 |
||
1730 |
fun mk_rel_eq_onp () = |
|
1731 |
let |
|
1732 |
val lhs = Term.list_comb (relAsAs, map mk_eq_onp Ps); |
|
1733 |
val rhs = mk_eq_onp (Term.list_comb (pred, Ps)); |
|
1734 |
in |
|
1735 |
Goal.prove_sorry lthy (map fst Ps') [] (mk_Trueprop_eq (lhs, rhs)) |
|
1736 |
(fn {context = ctxt, prems = _} => |
|
1737 |
mk_rel_eq_onp_tac ctxt (#pred_set axioms) (#map_id0 axioms) (Lazy.force rel_Grp)) |
|
70494 | 1738 |
|> Thm.close_derivation \<^here> |
62324 | 1739 |
end; |
1740 |
||
1741 |
val rel_eq_onp = Lazy.lazy mk_rel_eq_onp; |
|
1742 |
val pred_rel = Lazy.map (fn thm => thm RS sym RS @{thm eq_onp_eqD}) rel_eq_onp; |
|
1743 |
||
1744 |
fun mk_pred_mono_strong0 () = |
|
1745 |
let |
|
1746 |
fun mk_prem setA P Q a = |
|
1747 |
HOLogic.mk_Trueprop |
|
1748 |
(mk_Ball (setA $ x) (Term.absfree (dest_Free a) (HOLogic.mk_imp (P $ a, Q $ a)))); |
|
1749 |
val prems = HOLogic.mk_Trueprop (Term.list_comb (pred, Ps) $ x) :: |
|
1750 |
@{map 4} mk_prem bnf_sets_As Ps Ps_copy zs; |
|
1751 |
val concl = HOLogic.mk_Trueprop (Term.list_comb (pred, Ps_copy) $ x); |
|
1752 |
in |
|
1753 |
Goal.prove_sorry lthy [] [] |
|
1754 |
(fold_rev Logic.all (x :: Ps @ Ps_copy) (Logic.list_implies (prems, concl))) |
|
1755 |
(fn {context = ctxt, prems = _} => |
|
1756 |
mk_pred_mono_strong0_tac ctxt (Lazy.force pred_rel) (Lazy.force rel_mono_strong0)) |
|
70494 | 1757 |
|> Thm.close_derivation \<^here> |
62324 | 1758 |
end; |
1759 |
||
1760 |
val pred_mono_strong0 = Lazy.lazy mk_pred_mono_strong0; |
|
1761 |
||
1762 |
val pred_mono_strong = Lazy.map (Object_Logic.rulify lthy) pred_mono_strong0; |
|
1763 |
||
63714 | 1764 |
fun mk_pred_mono () = |
1765 |
let |
|
1766 |
val mono_prems = mk_pred_prems mk_leq; |
|
1767 |
val mono_concl = mk_pred_concl (uncurry mk_leq); |
|
1768 |
in |
|
1769 |
Goal.prove_sorry lthy [] [] |
|
1770 |
(fold_rev Logic.all (Ps @ Ps_copy) (Logic.list_implies (mono_prems, mono_concl))) |
|
1771 |
(fn {context = ctxt, prems = _} => |
|
1772 |
mk_pred_mono_tac ctxt (Lazy.force rel_eq_onp) (Lazy.force rel_mono)) |
|
70494 | 1773 |
|> Thm.close_derivation \<^here> |
63714 | 1774 |
end; |
1775 |
||
1776 |
val pred_mono = Lazy.lazy mk_pred_mono; |
|
1777 |
||
62324 | 1778 |
fun mk_pred_cong_prem mk_implies x z set P P_copy = |
1779 |
Logic.all z |
|
1780 |
(mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (P $ z, P_copy $ z))); |
|
1781 |
||
1782 |
fun mk_pred_cong mk_implies () = |
|
1783 |
let |
|
1784 |
val prem0 = mk_Trueprop_eq (x, x_copy); |
|
1785 |
val prems = @{map 4} (mk_pred_cong_prem mk_implies x_copy) zs bnf_sets_As Ps Ps_copy; |
|
1786 |
val eq = mk_Trueprop_eq (Term.list_comb (pred, Ps) $ x, |
|
1787 |
Term.list_comb (pred, Ps_copy) $ x_copy); |
|
1788 |
in |
|
1789 |
fold (Variable.add_free_names lthy) (eq :: prem0 :: prems) [] |
|
1790 |
|> (fn vars => Goal.prove_sorry lthy vars (prem0 :: prems) eq |
|
1791 |
(fn {context = ctxt, prems} => |
|
1792 |
mk_rel_cong_tac ctxt (chop 1 prems) (Lazy.force pred_mono_strong))) |
|
70494 | 1793 |
|> Thm.close_derivation \<^here> |
62324 | 1794 |
end; |
1795 |
||
1796 |
val pred_cong = Lazy.lazy (mk_pred_cong Logic.mk_implies); |
|
69593 | 1797 |
val pred_cong_simp = Lazy.lazy (mk_pred_cong (fn (a, b) => \<^term>\<open>simp_implies\<close> $ a $ b)); |
62324 | 1798 |
|
1799 |
fun mk_map_cong_pred () = |
|
1800 |
let |
|
1801 |
val prem0 = mk_Trueprop_eq (x, x_copy); |
|
1802 |
fun mk_eq f g z = Term.absfree (dest_Free z) (HOLogic.mk_eq (f $ z, g $ z)); |
|
1803 |
val prem = HOLogic.mk_Trueprop |
|
1804 |
(Term.list_comb (pred, @{map 3} mk_eq fs fs_copy zs) $ x_copy); |
|
1805 |
val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x, |
|
1806 |
Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy); |
|
1807 |
val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy) |
|
1808 |
(Logic.list_implies ([prem0, prem], eq)); |
|
1809 |
in |
|
1810 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
|
1811 |
unfold_thms_tac ctxt [#pred_set axioms] THEN |
|
1812 |
HEADGOAL (EVERY' [REPEAT_DETERM o etac ctxt conjE, |
|
1813 |
etac ctxt (Lazy.force map_cong) THEN_ALL_NEW |
|
63399 | 1814 |
(etac ctxt @{thm bspec} THEN' assume_tac ctxt)])) |
70494 | 1815 |
|> Thm.close_derivation \<^here> |
62324 | 1816 |
end; |
1817 |
||
1818 |
val map_cong_pred = Lazy.lazy mk_map_cong_pred; |
|
1819 |
||
57932 | 1820 |
fun mk_rel_map () = |
1821 |
let |
|
1822 |
fun mk_goal lhs rhs = |
|
1823 |
fold_rev Logic.all ([x, y] @ S_CsBs @ S_AsCs @ is @ gs) (mk_Trueprop_eq (lhs, rhs)); |
|
1824 |
||
1825 |
val lhss = |
|
1826 |
[Term.list_comb (relCsBs, S_CsBs) $ (Term.list_comb (bnf_map_AsCs, is) $ x) $ y, |
|
1827 |
Term.list_comb (relAsCs, S_AsCs) $ x $ (Term.list_comb (bnf_map_BsCs, gs) $ y)]; |
|
1828 |
val rhss = |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1829 |
[Term.list_comb (rel, @{map 3} (fn f => fn P => fn T => |
57932 | 1830 |
mk_vimage2p f (HOLogic.id_const T) $ P) is S_CsBs Bs') $ x $ y, |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1831 |
Term.list_comb (rel, @{map 3} (fn f => fn P => fn T => |
57932 | 1832 |
mk_vimage2p (HOLogic.id_const T) f $ P) gs S_AsCs As') $ x $ y]; |
1833 |
val goals = map2 mk_goal lhss rhss; |
|
1834 |
in |
|
57970 | 1835 |
goals |
1836 |
|> map (fn goal => Goal.prove_sorry lthy [] [] goal |
|
57932 | 1837 |
(fn {context = ctxt, prems = _} => |
1838 |
mk_rel_map0_tac ctxt live (Lazy.force rel_OO) (Lazy.force rel_conversep) |
|
57970 | 1839 |
(Lazy.force rel_Grp) (Lazy.force map_id))) |
63170 | 1840 |
|> map (unfold_thms lthy @{thms vimage2p_def[of id, simplified id_apply] |
1841 |
vimage2p_def[of _ id, simplified id_apply]}) |
|
70494 | 1842 |
|> map (Thm.close_derivation \<^here>) |
57932 | 1843 |
end; |
1844 |
||
1845 |
val rel_map = Lazy.lazy mk_rel_map; |
|
1846 |
||
59726 | 1847 |
fun mk_rel_refl () = @{thm ge_eq_refl[OF ord_eq_le_trans]} OF |
1848 |
[Lazy.force rel_eq RS sym, Lazy.force rel_mono OF (replicate live @{thm refl_ge_eq})]; |
|
1849 |
||
1850 |
val rel_refl = Lazy.lazy mk_rel_refl; |
|
1851 |
||
61240 | 1852 |
fun mk_rel_refl_strong () = |
1853 |
(rule_by_tactic lthy (ALLGOALS (Object_Logic.full_atomize_tac lthy)) |
|
1854 |
((Lazy.force rel_eq RS @{thm predicate2_eqD}) RS @{thm iffD2[OF _ refl]} RS |
|
1855 |
Lazy.force rel_mono_strong)) OF |
|
1856 |
(replicate live @{thm diag_imp_eq_le}) |
|
1857 |
||
1858 |
val rel_refl_strong = Lazy.lazy mk_rel_refl_strong; |
|
1859 |
||
1860 |
fun mk_rel_preserves mk_prop prop_conv_thm thm () = |
|
1861 |
let |
|
1862 |
val Rs = map2 retype_const_or_free self_pred2RTs Rs; |
|
1863 |
val prems = map (HOLogic.mk_Trueprop o mk_prop) Rs; |
|
1864 |
val goal = HOLogic.mk_Trueprop (mk_prop (Term.list_comb (relAsAs, Rs))); |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1865 |
val vars = fold (Variable.add_free_names lthy) (goal :: prems) []; |
61240 | 1866 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1867 |
Goal.prove_sorry lthy vars [] (Logic.list_implies (prems, goal)) |
61240 | 1868 |
(fn {context = ctxt, prems = _} => |
1869 |
unfold_thms_tac ctxt [prop_conv_thm] THEN |
|
62324 | 1870 |
HEADGOAL (rtac ctxt (Lazy.force thm RS sym RS @{thm ord_eq_le_trans}) |
61240 | 1871 |
THEN' rtac ctxt (Lazy.force rel_mono) THEN_ALL_NEW assume_tac ctxt)) |
70494 | 1872 |
|> Thm.close_derivation \<^here> |
61240 | 1873 |
end; |
1874 |
||
1875 |
val rel_reflp = Lazy.lazy (mk_rel_preserves mk_reflp @{thm reflp_eq} rel_eq); |
|
1876 |
val rel_symp = Lazy.lazy (mk_rel_preserves mk_symp @{thm symp_conversep} rel_conversep); |
|
1877 |
val rel_transp = Lazy.lazy (mk_rel_preserves mk_transp @{thm transp_relcompp} rel_OO); |
|
1878 |
||
62324 | 1879 |
fun mk_pred_True () = |
1880 |
let |
|
69593 | 1881 |
val lhs = Term.list_comb (pred, map (fn T => absdummy T \<^term>\<open>True\<close>) As'); |
1882 |
val rhs = absdummy CA' \<^term>\<open>True\<close>; |
|
62324 | 1883 |
val goal = mk_Trueprop_eq (lhs, rhs); |
1884 |
in |
|
1885 |
Goal.prove_sorry lthy [] [] goal |
|
1886 |
(fn {context = ctxt, prems = _} => |
|
1887 |
HEADGOAL (EVERY' (map (rtac ctxt) [ext, Lazy.force pred_rel RS trans, |
|
1888 |
Lazy.force rel_cong0 RS fun_cong RS fun_cong RS trans OF |
|
1889 |
replicate live @{thm eq_onp_True}, |
|
1890 |
Lazy.force rel_eq RS fun_cong RS fun_cong RS trans, @{thm eqTrueI[OF refl]}]))) |
|
70494 | 1891 |
|> Thm.close_derivation \<^here> |
62324 | 1892 |
end; |
1893 |
||
1894 |
val pred_True = Lazy.lazy mk_pred_True; |
|
1895 |
||
1896 |
fun mk_pred_map () = |
|
1897 |
let |
|
1898 |
val lhs = Term.list_comb (pred', Qs) $ (Term.list_comb (bnf_map_AsBs, fs) $ x); |
|
1899 |
val rhs = Term.list_comb (pred, @{map 2} (curry HOLogic.mk_comp) Qs fs) $ x; |
|
1900 |
val goal = mk_Trueprop_eq (lhs, rhs); |
|
1901 |
val vars = Variable.add_free_names lthy goal []; |
|
1902 |
val pred_set = #pred_set axioms RS fun_cong RS sym; |
|
1903 |
in |
|
1904 |
Goal.prove_sorry lthy vars [] goal |
|
1905 |
(fn {context = ctxt, prems = _} => |
|
1906 |
HEADGOAL (rtac ctxt (pred_set RSN (2, pred_set RSN (2, box_equals)))) THEN |
|
67222 | 1907 |
unfold_thms_tac ctxt |
1908 |
(@{thms Ball_image_comp ball_empty} @ map Lazy.force set_map) THEN |
|
62324 | 1909 |
HEADGOAL (rtac ctxt refl)) |
70494 | 1910 |
|> Thm.close_derivation \<^here> |
62324 | 1911 |
end; |
1912 |
||
1913 |
val pred_map = Lazy.lazy mk_pred_map; |
|
1914 |
||
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1915 |
fun mk_map_transfer () = |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1916 |
let |
55945 | 1917 |
val rels = map2 mk_rel_fun transfer_domRs transfer_ranRs; |
1918 |
val rel = mk_rel_fun |
|
52725 | 1919 |
(Term.list_comb (mk_bnf_rel transfer_domRTs CA' CB1, transfer_domRs)) |
1920 |
(Term.list_comb (mk_bnf_rel transfer_ranRTs CB' CB2, transfer_ranRs)); |
|
1921 |
val concl = HOLogic.mk_Trueprop |
|
55945 | 1922 |
(fold_rev mk_rel_fun rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts); |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1923 |
in |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1924 |
Goal.prove_sorry lthy [] [] |
52725 | 1925 |
(fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl) |
55197 | 1926 |
(fn {context = ctxt, prems = _} => mk_map_transfer_tac ctxt (Lazy.force rel_mono) |
1927 |
(Lazy.force in_rel) (map Lazy.force set_map) (#map_cong0 axioms) |
|
1928 |
(Lazy.force map_comp)) |
|
70494 | 1929 |
|> Thm.close_derivation \<^here> |
52719
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1930 |
end; |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1931 |
|
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1932 |
val map_transfer = Lazy.lazy mk_map_transfer; |
480a3479fa47
transfer rule for map (not yet registered as a transfer rule)
traytel
parents:
52635
diff
changeset
|
1933 |
|
62329 | 1934 |
fun mk_pred_transfer () = |
1935 |
let |
|
1936 |
val iff = HOLogic.eq_const HOLogic.boolT; |
|
1937 |
val prem_rels = map (fn T => mk_rel_fun T iff) Rs; |
|
1938 |
val prem_elems = mk_rel_fun (Term.list_comb (rel, Rs)) iff; |
|
1939 |
val goal = HOLogic.mk_Trueprop |
|
1940 |
(fold_rev mk_rel_fun prem_rels prem_elems $ pred $ pred'); |
|
1941 |
val vars = Variable.add_free_names lthy goal []; |
|
1942 |
in |
|
1943 |
Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => |
|
1944 |
mk_pred_transfer_tac ctxt live (Lazy.force in_rel) (Lazy.force pred_map) |
|
1945 |
(Lazy.force pred_cong)) |
|
70494 | 1946 |
|> Thm.close_derivation \<^here> |
62329 | 1947 |
end; |
1948 |
||
1949 |
val pred_transfer = Lazy.lazy mk_pred_transfer; |
|
1950 |
||
58104 | 1951 |
fun mk_rel_transfer () = |
1952 |
let |
|
1953 |
val iff = HOLogic.eq_const HOLogic.boolT; |
|
1954 |
val prem_rels = |
|
1955 |
map2 (fn T1 => fn T2 => mk_rel_fun T1 (mk_rel_fun T2 iff)) S_AsCs S_BsEs; |
|
1956 |
val prem_elems = |
|
1957 |
mk_rel_fun (Term.list_comb (mk_bnf_rel pred2RTsAsCs CA' CC', S_AsCs)) |
|
1958 |
(mk_rel_fun (Term.list_comb (mk_bnf_rel pred2RTsBsEs CB' CE', S_BsEs)) iff); |
|
1959 |
val goal = |
|
1960 |
HOLogic.mk_Trueprop (fold_rev mk_rel_fun prem_rels prem_elems $ rel $ relCsEs); |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1961 |
val vars = Variable.add_free_names lthy goal []; |
58104 | 1962 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1963 |
Goal.prove_sorry lthy vars [] goal |
58104 | 1964 |
(fn {context = ctxt, prems = _} => |
1965 |
mk_rel_transfer_tac ctxt (Lazy.force in_rel) (Lazy.force rel_map) |
|
1966 |
(Lazy.force rel_mono_strong)) |
|
70494 | 1967 |
|> Thm.close_derivation \<^here> |
58104 | 1968 |
end; |
1969 |
||
1970 |
val rel_transfer = Lazy.lazy mk_rel_transfer; |
|
1971 |
||
58106 | 1972 |
fun mk_set_transfer () = |
1973 |
let |
|
69593 | 1974 |
val rel_sets = map2 (fn A => fn B => mk_rel 1 [A] [B] \<^term>\<open>rel_set\<close>) As' Bs'; |
58106 | 1975 |
val rel_Rs = Term.list_comb (rel, Rs); |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1976 |
val goals = @{map 4} (fn R => fn rel_set => fn setA => fn setB => HOLogic.mk_Trueprop |
58106 | 1977 |
(mk_rel_fun rel_Rs (rel_set $ R) $ setA $ setB)) Rs rel_sets bnf_sets_As bnf_sets_Bs; |
1978 |
in |
|
1979 |
if null goals then [] |
|
1980 |
else |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1981 |
let |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1982 |
val goal = Logic.mk_conjunction_balanced goals; |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1983 |
val vars = Variable.add_free_names lthy goal []; |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1984 |
in |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1985 |
Goal.prove_sorry lthy vars [] goal |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1986 |
(fn {context = ctxt, prems = _} => |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1987 |
mk_set_transfer_tac ctxt (Lazy.force in_rel) (map Lazy.force set_map)) |
70494 | 1988 |
|> Thm.close_derivation \<^here> |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1989 |
|> Conjunction.elim_balanced (length goals) |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1990 |
end |
58106 | 1991 |
end; |
1992 |
||
1993 |
val set_transfer = Lazy.lazy mk_set_transfer; |
|
1994 |
||
57970 | 1995 |
fun mk_inj_map_strong () = |
1996 |
let |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58432
diff
changeset
|
1997 |
val assms = @{map 5} (fn setA => fn z => fn f => fn z' => fn f' => |
57970 | 1998 |
fold_rev Logic.all [z, z'] |
1999 |
(Logic.mk_implies (mk_Trueprop_mem (z, setA $ x), |
|
2000 |
Logic.mk_implies (mk_Trueprop_mem (z', setA $ x'), |
|
2001 |
Logic.mk_implies (mk_Trueprop_eq (f $ z, f' $ z'), |
|
2002 |
mk_Trueprop_eq (z, z')))))) bnf_sets_As zs fs zs' fs'; |
|
2003 |
val concl = Logic.mk_implies |
|
2004 |
(mk_Trueprop_eq |
|
2005 |
(Term.list_comb (bnf_map_AsBs, fs) $ x, |
|
2006 |
Term.list_comb (bnf_map_AsBs, fs') $ x'), |
|
2007 |
mk_Trueprop_eq (x, x')); |
|
2008 |
val goal = fold_rev Logic.all (x :: x' :: fs @ fs') |
|
2009 |
(fold_rev (curry Logic.mk_implies) assms concl); |
|
2010 |
in |
|
2011 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
|
2012 |
mk_inj_map_strong_tac ctxt (Lazy.force rel_eq) (Lazy.force rel_map) |
|
2013 |
(Lazy.force rel_mono_strong)) |
|
70494 | 2014 |
|> Thm.close_derivation \<^here> |
57970 | 2015 |
end; |
2016 |
||
2017 |
val inj_map_strong = Lazy.lazy mk_inj_map_strong; |
|
2018 |
||
62324 | 2019 |
val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_pred_def; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2020 |
|
52635
4f84b730c489
got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents:
51930
diff
changeset
|
2021 |
val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong |
62324 | 2022 |
in_mono in_rel inj_map inj_map_strong map_comp map_cong map_cong_simp map_cong_pred map_id |
2023 |
map_ident0 map_ident map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp |
|
2024 |
rel_map rel_mono rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep |
|
2025 |
rel_OO rel_refl rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp |
|
63714 | 2026 |
pred_transfer pred_True pred_map pred_rel pred_mono_strong0 pred_mono_strong pred_mono |
2027 |
pred_cong0 pred_cong pred_cong_simp; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2028 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2029 |
val wits = map2 mk_witness bnf_wits wit_thms; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2030 |
|
49507 | 2031 |
val bnf_rel = |
2032 |
Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2033 |
|
62324 | 2034 |
val bnf_pred = Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas)) pred; |
2035 |
||
54841
af71b753c459
express weak pullback property of bnfs only in terms of the relator
traytel
parents:
54740
diff
changeset
|
2036 |
val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms |
62324 | 2037 |
defs facts wits bnf_rel bnf_pred; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2038 |
in |
57631
959caab43a3d
use the noted theorem whenever possible, also in 'BNF_Def'
blanchet
parents:
57567
diff
changeset
|
2039 |
note_bnf_thms fact_policy qualify bnf_b bnf lthy |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2040 |
end; |
49459 | 2041 |
|
2042 |
val one_step_defs = |
|
62324 | 2043 |
no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ |
2044 |
[bnf_rel_def, bnf_pred_def]); |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2045 |
in |
49459 | 2046 |
(key, goals, wit_goalss, after_qed, lthy, one_step_defs) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2047 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2048 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2049 |
structure BNF_Plugin = Plugin(type T = bnf); |
56346 | 2050 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2051 |
fun bnf_interpretation name f = |
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2052 |
BNF_Plugin.interpretation name |
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2053 |
(fn bnf => fn lthy => f (transfer_bnf (Proof_Context.theory_of lthy) bnf) lthy); |
56376
5a93b8f928a2
added same idiomatic handling of namings for Ctr_Sugar/BNF-related interpretation hooks as for typedef and (old-style) datatypes
blanchet
parents:
56346
diff
changeset
|
2054 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2055 |
val interpret_bnf = BNF_Plugin.data; |
56346 | 2056 |
|
58177
166131276380
introduced local interpretation mechanism for BNFs, to solve issues with datatypes in locales
blanchet
parents:
58175
diff
changeset
|
2057 |
fun register_bnf_raw key bnf = |
56346 | 2058 |
Local_Theory.declaration {syntax = false, pervasive = true} |
58177
166131276380
introduced local interpretation mechanism for BNFs, to solve issues with datatypes in locales
blanchet
parents:
58175
diff
changeset
|
2059 |
(fn phi => Data.map (Symtab.update (key, morph_bnf phi bnf))); |
166131276380
introduced local interpretation mechanism for BNFs, to solve issues with datatypes in locales
blanchet
parents:
58175
diff
changeset
|
2060 |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
2061 |
fun register_bnf plugins key bnf = |
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
2062 |
register_bnf_raw key bnf #> interpret_bnf plugins bnf; |
49434
433dc7e028c8
separated registration of BNFs from bnf_def (BNFs are now stored only for bnf_def and (co)data commands)
traytel
parents:
49430
diff
changeset
|
2063 |
|
62324 | 2064 |
fun bnf_def const_policy fact_policy internal qualify tacs wit_tac Ds map_b rel_b pred_b set_bs |
2065 |
raw_csts = |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2066 |
(fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) => |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2067 |
let |
55197 | 2068 |
fun mk_wits_tac ctxt set_maps = |
2069 |
TRYALL Goal.conjunction_tac THEN |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2070 |
(case triv_tac_opt of |
55197 | 2071 |
SOME tac => tac ctxt set_maps |
2072 |
| NONE => unfold_thms_tac ctxt one_step_defs THEN wit_tac ctxt); |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2073 |
val wit_goals = map Logic.mk_conjunction_balanced wit_goalss; |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2074 |
fun mk_wit_thms set_maps = |
55197 | 2075 |
Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) |
2076 |
(fn {context = ctxt, prems = _} => mk_wits_tac ctxt set_maps) |
|
70494 | 2077 |
|> Thm.close_derivation \<^here> |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2078 |
|> Conjunction.elim_balanced (length wit_goals) |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2079 |
|> map2 (Conjunction.elim_balanced o length) wit_goalss |
61116
6189d179c2b5
close derivation *before* splitting conjuncts, like Goal.prove_common (see also 757cad5a3fe9) -- potential improvement of performance;
wenzelm
parents:
61101
diff
changeset
|
2080 |
|> (map o map) (Thm.forall_elim_vars 0); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2081 |
in |
70494 | 2082 |
map2 (Thm.close_derivation \<^here> oo Goal.prove_sorry lthy [] []) |
55197 | 2083 |
goals (map (fn tac => fn {context = ctxt, prems = _} => |
2084 |
unfold_thms_tac ctxt one_step_defs THEN tac ctxt) tacs) |
|
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2085 |
|> (fn thms => after_qed mk_wit_thms (map single thms) lthy) |
62324 | 2086 |
end) o prepare_def const_policy fact_policy internal qualify (K I) (K I) Ds map_b rel_b pred_b |
2087 |
set_bs raw_csts; |
|
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2088 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2089 |
fun bnf_cmd (raw_csts, raw_plugins) = |
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
2090 |
(fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) => |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2091 |
let |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
2092 |
val plugins = raw_plugins lthy; |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2093 |
val wit_goals = map Logic.mk_conjunction_balanced wit_goalss; |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2094 |
fun mk_triv_wit_thms tac set_maps = |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2095 |
Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) |
55197 | 2096 |
(fn {context = ctxt, prems = _} => TRYALL Goal.conjunction_tac THEN tac ctxt set_maps) |
70494 | 2097 |
|> Thm.close_derivation \<^here> |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2098 |
|> Conjunction.elim_balanced (length wit_goals) |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2099 |
|> map2 (Conjunction.elim_balanced o length) wit_goalss |
61116
6189d179c2b5
close derivation *before* splitting conjuncts, like Goal.prove_common (see also 757cad5a3fe9) -- potential improvement of performance;
wenzelm
parents:
61101
diff
changeset
|
2100 |
|> (map o map) (Thm.forall_elim_vars 0); |
57301
7b997028aaac
generate 'rel_coinduct0' theorem for codatatypes
desharna
parents:
56954
diff
changeset
|
2101 |
val (mk_wit_thms, nontriv_wit_goals) = |
54189
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2102 |
(case triv_tac_opt of |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2103 |
NONE => (fn _ => [], map (map (rpair [])) wit_goalss) |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2104 |
| SOME tac => (mk_triv_wit_thms tac, [])); |
c0186a0d8cb3
define a trivial nonemptiness witness if none is provided
traytel
parents:
54158
diff
changeset
|
2105 |
in |
62324 | 2106 |
lthy |
2107 |
|> Proof.theorem NONE (uncurry (register_bnf plugins key) oo after_qed mk_wit_thms) |
|
2108 |
(map (single o rpair []) goals @ nontriv_wit_goals) |
|
2109 |
|> Proof.unfolding ([[(@{thm OO_Grp_alt} :: @{thm mem_Collect_eq} :: defs, [])]]) |
|
2110 |
|> Proof.refine_singleton (Method.Basic (fn ctxt => |
|
2111 |
Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
2112 |
end) o prepare_def Do_Inline (user_policy Note_Some) false I Syntax.read_typ Syntax.read_term |
62324 | 2113 |
NONE Binding.empty Binding.empty Binding.empty [] raw_csts; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2114 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2115 |
fun print_bnfs ctxt = |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2116 |
let |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2117 |
fun pretty_set sets i = Pretty.block |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2118 |
[Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1, |
59663 | 2119 |
Pretty.quote (Syntax.pretty_term ctxt (nth sets i))]; |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2120 |
|
56903 | 2121 |
fun pretty_bnf (key, BNF {T, map, sets, bd, live, lives, dead, deads, ...}) = |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2122 |
Pretty.big_list |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2123 |
(Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2124 |
Pretty.quote (Syntax.pretty_typ ctxt T)])) |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2125 |
([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live), |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2126 |
Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)], |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2127 |
Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead), |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2128 |
Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)], |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2129 |
Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2130 |
Pretty.quote (Syntax.pretty_term ctxt map)]] @ |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2131 |
List.map (pretty_set sets) (0 upto length sets - 1) @ |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2132 |
[Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1, |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2133 |
Pretty.quote (Syntax.pretty_term ctxt bd)]]); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2134 |
in |
59822 | 2135 |
Pretty.big_list "Registered bounded natural functors:" |
60924
610794dff23c
tuned signature, in accordance to sortBy in Scala;
wenzelm
parents:
60801
diff
changeset
|
2136 |
(map pretty_bnf (sort_by fst (Symtab.dest (Data.get (Context.Proof ctxt))))) |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2137 |
|> Pretty.writeln |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2138 |
end; |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2139 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2140 |
val _ = |
69593 | 2141 |
Outer_Syntax.command \<^command_keyword>\<open>print_bnfs\<close> |
53289 | 2142 |
"print all bounded natural functors" |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2143 |
(Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of))); |
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2144 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2145 |
val _ = |
69593 | 2146 |
Outer_Syntax.local_theory_to_proof \<^command_keyword>\<open>bnf\<close> |
53289 | 2147 |
"register a type as a bounded natural functor" |
54421 | 2148 |
(parse_opt_binding_colon -- Parse.typ --| |
69593 | 2149 |
(Parse.reserved "map" -- \<^keyword>\<open>:\<close>) -- Parse.term -- |
2150 |
Scan.optional ((Parse.reserved "sets" -- \<^keyword>\<open>:\<close>) |-- |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
2151 |
Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) [] --| |
69593 | 2152 |
(Parse.reserved "bd" -- \<^keyword>\<open>:\<close>) -- Parse.term -- |
2153 |
Scan.optional ((Parse.reserved "wits" -- \<^keyword>\<open>:\<close>) |-- |
|
58432 | 2154 |
Scan.repeat1 (Scan.unless (Parse.reserved "rel" || |
2155 |
Parse.reserved "plugins") Parse.term)) [] -- |
|
69593 | 2156 |
Scan.option ((Parse.reserved "rel" -- \<^keyword>\<open>:\<close>) |-- Parse.term) -- |
2157 |
Scan.option ((Parse.reserved "pred" -- \<^keyword>\<open>:\<close>) |-- Parse.term) -- |
|
58660 | 2158 |
Scan.optional Plugin_Name.parse_filter (K Plugin_Name.default_filter) |
51836
4d6dcd51dd52
renamed "bnf_def" keyword to "bnf" (since it's not a definition, but rather a registration)
blanchet
parents:
51823
diff
changeset
|
2159 |
>> bnf_cmd); |
48975
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2160 |
|
7f79f94a432c
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff
changeset
|
2161 |
end; |