blanchet@49990
|
1 |
(* Title: HOL/Codatatype/Tools/bnf_def.ML
|
blanchet@49990
|
2 |
Author: Dmitriy Traytel, TU Muenchen
|
blanchet@49990
|
3 |
Author: Jasmin Blanchette, TU Muenchen
|
blanchet@49990
|
4 |
Copyright 2012
|
blanchet@49990
|
5 |
|
blanchet@49990
|
6 |
Definition of bounded natural functors.
|
blanchet@49990
|
7 |
*)
|
blanchet@49990
|
8 |
|
blanchet@49990
|
9 |
signature BNF_DEF =
|
blanchet@49990
|
10 |
sig
|
blanchet@49990
|
11 |
type BNF
|
blanchet@49990
|
12 |
type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
|
blanchet@49990
|
13 |
|
blanchet@49990
|
14 |
val bnf_of: Proof.context -> string -> BNF option
|
blanchet@49990
|
15 |
val name_of_bnf: BNF -> binding
|
blanchet@49990
|
16 |
val T_of_bnf: BNF -> typ
|
blanchet@49990
|
17 |
val live_of_bnf: BNF -> int
|
blanchet@49990
|
18 |
val lives_of_bnf: BNF -> typ list
|
blanchet@49990
|
19 |
val dead_of_bnf: BNF -> int
|
blanchet@49990
|
20 |
val deads_of_bnf: BNF -> typ list
|
blanchet@49990
|
21 |
val nwits_of_bnf: BNF -> int
|
blanchet@49990
|
22 |
|
blanchet@49990
|
23 |
val mapN: string
|
blanchet@49990
|
24 |
val setN: string
|
blanchet@49990
|
25 |
val relN: string
|
blanchet@49990
|
26 |
val predN: string
|
blanchet@49990
|
27 |
val mk_setN: int -> string
|
blanchet@49990
|
28 |
val rel_unfoldN: string
|
blanchet@49990
|
29 |
val pred_unfoldN: string
|
blanchet@49990
|
30 |
|
blanchet@50229
|
31 |
val map_of_bnf: BNF -> term
|
blanchet@50229
|
32 |
|
blanchet@49990
|
33 |
val mk_T_of_bnf: typ list -> typ list -> BNF -> typ
|
blanchet@49990
|
34 |
val mk_bd_of_bnf: typ list -> typ list -> BNF -> term
|
blanchet@49990
|
35 |
val mk_map_of_bnf: typ list -> typ list -> typ list -> BNF -> term
|
blanchet@49990
|
36 |
val mk_pred_of_bnf: typ list -> typ list -> typ list -> BNF -> term
|
blanchet@49990
|
37 |
val mk_rel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
|
blanchet@49990
|
38 |
val mk_sets_of_bnf: typ list list -> typ list list -> BNF -> term list
|
blanchet@49990
|
39 |
val mk_wits_of_bnf: typ list list -> typ list list -> BNF -> (int list * term) list
|
blanchet@49990
|
40 |
|
blanchet@49990
|
41 |
val bd_Card_order_of_bnf: BNF -> thm
|
blanchet@49990
|
42 |
val bd_Cinfinite_of_bnf: BNF -> thm
|
blanchet@49990
|
43 |
val bd_Cnotzero_of_bnf: BNF -> thm
|
blanchet@49990
|
44 |
val bd_card_order_of_bnf: BNF -> thm
|
blanchet@49990
|
45 |
val bd_cinfinite_of_bnf: BNF -> thm
|
blanchet@49990
|
46 |
val collect_set_natural_of_bnf: BNF -> thm
|
blanchet@49990
|
47 |
val in_bd_of_bnf: BNF -> thm
|
blanchet@49990
|
48 |
val in_cong_of_bnf: BNF -> thm
|
blanchet@49990
|
49 |
val in_mono_of_bnf: BNF -> thm
|
blanchet@49990
|
50 |
val in_rel_of_bnf: BNF -> thm
|
blanchet@49990
|
51 |
val map_comp'_of_bnf: BNF -> thm
|
blanchet@49990
|
52 |
val map_comp_of_bnf: BNF -> thm
|
blanchet@49990
|
53 |
val map_cong_of_bnf: BNF -> thm
|
blanchet@49990
|
54 |
val map_def_of_bnf: BNF -> thm
|
blanchet@49990
|
55 |
val map_id'_of_bnf: BNF -> thm
|
blanchet@49990
|
56 |
val map_id_of_bnf: BNF -> thm
|
blanchet@49990
|
57 |
val map_wppull_of_bnf: BNF -> thm
|
blanchet@49990
|
58 |
val map_wpull_of_bnf: BNF -> thm
|
blanchet@49990
|
59 |
val pred_def_of_bnf: BNF -> thm
|
blanchet@49990
|
60 |
val rel_Gr_of_bnf: BNF -> thm
|
blanchet@49990
|
61 |
val rel_Id_of_bnf: BNF -> thm
|
blanchet@49990
|
62 |
val rel_O_of_bnf: BNF -> thm
|
blanchet@49990
|
63 |
val rel_cong_of_bnf: BNF -> thm
|
blanchet@49990
|
64 |
val rel_converse_of_bnf: BNF -> thm
|
blanchet@49990
|
65 |
val rel_def_of_bnf: BNF -> thm
|
blanchet@49990
|
66 |
val rel_mono_of_bnf: BNF -> thm
|
blanchet@49990
|
67 |
val set_bd_of_bnf: BNF -> thm list
|
blanchet@49990
|
68 |
val set_defs_of_bnf: BNF -> thm list
|
blanchet@49990
|
69 |
val set_natural'_of_bnf: BNF -> thm list
|
blanchet@49990
|
70 |
val set_natural_of_bnf: BNF -> thm list
|
blanchet@49990
|
71 |
val sets_of_bnf: BNF -> term list
|
blanchet@49990
|
72 |
val wit_thms_of_bnf: BNF -> thm list
|
blanchet@49990
|
73 |
val wit_thmss_of_bnf: BNF -> thm list list
|
blanchet@49990
|
74 |
|
blanchet@49990
|
75 |
val mk_witness: int list * term -> thm list -> nonemptiness_witness
|
traytel@50118
|
76 |
val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
|
blanchet@49990
|
77 |
val wits_of_bnf: BNF -> nonemptiness_witness list
|
blanchet@49990
|
78 |
|
blanchet@49990
|
79 |
datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
|
blanchet@49990
|
80 |
datatype fact_policy =
|
blanchet@49990
|
81 |
Derive_Some_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms
|
blanchet@49990
|
82 |
val bnf_note_all: bool Config.T
|
blanchet@49990
|
83 |
val user_policy: Proof.context -> fact_policy
|
blanchet@49990
|
84 |
|
blanchet@49990
|
85 |
val print_bnfs: Proof.context -> unit
|
blanchet@50033
|
86 |
val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
|
blanchet@49990
|
87 |
({prems: thm list, context: Proof.context} -> tactic) list ->
|
blanchet@49990
|
88 |
({prems: thm list, context: Proof.context} -> tactic) -> typ list option ->
|
blanchet@49990
|
89 |
(((binding * term) * term list) * term) * term list -> local_theory ->
|
blanchet@49990
|
90 |
BNF * local_theory
|
blanchet@49990
|
91 |
|
blanchet@49990
|
92 |
val filter_refl: thm list -> thm list
|
blanchet@50033
|
93 |
val bnf_def_cmd: (((binding * string) * string list) * string) * string list -> local_theory ->
|
blanchet@49990
|
94 |
Proof.state
|
blanchet@49990
|
95 |
end;
|
blanchet@49990
|
96 |
|
blanchet@49990
|
97 |
structure BNF_Def : BNF_DEF =
|
blanchet@49990
|
98 |
struct
|
blanchet@49990
|
99 |
|
blanchet@49990
|
100 |
open BNF_Util
|
blanchet@49990
|
101 |
open BNF_Tactics
|
blanchet@49990
|
102 |
|
blanchet@49990
|
103 |
type axioms = {
|
blanchet@49990
|
104 |
map_id: thm,
|
blanchet@49990
|
105 |
map_comp: thm,
|
blanchet@49990
|
106 |
map_cong: thm,
|
blanchet@49990
|
107 |
set_natural: thm list,
|
blanchet@49990
|
108 |
bd_card_order: thm,
|
blanchet@49990
|
109 |
bd_cinfinite: thm,
|
blanchet@49990
|
110 |
set_bd: thm list,
|
blanchet@49990
|
111 |
in_bd: thm,
|
blanchet@49990
|
112 |
map_wpull: thm
|
blanchet@49990
|
113 |
};
|
blanchet@49990
|
114 |
|
blanchet@49990
|
115 |
fun mk_axioms' ((((((((id, comp), cong), nat), c_o), cinf), set_bd), in_bd), wpull) =
|
blanchet@49990
|
116 |
{map_id = id, map_comp = comp, map_cong = cong, set_natural = nat, bd_card_order = c_o,
|
blanchet@49990
|
117 |
bd_cinfinite = cinf, set_bd = set_bd, in_bd = in_bd, map_wpull = wpull};
|
blanchet@49990
|
118 |
|
blanchet@49990
|
119 |
fun dest_cons [] = raise Empty
|
blanchet@49990
|
120 |
| dest_cons (x :: xs) = (x, xs);
|
blanchet@49990
|
121 |
|
blanchet@49990
|
122 |
fun mk_axioms n thms = thms
|
blanchet@49990
|
123 |
|> map the_single
|
blanchet@49990
|
124 |
|> dest_cons
|
blanchet@49990
|
125 |
||>> dest_cons
|
blanchet@49990
|
126 |
||>> dest_cons
|
blanchet@49990
|
127 |
||>> chop n
|
blanchet@49990
|
128 |
||>> dest_cons
|
blanchet@49990
|
129 |
||>> dest_cons
|
blanchet@49990
|
130 |
||>> chop n
|
blanchet@49990
|
131 |
||>> dest_cons
|
blanchet@49990
|
132 |
||> the_single
|
blanchet@49990
|
133 |
|> mk_axioms';
|
blanchet@49990
|
134 |
|
blanchet@49990
|
135 |
fun dest_axioms {map_id, map_comp, map_cong, set_natural,
|
blanchet@49990
|
136 |
bd_card_order, bd_cinfinite, set_bd, in_bd, map_wpull} =
|
blanchet@49990
|
137 |
[map_id, map_comp, map_cong] @ set_natural @ [bd_card_order, bd_cinfinite] @
|
blanchet@49990
|
138 |
set_bd @ [in_bd, map_wpull];
|
blanchet@49990
|
139 |
|
blanchet@49990
|
140 |
fun map_axioms f
|
blanchet@49990
|
141 |
{map_id = map_id, map_comp = map_comp, map_cong = map_cong, set_natural = set_natural,
|
blanchet@49990
|
142 |
bd_card_order = bd_card_order, bd_cinfinite = bd_cinfinite,
|
blanchet@49990
|
143 |
set_bd = set_bd, in_bd = in_bd, map_wpull = map_wpull} =
|
blanchet@49990
|
144 |
{map_id = f map_id,
|
blanchet@49990
|
145 |
map_comp = f map_comp,
|
blanchet@49990
|
146 |
map_cong = f map_cong,
|
blanchet@49990
|
147 |
set_natural = map f set_natural,
|
blanchet@49990
|
148 |
bd_card_order = f bd_card_order,
|
blanchet@49990
|
149 |
bd_cinfinite = f bd_cinfinite,
|
blanchet@49990
|
150 |
set_bd = map f set_bd,
|
blanchet@49990
|
151 |
in_bd = f in_bd,
|
blanchet@49990
|
152 |
map_wpull = f map_wpull};
|
blanchet@49990
|
153 |
|
blanchet@49990
|
154 |
val morph_axioms = map_axioms o Morphism.thm;
|
blanchet@49990
|
155 |
|
blanchet@49990
|
156 |
type defs = {
|
blanchet@49990
|
157 |
map_def: thm,
|
blanchet@49990
|
158 |
set_defs: thm list,
|
blanchet@49990
|
159 |
rel_def: thm,
|
blanchet@49990
|
160 |
pred_def: thm
|
blanchet@49990
|
161 |
}
|
blanchet@49990
|
162 |
|
blanchet@49990
|
163 |
fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred};
|
blanchet@49990
|
164 |
|
blanchet@49990
|
165 |
fun map_defs f {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred} =
|
blanchet@49990
|
166 |
{map_def = f map, set_defs = List.map f sets, rel_def = f rel, pred_def = f pred};
|
blanchet@49990
|
167 |
|
blanchet@49990
|
168 |
val morph_defs = map_defs o Morphism.thm;
|
blanchet@49990
|
169 |
|
blanchet@49990
|
170 |
type facts = {
|
blanchet@49990
|
171 |
bd_Card_order: thm,
|
blanchet@49990
|
172 |
bd_Cinfinite: thm,
|
blanchet@49990
|
173 |
bd_Cnotzero: thm,
|
blanchet@49990
|
174 |
collect_set_natural: thm lazy,
|
blanchet@49990
|
175 |
in_cong: thm lazy,
|
blanchet@49990
|
176 |
in_mono: thm lazy,
|
blanchet@49990
|
177 |
in_rel: thm lazy,
|
blanchet@49990
|
178 |
map_comp': thm lazy,
|
blanchet@49990
|
179 |
map_id': thm lazy,
|
blanchet@49990
|
180 |
map_wppull: thm lazy,
|
blanchet@49990
|
181 |
rel_cong: thm lazy,
|
blanchet@49990
|
182 |
rel_mono: thm lazy,
|
blanchet@49990
|
183 |
rel_Id: thm lazy,
|
blanchet@49990
|
184 |
rel_Gr: thm lazy,
|
blanchet@49990
|
185 |
rel_converse: thm lazy,
|
blanchet@49990
|
186 |
rel_O: thm lazy,
|
blanchet@49990
|
187 |
set_natural': thm lazy list
|
blanchet@49990
|
188 |
};
|
blanchet@49990
|
189 |
|
blanchet@49990
|
190 |
fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero
|
blanchet@49990
|
191 |
collect_set_natural in_cong in_mono in_rel map_comp' map_id' map_wppull
|
blanchet@49990
|
192 |
rel_cong rel_mono rel_Id rel_Gr rel_converse rel_O set_natural' = {
|
blanchet@49990
|
193 |
bd_Card_order = bd_Card_order,
|
blanchet@49990
|
194 |
bd_Cinfinite = bd_Cinfinite,
|
blanchet@49990
|
195 |
bd_Cnotzero = bd_Cnotzero,
|
blanchet@49990
|
196 |
collect_set_natural = collect_set_natural,
|
blanchet@49990
|
197 |
in_cong = in_cong,
|
blanchet@49990
|
198 |
in_mono = in_mono,
|
blanchet@49990
|
199 |
in_rel = in_rel,
|
blanchet@49990
|
200 |
map_comp' = map_comp',
|
blanchet@49990
|
201 |
map_id' = map_id',
|
blanchet@49990
|
202 |
map_wppull = map_wppull,
|
blanchet@49990
|
203 |
rel_cong = rel_cong,
|
blanchet@49990
|
204 |
rel_mono = rel_mono,
|
blanchet@49990
|
205 |
rel_Id = rel_Id,
|
blanchet@49990
|
206 |
rel_Gr = rel_Gr,
|
blanchet@49990
|
207 |
rel_converse = rel_converse,
|
blanchet@49990
|
208 |
rel_O = rel_O,
|
blanchet@49990
|
209 |
set_natural' = set_natural'};
|
blanchet@49990
|
210 |
|
blanchet@49990
|
211 |
fun map_facts f {
|
blanchet@49990
|
212 |
bd_Card_order,
|
blanchet@49990
|
213 |
bd_Cinfinite,
|
blanchet@49990
|
214 |
bd_Cnotzero,
|
blanchet@49990
|
215 |
collect_set_natural,
|
blanchet@49990
|
216 |
in_cong,
|
blanchet@49990
|
217 |
in_mono,
|
blanchet@49990
|
218 |
in_rel,
|
blanchet@49990
|
219 |
map_comp',
|
blanchet@49990
|
220 |
map_id',
|
blanchet@49990
|
221 |
map_wppull,
|
blanchet@49990
|
222 |
rel_cong,
|
blanchet@49990
|
223 |
rel_mono,
|
blanchet@49990
|
224 |
rel_Id,
|
blanchet@49990
|
225 |
rel_Gr,
|
blanchet@49990
|
226 |
rel_converse,
|
blanchet@49990
|
227 |
rel_O,
|
blanchet@49990
|
228 |
set_natural'} =
|
blanchet@49990
|
229 |
{bd_Card_order = f bd_Card_order,
|
blanchet@49990
|
230 |
bd_Cinfinite = f bd_Cinfinite,
|
blanchet@49990
|
231 |
bd_Cnotzero = f bd_Cnotzero,
|
blanchet@49990
|
232 |
collect_set_natural = Lazy.map f collect_set_natural,
|
blanchet@49990
|
233 |
in_cong = Lazy.map f in_cong,
|
blanchet@49990
|
234 |
in_mono = Lazy.map f in_mono,
|
blanchet@49990
|
235 |
in_rel = Lazy.map f in_rel,
|
blanchet@49990
|
236 |
map_comp' = Lazy.map f map_comp',
|
blanchet@49990
|
237 |
map_id' = Lazy.map f map_id',
|
blanchet@49990
|
238 |
map_wppull = Lazy.map f map_wppull,
|
blanchet@49990
|
239 |
rel_cong = Lazy.map f rel_cong,
|
blanchet@49990
|
240 |
rel_mono = Lazy.map f rel_mono,
|
blanchet@49990
|
241 |
rel_Id = Lazy.map f rel_Id,
|
blanchet@49990
|
242 |
rel_Gr = Lazy.map f rel_Gr,
|
blanchet@49990
|
243 |
rel_converse = Lazy.map f rel_converse,
|
blanchet@49990
|
244 |
rel_O = Lazy.map f rel_O,
|
blanchet@49990
|
245 |
set_natural' = map (Lazy.map f) set_natural'};
|
blanchet@49990
|
246 |
|
blanchet@49990
|
247 |
val morph_facts = map_facts o Morphism.thm;
|
blanchet@49990
|
248 |
|
blanchet@49990
|
249 |
type nonemptiness_witness = {
|
blanchet@49990
|
250 |
I: int list,
|
blanchet@49990
|
251 |
wit: term,
|
blanchet@49990
|
252 |
prop: thm list
|
blanchet@49990
|
253 |
};
|
blanchet@49990
|
254 |
|
blanchet@49990
|
255 |
fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
|
blanchet@49990
|
256 |
fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
|
blanchet@49990
|
257 |
fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
|
blanchet@49990
|
258 |
|
blanchet@49990
|
259 |
datatype BNF = BNF of {
|
blanchet@49990
|
260 |
name: binding,
|
blanchet@49990
|
261 |
T: typ,
|
blanchet@49990
|
262 |
live: int,
|
blanchet@49990
|
263 |
lives: typ list, (*source type variables of map, only for composition*)
|
blanchet@49990
|
264 |
lives': typ list, (*target type variables of map, only for composition*)
|
blanchet@49990
|
265 |
dead: int,
|
blanchet@49990
|
266 |
deads: typ list, (*only for composition*)
|
blanchet@49990
|
267 |
map: term,
|
blanchet@49990
|
268 |
sets: term list,
|
blanchet@49990
|
269 |
bd: term,
|
blanchet@49990
|
270 |
axioms: axioms,
|
blanchet@49990
|
271 |
defs: defs,
|
blanchet@49990
|
272 |
facts: facts,
|
blanchet@49990
|
273 |
nwits: int,
|
blanchet@49990
|
274 |
wits: nonemptiness_witness list,
|
blanchet@49990
|
275 |
rel: term,
|
blanchet@49990
|
276 |
pred: term
|
blanchet@49990
|
277 |
};
|
blanchet@49990
|
278 |
|
blanchet@49990
|
279 |
(* getters *)
|
blanchet@49990
|
280 |
|
blanchet@49990
|
281 |
fun rep_bnf (BNF bnf) = bnf;
|
blanchet@49990
|
282 |
val name_of_bnf = #name o rep_bnf;
|
blanchet@49990
|
283 |
val T_of_bnf = #T o rep_bnf;
|
blanchet@49990
|
284 |
fun mk_T_of_bnf Ds Ts bnf =
|
blanchet@49990
|
285 |
let val bnf_rep = rep_bnf bnf
|
blanchet@49990
|
286 |
in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
|
blanchet@49990
|
287 |
val live_of_bnf = #live o rep_bnf;
|
blanchet@49990
|
288 |
val lives_of_bnf = #lives o rep_bnf;
|
blanchet@49990
|
289 |
val dead_of_bnf = #dead o rep_bnf;
|
blanchet@49990
|
290 |
val deads_of_bnf = #deads o rep_bnf;
|
blanchet@49990
|
291 |
val axioms_of_bnf = #axioms o rep_bnf;
|
blanchet@49990
|
292 |
val facts_of_bnf = #facts o rep_bnf;
|
blanchet@49990
|
293 |
val nwits_of_bnf = #nwits o rep_bnf;
|
blanchet@49990
|
294 |
val wits_of_bnf = #wits o rep_bnf;
|
blanchet@49990
|
295 |
|
blanchet@49990
|
296 |
(*terms*)
|
blanchet@49990
|
297 |
val map_of_bnf = #map o rep_bnf;
|
blanchet@49990
|
298 |
val sets_of_bnf = #sets o rep_bnf;
|
blanchet@49990
|
299 |
fun mk_map_of_bnf Ds Ts Us bnf =
|
blanchet@49990
|
300 |
let val bnf_rep = rep_bnf bnf;
|
blanchet@49990
|
301 |
in
|
blanchet@49990
|
302 |
Term.subst_atomic_types
|
blanchet@49990
|
303 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
|
blanchet@49990
|
304 |
end;
|
blanchet@49990
|
305 |
fun mk_sets_of_bnf Dss Tss bnf =
|
blanchet@49990
|
306 |
let val bnf_rep = rep_bnf bnf;
|
blanchet@49990
|
307 |
in
|
blanchet@49990
|
308 |
map2 (fn (Ds, Ts) => Term.subst_atomic_types
|
blanchet@49990
|
309 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
|
blanchet@49990
|
310 |
end;
|
blanchet@49990
|
311 |
val bd_of_bnf = #bd o rep_bnf;
|
blanchet@49990
|
312 |
fun mk_bd_of_bnf Ds Ts bnf =
|
blanchet@49990
|
313 |
let val bnf_rep = rep_bnf bnf;
|
blanchet@49990
|
314 |
in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
|
blanchet@49990
|
315 |
fun mk_wits_of_bnf Dss Tss bnf =
|
blanchet@49990
|
316 |
let
|
blanchet@49990
|
317 |
val bnf_rep = rep_bnf bnf;
|
blanchet@49990
|
318 |
val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
|
blanchet@49990
|
319 |
in
|
blanchet@49990
|
320 |
map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
|
blanchet@49990
|
321 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
|
blanchet@49990
|
322 |
end;
|
blanchet@49990
|
323 |
val rel_of_bnf = #rel o rep_bnf;
|
blanchet@49990
|
324 |
fun mk_rel_of_bnf Ds Ts Us bnf =
|
blanchet@49990
|
325 |
let val bnf_rep = rep_bnf bnf;
|
blanchet@49990
|
326 |
in
|
blanchet@49990
|
327 |
Term.subst_atomic_types
|
blanchet@49990
|
328 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
|
blanchet@49990
|
329 |
end;
|
blanchet@49990
|
330 |
val pred_of_bnf = #pred o rep_bnf;
|
blanchet@49990
|
331 |
fun mk_pred_of_bnf Ds Ts Us bnf =
|
blanchet@49990
|
332 |
let val bnf_rep = rep_bnf bnf;
|
blanchet@49990
|
333 |
in
|
blanchet@49990
|
334 |
Term.subst_atomic_types
|
blanchet@49990
|
335 |
((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#pred bnf_rep)
|
blanchet@49990
|
336 |
end;
|
blanchet@49990
|
337 |
|
blanchet@49990
|
338 |
(*thms*)
|
blanchet@49990
|
339 |
val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
|
blanchet@49990
|
340 |
val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
|
blanchet@49990
|
341 |
val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
|
blanchet@49990
|
342 |
val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
|
blanchet@49990
|
343 |
val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
|
blanchet@49990
|
344 |
val collect_set_natural_of_bnf = Lazy.force o #collect_set_natural o #facts o rep_bnf;
|
blanchet@49990
|
345 |
val in_bd_of_bnf = #in_bd o #axioms o rep_bnf;
|
blanchet@49990
|
346 |
val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
|
blanchet@49990
|
347 |
val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
|
blanchet@49990
|
348 |
val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
|
blanchet@49990
|
349 |
val map_def_of_bnf = #map_def o #defs o rep_bnf;
|
blanchet@49990
|
350 |
val map_id_of_bnf = #map_id o #axioms o rep_bnf;
|
blanchet@49990
|
351 |
val map_id'_of_bnf = Lazy.force o #map_id' o #facts o rep_bnf;
|
blanchet@49990
|
352 |
val map_comp_of_bnf = #map_comp o #axioms o rep_bnf;
|
blanchet@49990
|
353 |
val map_comp'_of_bnf = Lazy.force o #map_comp' o #facts o rep_bnf;
|
blanchet@49990
|
354 |
val map_cong_of_bnf = #map_cong o #axioms o rep_bnf;
|
blanchet@49990
|
355 |
val map_wppull_of_bnf = Lazy.force o #map_wppull o #facts o rep_bnf;
|
blanchet@49990
|
356 |
val map_wpull_of_bnf = #map_wpull o #axioms o rep_bnf;
|
blanchet@49990
|
357 |
val pred_def_of_bnf = #pred_def o #defs o rep_bnf;
|
blanchet@49990
|
358 |
val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
|
blanchet@49990
|
359 |
val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
|
blanchet@49990
|
360 |
val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
|
blanchet@49990
|
361 |
val rel_Id_of_bnf = Lazy.force o #rel_Id o #facts o rep_bnf;
|
blanchet@49990
|
362 |
val rel_Gr_of_bnf = Lazy.force o #rel_Gr o #facts o rep_bnf;
|
blanchet@49990
|
363 |
val rel_converse_of_bnf = Lazy.force o #rel_converse o #facts o rep_bnf;
|
blanchet@49990
|
364 |
val rel_O_of_bnf = Lazy.force o #rel_O o #facts o rep_bnf;
|
blanchet@49990
|
365 |
val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
|
blanchet@49990
|
366 |
val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
|
blanchet@49990
|
367 |
val set_natural_of_bnf = #set_natural o #axioms o rep_bnf;
|
blanchet@49990
|
368 |
val set_natural'_of_bnf = map Lazy.force o #set_natural' o #facts o rep_bnf;
|
blanchet@49990
|
369 |
val wit_thms_of_bnf = maps #prop o wits_of_bnf;
|
blanchet@49990
|
370 |
val wit_thmss_of_bnf = map #prop o wits_of_bnf;
|
blanchet@49990
|
371 |
|
blanchet@49990
|
372 |
fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred =
|
blanchet@49990
|
373 |
BNF {name = name, T = T,
|
blanchet@49990
|
374 |
live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
|
blanchet@49990
|
375 |
map = map, sets = sets, bd = bd,
|
blanchet@49990
|
376 |
axioms = axioms, defs = defs, facts = facts,
|
blanchet@49990
|
377 |
nwits = length wits, wits = wits, rel = rel, pred = pred};
|
blanchet@49990
|
378 |
|
blanchet@49990
|
379 |
fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
|
blanchet@49990
|
380 |
dead = dead, deads = deads, map = map, sets = sets, bd = bd,
|
blanchet@49990
|
381 |
axioms = axioms, defs = defs, facts = facts,
|
blanchet@49990
|
382 |
nwits = nwits, wits = wits, rel = rel, pred = pred}) =
|
blanchet@49990
|
383 |
BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
|
blanchet@49990
|
384 |
live = live, lives = List.map (Morphism.typ phi) lives,
|
blanchet@49990
|
385 |
lives' = List.map (Morphism.typ phi) lives',
|
blanchet@49990
|
386 |
dead = dead, deads = List.map (Morphism.typ phi) deads,
|
blanchet@49990
|
387 |
map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
|
blanchet@49990
|
388 |
bd = Morphism.term phi bd,
|
blanchet@49990
|
389 |
axioms = morph_axioms phi axioms,
|
blanchet@49990
|
390 |
defs = morph_defs phi defs,
|
blanchet@49990
|
391 |
facts = morph_facts phi facts,
|
blanchet@49990
|
392 |
nwits = nwits,
|
blanchet@49990
|
393 |
wits = List.map (morph_witness phi) wits,
|
blanchet@49990
|
394 |
rel = Morphism.term phi rel, pred = Morphism.term phi pred};
|
blanchet@49990
|
395 |
|
blanchet@49990
|
396 |
fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
|
blanchet@49990
|
397 |
BNF {T = T2, live = live2, dead = dead2, ...}) =
|
blanchet@49990
|
398 |
Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
|
blanchet@49990
|
399 |
|
blanchet@49990
|
400 |
structure Data = Generic_Data
|
blanchet@49990
|
401 |
(
|
blanchet@49990
|
402 |
type T = BNF Symtab.table;
|
blanchet@49990
|
403 |
val empty = Symtab.empty;
|
blanchet@49990
|
404 |
val extend = I;
|
blanchet@49990
|
405 |
val merge = Symtab.merge (eq_bnf);
|
blanchet@49990
|
406 |
);
|
blanchet@49990
|
407 |
|
blanchet@49990
|
408 |
val bnf_of = Symtab.lookup o Data.get o Context.Proof;
|
blanchet@49990
|
409 |
|
blanchet@49990
|
410 |
|
blanchet@49990
|
411 |
|
blanchet@49990
|
412 |
(* Utilities *)
|
blanchet@49990
|
413 |
|
blanchet@49990
|
414 |
fun normalize_set insts instA set =
|
blanchet@49990
|
415 |
let
|
blanchet@49990
|
416 |
val (T, T') = dest_funT (fastype_of set);
|
blanchet@49990
|
417 |
val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
|
blanchet@49990
|
418 |
val params = Term.add_tvar_namesT T [];
|
blanchet@49990
|
419 |
in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
|
blanchet@49990
|
420 |
|
blanchet@49990
|
421 |
fun normalize_rel ctxt instTs instA instB rel =
|
blanchet@49990
|
422 |
let
|
blanchet@49990
|
423 |
val thy = Proof_Context.theory_of ctxt;
|
blanchet@49990
|
424 |
val tyenv =
|
blanchet@49990
|
425 |
Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_relT (instA, instB)))
|
blanchet@49990
|
426 |
Vartab.empty;
|
blanchet@49990
|
427 |
in Envir.subst_term (tyenv, Vartab.empty) rel end;
|
blanchet@49990
|
428 |
|
blanchet@49990
|
429 |
fun normalize_pred ctxt instTs instA instB pred =
|
blanchet@49990
|
430 |
let
|
blanchet@49990
|
431 |
val thy = Proof_Context.theory_of ctxt;
|
blanchet@49990
|
432 |
val tyenv =
|
blanchet@49990
|
433 |
Sign.typ_match thy (fastype_of pred,
|
blanchet@49990
|
434 |
Library.foldr (op -->) (instTs, instA --> instB --> HOLogic.boolT)) Vartab.empty;
|
blanchet@49990
|
435 |
in Envir.subst_term (tyenv, Vartab.empty) pred end;
|
blanchet@49990
|
436 |
|
blanchet@49990
|
437 |
fun normalize_wit insts CA As wit =
|
blanchet@49990
|
438 |
let
|
blanchet@49990
|
439 |
fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
|
blanchet@49990
|
440 |
if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
|
blanchet@49990
|
441 |
| strip_param x = x;
|
blanchet@49990
|
442 |
val (Ts, T) = strip_param ([], fastype_of wit);
|
blanchet@49990
|
443 |
val subst = Term.add_tvar_namesT T [] ~~ insts;
|
blanchet@49990
|
444 |
fun find y = find_index (fn x => x = y) As;
|
blanchet@49990
|
445 |
in
|
blanchet@49990
|
446 |
(map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
|
blanchet@49990
|
447 |
end;
|
blanchet@49990
|
448 |
|
blanchet@49990
|
449 |
fun minimize_wits wits =
|
blanchet@49990
|
450 |
let
|
blanchet@49990
|
451 |
fun minimize done [] = done
|
traytel@50118
|
452 |
| minimize done ((I, wit) :: todo) =
|
blanchet@49990
|
453 |
if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
|
blanchet@49990
|
454 |
then minimize done todo
|
blanchet@49990
|
455 |
else minimize ((I, wit) :: done) todo;
|
blanchet@49990
|
456 |
in minimize [] wits end;
|
blanchet@49990
|
457 |
|
blanchet@49990
|
458 |
fun unfold_defs_tac lthy defs mk_tac context = Local_Defs.unfold_tac lthy defs THEN mk_tac context;
|
blanchet@49990
|
459 |
|
blanchet@49990
|
460 |
|
blanchet@49990
|
461 |
|
blanchet@49990
|
462 |
(* Names *)
|
blanchet@49990
|
463 |
|
blanchet@49990
|
464 |
fun nonzero_string_of_int 0 = ""
|
blanchet@49990
|
465 |
| nonzero_string_of_int n = string_of_int n;
|
blanchet@49990
|
466 |
|
blanchet@49990
|
467 |
val mapN = "map";
|
blanchet@49990
|
468 |
val setN = "set";
|
blanchet@49990
|
469 |
fun mk_setN i = setN ^ nonzero_string_of_int i;
|
blanchet@49990
|
470 |
val bdN = "bd";
|
blanchet@49990
|
471 |
val witN = "wit";
|
blanchet@49990
|
472 |
fun mk_witN i = witN ^ nonzero_string_of_int i;
|
blanchet@49990
|
473 |
val relN = "rel";
|
blanchet@49990
|
474 |
val predN = "pred";
|
blanchet@49990
|
475 |
val rel_unfoldN = relN ^ "_unfold";
|
blanchet@49990
|
476 |
val pred_unfoldN = predN ^ "_unfold";
|
blanchet@49990
|
477 |
|
blanchet@49990
|
478 |
val bd_card_orderN = "bd_card_order";
|
blanchet@49990
|
479 |
val bd_cinfiniteN = "bd_cinfinite";
|
blanchet@49990
|
480 |
val bd_Card_orderN = "bd_Card_order";
|
blanchet@49990
|
481 |
val bd_CinfiniteN = "bd_Cinfinite";
|
blanchet@49990
|
482 |
val bd_CnotzeroN = "bd_Cnotzero";
|
blanchet@49990
|
483 |
val collect_set_naturalN = "collect_set_natural";
|
blanchet@49990
|
484 |
val in_bdN = "in_bd";
|
blanchet@49990
|
485 |
val in_congN = "in_cong";
|
blanchet@49990
|
486 |
val in_monoN = "in_mono";
|
blanchet@49990
|
487 |
val in_relN = "in_rel";
|
blanchet@49990
|
488 |
val map_idN = "map_id";
|
blanchet@49990
|
489 |
val map_id'N = "map_id'";
|
blanchet@49990
|
490 |
val map_compN = "map_comp";
|
blanchet@49990
|
491 |
val map_comp'N = "map_comp'";
|
blanchet@49990
|
492 |
val map_congN = "map_cong";
|
blanchet@49990
|
493 |
val map_wppullN = "map_wppull";
|
blanchet@49990
|
494 |
val map_wpullN = "map_wpull";
|
blanchet@49990
|
495 |
val rel_congN = "rel_cong";
|
blanchet@49990
|
496 |
val rel_IdN = "rel_Id";
|
blanchet@49990
|
497 |
val rel_GrN = "rel_Gr";
|
blanchet@49990
|
498 |
val rel_converseN = "rel_converse";
|
blanchet@49990
|
499 |
val rel_ON = "rel_comp";
|
blanchet@49990
|
500 |
val set_naturalN = "set_natural";
|
blanchet@49990
|
501 |
val set_natural'N = "set_natural'";
|
blanchet@49990
|
502 |
val set_bdN = "set_bd";
|
blanchet@49990
|
503 |
|
blanchet@49990
|
504 |
datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
|
blanchet@49990
|
505 |
|
blanchet@49990
|
506 |
datatype fact_policy =
|
blanchet@49990
|
507 |
Derive_Some_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms;
|
blanchet@49990
|
508 |
|
blanchet@49990
|
509 |
val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
|
blanchet@49990
|
510 |
|
blanchet@49990
|
511 |
fun user_policy ctxt =
|
blanchet@50031
|
512 |
if Config.get ctxt bnf_note_all then Note_All_Facts_and_Axioms else Derive_All_Facts_Note_Most;
|
blanchet@49990
|
513 |
|
blanchet@49990
|
514 |
val smart_max_inline_size = 25; (*FUDGE*)
|
blanchet@49990
|
515 |
|
blanchet@49990
|
516 |
val no_def = Drule.reflexive_thm;
|
blanchet@49990
|
517 |
val no_fact = refl;
|
blanchet@49990
|
518 |
|
blanchet@49990
|
519 |
fun is_reflexive th =
|
blanchet@49990
|
520 |
let val t = Thm.prop_of th;
|
blanchet@49990
|
521 |
in
|
blanchet@49990
|
522 |
op aconv (Logic.dest_equals t)
|
blanchet@49990
|
523 |
handle TERM _ => op aconv (HOLogic.dest_eq (HOLogic.dest_Trueprop t))
|
blanchet@49990
|
524 |
handle TERM _ => false
|
blanchet@49990
|
525 |
end;
|
blanchet@49990
|
526 |
|
blanchet@49990
|
527 |
val filter_refl = filter_out is_reflexive;
|
blanchet@49990
|
528 |
|
blanchet@49990
|
529 |
|
blanchet@49990
|
530 |
|
blanchet@49990
|
531 |
(* Define new BNFs *)
|
blanchet@49990
|
532 |
|
blanchet@50034
|
533 |
fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt
|
blanchet@49990
|
534 |
((((raw_b, raw_map), raw_sets), raw_bd_Abs), raw_wits) no_defs_lthy =
|
blanchet@49990
|
535 |
let
|
blanchet@49990
|
536 |
val fact_policy = mk_fact_policy no_defs_lthy;
|
blanchet@49990
|
537 |
val b = qualify raw_b;
|
blanchet@49990
|
538 |
val live = length raw_sets;
|
blanchet@49990
|
539 |
val nwits = length raw_wits;
|
blanchet@49990
|
540 |
|
blanchet@49990
|
541 |
val map_rhs = prep_term no_defs_lthy raw_map;
|
blanchet@49990
|
542 |
val set_rhss = map (prep_term no_defs_lthy) raw_sets;
|
blanchet@49990
|
543 |
val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
|
blanchet@49990
|
544 |
Abs (_, T, t) => (T, t)
|
blanchet@49990
|
545 |
| _ => error "Bad bound constant");
|
blanchet@49990
|
546 |
val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
|
blanchet@49990
|
547 |
|
blanchet@49990
|
548 |
val map_bind_def = (fn () => Binding.suffix_name ("_" ^ mapN) b, map_rhs);
|
blanchet@49990
|
549 |
val set_binds_defs =
|
blanchet@49990
|
550 |
let
|
blanchet@49990
|
551 |
val bs = if live = 1 then [fn () => Binding.suffix_name ("_" ^ setN) b]
|
blanchet@49990
|
552 |
else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_setN i) b) (1 upto live)
|
blanchet@49990
|
553 |
in map2 pair bs set_rhss end;
|
blanchet@49990
|
554 |
val bd_bind_def = (fn () => Binding.suffix_name ("_" ^ bdN) b, bd_rhs);
|
blanchet@49990
|
555 |
val wit_binds_defs =
|
blanchet@49990
|
556 |
let
|
blanchet@49990
|
557 |
val bs = if nwits = 1 then [fn () => Binding.suffix_name ("_" ^ witN) b]
|
blanchet@49990
|
558 |
else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_witN i) b) (1 upto nwits);
|
blanchet@49990
|
559 |
in map2 pair bs wit_rhss end;
|
blanchet@49990
|
560 |
|
blanchet@50036
|
561 |
fun maybe_define needed_for_extra_facts (b, rhs) lthy =
|
blanchet@49990
|
562 |
let
|
blanchet@49990
|
563 |
val inline =
|
blanchet@50036
|
564 |
(not needed_for_extra_facts orelse fact_policy = Derive_Some_Facts) andalso
|
blanchet@49990
|
565 |
(case const_policy of
|
blanchet@49990
|
566 |
Dont_Inline => false
|
blanchet@49990
|
567 |
| Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
|
blanchet@49990
|
568 |
| Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
|
blanchet@49990
|
569 |
| Do_Inline => true)
|
blanchet@49990
|
570 |
in
|
blanchet@49990
|
571 |
if inline then
|
blanchet@49990
|
572 |
((rhs, no_def), lthy)
|
blanchet@49990
|
573 |
else
|
blanchet@49990
|
574 |
let val b = b () in
|
blanchet@49990
|
575 |
apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
|
blanchet@49990
|
576 |
lthy)
|
blanchet@49990
|
577 |
end
|
blanchet@49990
|
578 |
end;
|
blanchet@49990
|
579 |
fun maybe_restore lthy0 lthy = lthy |> not (pointer_eq (lthy0, lthy)) ? Local_Theory.restore;
|
blanchet@49990
|
580 |
|
blanchet@49990
|
581 |
val (((((bnf_map_term, raw_map_def),
|
blanchet@49990
|
582 |
(bnf_set_terms, raw_set_defs)),
|
blanchet@49990
|
583 |
(bnf_bd_term, raw_bd_def)),
|
blanchet@49990
|
584 |
(bnf_wit_terms, raw_wit_defs)), (lthy', lthy)) =
|
blanchet@49990
|
585 |
no_defs_lthy
|
blanchet@49990
|
586 |
|> maybe_define false map_bind_def
|
blanchet@49990
|
587 |
||>> apfst split_list o fold_map (maybe_define false) set_binds_defs
|
blanchet@49990
|
588 |
||>> maybe_define false bd_bind_def
|
blanchet@49990
|
589 |
||>> apfst split_list o fold_map (maybe_define false) wit_binds_defs
|
blanchet@49990
|
590 |
||> `(maybe_restore no_defs_lthy);
|
blanchet@49990
|
591 |
|
blanchet@49990
|
592 |
(*transforms defined frees into consts (and more)*)
|
blanchet@49990
|
593 |
val phi = Proof_Context.export_morphism lthy lthy';
|
blanchet@49990
|
594 |
|
blanchet@49990
|
595 |
val bnf_map_def = Morphism.thm phi raw_map_def;
|
blanchet@49990
|
596 |
val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
|
blanchet@49990
|
597 |
val bnf_bd_def = Morphism.thm phi raw_bd_def;
|
blanchet@49990
|
598 |
val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
|
blanchet@49990
|
599 |
|
blanchet@49990
|
600 |
val one_step_defs = filter_refl (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs);
|
blanchet@49990
|
601 |
|
blanchet@49990
|
602 |
val _ = case map_filter (try dest_Free)
|
blanchet@49990
|
603 |
(bnf_map_term :: bnf_set_terms @ [bnf_bd_term] @ bnf_wit_terms) of
|
blanchet@49990
|
604 |
[] => ()
|
blanchet@49990
|
605 |
| frees => Proof_Display.print_consts true lthy (K false) frees;
|
blanchet@49990
|
606 |
|
blanchet@49990
|
607 |
val bnf_map = Morphism.term phi bnf_map_term;
|
blanchet@49990
|
608 |
|
blanchet@49990
|
609 |
fun iter_split ((Ts, T1), T2) = if length Ts < live then error "Bad map function"
|
blanchet@49990
|
610 |
else if length Ts = live then ((Ts, T1), T2)
|
blanchet@49990
|
611 |
else iter_split (split_last Ts, T1 --> T2);
|
blanchet@49990
|
612 |
|
blanchet@49990
|
613 |
(*TODO: handle errors*)
|
blanchet@49990
|
614 |
(*simple shape analysis of a map function*)
|
blanchet@49990
|
615 |
val (((alphas, betas), CA), _) =
|
blanchet@49990
|
616 |
apfst (apfst (map_split dest_funT))
|
blanchet@49990
|
617 |
(iter_split (apfst split_last (strip_type (fastype_of bnf_map))));
|
blanchet@49990
|
618 |
|
blanchet@49990
|
619 |
val CA_params = map TVar (Term.add_tvarsT CA []);
|
blanchet@49990
|
620 |
|
blanchet@49990
|
621 |
val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
|
blanchet@49990
|
622 |
val bdT = Morphism.typ phi bd_rhsT;
|
blanchet@49990
|
623 |
val bnf_bd =
|
blanchet@49990
|
624 |
Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
|
blanchet@49990
|
625 |
val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
|
blanchet@49990
|
626 |
|
blanchet@49990
|
627 |
(*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
|
blanchet@49990
|
628 |
val deads = (case Ds_opt of
|
blanchet@49990
|
629 |
NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
|
blanchet@49990
|
630 |
| SOME Ds => map (Morphism.typ phi) Ds);
|
blanchet@49990
|
631 |
val dead = length deads;
|
blanchet@49990
|
632 |
|
blanchet@49990
|
633 |
(*FIXME: check DUP here, not in after_qed*)
|
blanchet@49990
|
634 |
val key = Name_Space.full_name Name_Space.default_naming b;
|
blanchet@49990
|
635 |
|
blanchet@49990
|
636 |
(*TODO: further checks of type of bnf_map*)
|
blanchet@49990
|
637 |
(*TODO: check types of bnf_sets*)
|
blanchet@49990
|
638 |
(*TODO: check type of bnf_bd*)
|
blanchet@49990
|
639 |
|
blanchet@49990
|
640 |
val ((((((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), domTs), ranTs), ranTs'), ranTs''),
|
blanchet@49990
|
641 |
(Ts, T)) = lthy'
|
blanchet@49990
|
642 |
|> mk_TFrees live
|
blanchet@49990
|
643 |
||>> mk_TFrees live
|
blanchet@49990
|
644 |
||>> mk_TFrees live
|
blanchet@49990
|
645 |
||>> mk_TFrees dead
|
blanchet@49990
|
646 |
||>> mk_TFrees live
|
blanchet@49990
|
647 |
||>> mk_TFrees live
|
blanchet@49990
|
648 |
||>> mk_TFrees live
|
blanchet@49990
|
649 |
||>> mk_TFrees live
|
blanchet@49990
|
650 |
||>> mk_TFrees live
|
blanchet@49990
|
651 |
||>> mk_TFrees live
|
blanchet@49990
|
652 |
||> fst o mk_TFrees 1
|
blanchet@49990
|
653 |
||> the_single
|
blanchet@49990
|
654 |
||> `(replicate live);
|
blanchet@49990
|
655 |
|
blanchet@49990
|
656 |
fun mk_bnf_map As' Bs' =
|
blanchet@49990
|
657 |
Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
|
blanchet@49990
|
658 |
fun mk_bnf_t As' t =
|
blanchet@49990
|
659 |
Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As')) t;
|
blanchet@49990
|
660 |
fun mk_bnf_T As' T =
|
blanchet@49990
|
661 |
Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As')) T;
|
blanchet@49990
|
662 |
|
blanchet@49990
|
663 |
val (setRTs, RTs) = map_split (`HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Bs');
|
blanchet@49990
|
664 |
val setRTsAsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Cs);
|
blanchet@49990
|
665 |
val setRTsBsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ Cs);
|
blanchet@49990
|
666 |
val setRT's = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ As');
|
blanchet@49990
|
667 |
val self_setRTs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ As');
|
blanchet@49990
|
668 |
val QTs = map2 (fn T => fn U => T --> U --> HOLogic.boolT) As' Bs';
|
blanchet@49990
|
669 |
|
blanchet@49990
|
670 |
val bnf_map_AsAs = mk_bnf_map As' As';
|
blanchet@49990
|
671 |
val bnf_map_AsBs = mk_bnf_map As' Bs';
|
blanchet@49990
|
672 |
val bnf_map_AsCs = mk_bnf_map As' Cs;
|
blanchet@49990
|
673 |
val bnf_map_BsCs = mk_bnf_map Bs' Cs;
|
blanchet@49990
|
674 |
val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
|
blanchet@49990
|
675 |
val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
|
blanchet@49990
|
676 |
val bnf_bd_As = mk_bnf_t As' bnf_bd;
|
blanchet@49990
|
677 |
val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
|
blanchet@49990
|
678 |
val CA' = mk_bnf_T As' CA;
|
blanchet@49990
|
679 |
val CB' = mk_bnf_T Bs' CA;
|
blanchet@49990
|
680 |
val CC' = mk_bnf_T Cs CA;
|
blanchet@49990
|
681 |
val CRs' = mk_bnf_T RTs CA;
|
blanchet@49990
|
682 |
|
blanchet@49990
|
683 |
val ((((((((((((((((((((((((fs, fs_copy), gs), hs), (x, x')), (y, y')), (z, z')), zs), As),
|
blanchet@49990
|
684 |
As_copy), Xs), B1s), B2s), f1s), f2s), e1s), e2s), p1s), p2s), bs),
|
blanchet@49990
|
685 |
(Rs, Rs')), Rs_copy), Ss), (Qs, Qs')), _) = lthy'
|
blanchet@49990
|
686 |
|> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
|
blanchet@49990
|
687 |
||>> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
|
blanchet@49990
|
688 |
||>> mk_Frees "g" (map2 (curry (op -->)) Bs' Cs)
|
blanchet@49990
|
689 |
||>> mk_Frees "h" (map2 (curry (op -->)) As' Ts)
|
blanchet@49990
|
690 |
||>> yield_singleton (apfst (op ~~) oo mk_Frees' "x") CA'
|
blanchet@49990
|
691 |
||>> yield_singleton (apfst (op ~~) oo mk_Frees' "y") CB'
|
blanchet@49990
|
692 |
||>> yield_singleton (apfst (op ~~) oo mk_Frees' "z") CRs'
|
blanchet@49990
|
693 |
||>> mk_Frees "z" As'
|
blanchet@49990
|
694 |
||>> mk_Frees "A" (map HOLogic.mk_setT As')
|
blanchet@49990
|
695 |
||>> mk_Frees "A" (map HOLogic.mk_setT As')
|
blanchet@49990
|
696 |
||>> mk_Frees "A" (map HOLogic.mk_setT domTs)
|
blanchet@49990
|
697 |
||>> mk_Frees "B1" (map HOLogic.mk_setT B1Ts)
|
blanchet@49990
|
698 |
||>> mk_Frees "B2" (map HOLogic.mk_setT B2Ts)
|
blanchet@49990
|
699 |
||>> mk_Frees "f1" (map2 (curry (op -->)) B1Ts ranTs)
|
blanchet@49990
|
700 |
||>> mk_Frees "f2" (map2 (curry (op -->)) B2Ts ranTs)
|
blanchet@49990
|
701 |
||>> mk_Frees "e1" (map2 (curry (op -->)) B1Ts ranTs')
|
blanchet@49990
|
702 |
||>> mk_Frees "e2" (map2 (curry (op -->)) B2Ts ranTs'')
|
blanchet@49990
|
703 |
||>> mk_Frees "p1" (map2 (curry (op -->)) domTs B1Ts)
|
blanchet@49990
|
704 |
||>> mk_Frees "p2" (map2 (curry (op -->)) domTs B2Ts)
|
blanchet@49990
|
705 |
||>> mk_Frees "b" As'
|
blanchet@49990
|
706 |
||>> mk_Frees' "R" setRTs
|
blanchet@49990
|
707 |
||>> mk_Frees "R" setRTs
|
blanchet@49990
|
708 |
||>> mk_Frees "S" setRTsBsCs
|
blanchet@49990
|
709 |
||>> mk_Frees' "Q" QTs;
|
blanchet@49990
|
710 |
|
blanchet@49990
|
711 |
val goal_map_id =
|
blanchet@49990
|
712 |
let
|
blanchet@50033
|
713 |
val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As');
|
blanchet@49990
|
714 |
in
|
blanchet@49990
|
715 |
HOLogic.mk_Trueprop
|
blanchet@49990
|
716 |
(HOLogic.mk_eq (bnf_map_app_id, HOLogic.id_const CA'))
|
blanchet@49990
|
717 |
end;
|
blanchet@49990
|
718 |
|
blanchet@49990
|
719 |
val goal_map_comp =
|
blanchet@49990
|
720 |
let
|
blanchet@50033
|
721 |
val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
|
blanchet@49990
|
722 |
val comp_bnf_map_app = HOLogic.mk_comp
|
blanchet@49990
|
723 |
(Term.list_comb (bnf_map_BsCs, gs),
|
blanchet@49990
|
724 |
Term.list_comb (bnf_map_AsBs, fs));
|
blanchet@49990
|
725 |
in
|
blanchet@50138
|
726 |
fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
|
blanchet@49990
|
727 |
end;
|
blanchet@49990
|
728 |
|
blanchet@49990
|
729 |
val goal_map_cong =
|
blanchet@49990
|
730 |
let
|
blanchet@49990
|
731 |
fun mk_prem z set f f_copy =
|
blanchet@49990
|
732 |
Logic.all z (Logic.mk_implies
|
blanchet@49990
|
733 |
(HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
|
blanchet@50138
|
734 |
mk_Trueprop_eq (f $ z, f_copy $ z)));
|
blanchet@49990
|
735 |
val prems = map4 mk_prem zs bnf_sets_As fs fs_copy;
|
blanchet@49990
|
736 |
val eq = HOLogic.mk_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
|
blanchet@49990
|
737 |
Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
|
blanchet@49990
|
738 |
in
|
blanchet@49990
|
739 |
fold_rev Logic.all (x :: fs @ fs_copy)
|
blanchet@49990
|
740 |
(Logic.list_implies (prems, HOLogic.mk_Trueprop eq))
|
blanchet@49990
|
741 |
end;
|
blanchet@49990
|
742 |
|
blanchet@49990
|
743 |
val goal_set_naturals =
|
blanchet@49990
|
744 |
let
|
blanchet@49990
|
745 |
fun mk_goal setA setB f =
|
blanchet@49990
|
746 |
let
|
blanchet@49990
|
747 |
val set_comp_map =
|
blanchet@49990
|
748 |
HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
|
blanchet@49990
|
749 |
val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
|
blanchet@49990
|
750 |
in
|
blanchet@50138
|
751 |
fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
|
blanchet@49990
|
752 |
end;
|
blanchet@49990
|
753 |
in
|
blanchet@49990
|
754 |
map3 mk_goal bnf_sets_As bnf_sets_Bs fs
|
blanchet@49990
|
755 |
end;
|
blanchet@49990
|
756 |
|
blanchet@49990
|
757 |
val goal_card_order_bd = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
|
blanchet@49990
|
758 |
|
blanchet@49990
|
759 |
val goal_cinfinite_bd = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
|
blanchet@49990
|
760 |
|
blanchet@49990
|
761 |
val goal_set_bds =
|
blanchet@49990
|
762 |
let
|
blanchet@49990
|
763 |
fun mk_goal set =
|
blanchet@49990
|
764 |
Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
|
blanchet@49990
|
765 |
in
|
blanchet@49990
|
766 |
map mk_goal bnf_sets_As
|
blanchet@49990
|
767 |
end;
|
blanchet@49990
|
768 |
|
blanchet@49990
|
769 |
val goal_in_bd =
|
blanchet@49990
|
770 |
let
|
blanchet@49990
|
771 |
val bd = mk_cexp
|
blanchet@49990
|
772 |
(if live = 0 then ctwo
|
blanchet@49990
|
773 |
else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
|
blanchet@49990
|
774 |
bnf_bd_As;
|
blanchet@49990
|
775 |
in
|
blanchet@49990
|
776 |
fold_rev Logic.all As
|
blanchet@49990
|
777 |
(HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd))
|
blanchet@49990
|
778 |
end;
|
blanchet@49990
|
779 |
|
blanchet@49990
|
780 |
val goal_map_wpull =
|
blanchet@49990
|
781 |
let
|
blanchet@49990
|
782 |
val prems = map HOLogic.mk_Trueprop
|
blanchet@49990
|
783 |
(map8 mk_wpull Xs B1s B2s f1s f2s (replicate live NONE) p1s p2s);
|
blanchet@49990
|
784 |
val CX = mk_bnf_T domTs CA;
|
blanchet@49990
|
785 |
val CB1 = mk_bnf_T B1Ts CA;
|
blanchet@49990
|
786 |
val CB2 = mk_bnf_T B2Ts CA;
|
blanchet@49990
|
787 |
val bnf_sets_CX = map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
|
blanchet@49990
|
788 |
val bnf_sets_CB1 = map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
|
blanchet@49990
|
789 |
val bnf_sets_CB2 = map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
|
blanchet@49990
|
790 |
val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
|
blanchet@49990
|
791 |
val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
|
blanchet@49990
|
792 |
val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
|
blanchet@49990
|
793 |
val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
|
blanchet@49990
|
794 |
|
blanchet@49990
|
795 |
val map_wpull = mk_wpull (mk_in Xs bnf_sets_CX CX)
|
blanchet@49990
|
796 |
(mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
|
blanchet@49990
|
797 |
bnf_map_app_f1 bnf_map_app_f2 NONE bnf_map_app_p1 bnf_map_app_p2;
|
blanchet@49990
|
798 |
in
|
blanchet@49990
|
799 |
fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
|
blanchet@49990
|
800 |
(Logic.list_implies (prems, HOLogic.mk_Trueprop map_wpull))
|
blanchet@49990
|
801 |
end;
|
blanchet@49990
|
802 |
|
blanchet@49990
|
803 |
val goals =
|
blanchet@49990
|
804 |
[goal_map_id, goal_map_comp, goal_map_cong] @ goal_set_naturals @
|
blanchet@49990
|
805 |
[goal_card_order_bd, goal_cinfinite_bd] @ goal_set_bds @
|
blanchet@49990
|
806 |
[goal_in_bd, goal_map_wpull];
|
blanchet@49990
|
807 |
|
blanchet@49990
|
808 |
fun mk_wit_goals (I, wit) =
|
blanchet@49990
|
809 |
let
|
blanchet@49990
|
810 |
val xs = map (nth bs) I;
|
blanchet@49990
|
811 |
fun wit_goal i =
|
blanchet@49990
|
812 |
let
|
blanchet@49990
|
813 |
val z = nth zs i;
|
blanchet@49990
|
814 |
val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
|
blanchet@49990
|
815 |
val concl = HOLogic.mk_Trueprop
|
blanchet@49990
|
816 |
(if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
|
blanchet@49990
|
817 |
else @{term False});
|
blanchet@49990
|
818 |
in
|
blanchet@49990
|
819 |
fold_rev Logic.all (z :: xs)
|
blanchet@49990
|
820 |
(Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
|
blanchet@49990
|
821 |
end;
|
blanchet@49990
|
822 |
in
|
blanchet@49990
|
823 |
map wit_goal (0 upto live - 1)
|
blanchet@49990
|
824 |
end;
|
blanchet@49990
|
825 |
|
blanchet@49990
|
826 |
val wit_goalss = map mk_wit_goals bnf_wit_As;
|
blanchet@49990
|
827 |
|
blanchet@49990
|
828 |
fun after_qed thms lthy =
|
blanchet@49990
|
829 |
let
|
blanchet@49990
|
830 |
val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
|
blanchet@49990
|
831 |
|
traytel@50124
|
832 |
val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
|
blanchet@49990
|
833 |
val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
|
blanchet@49990
|
834 |
val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
|
blanchet@49990
|
835 |
|
blanchet@49990
|
836 |
fun mk_lazy f = if fact_policy <> Derive_Some_Facts then Lazy.value (f ()) else Lazy.lazy f;
|
blanchet@49990
|
837 |
|
blanchet@49990
|
838 |
fun mk_collect_set_natural () =
|
blanchet@49990
|
839 |
let
|
blanchet@49990
|
840 |
val defT = mk_bnf_T Ts CA --> HOLogic.mk_setT T;
|
blanchet@49990
|
841 |
val collect_map = HOLogic.mk_comp
|
blanchet@49990
|
842 |
(mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
|
blanchet@49990
|
843 |
Term.list_comb (mk_bnf_map As' Ts, hs));
|
blanchet@49990
|
844 |
val image_collect = mk_collect
|
blanchet@49990
|
845 |
(map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
|
blanchet@49990
|
846 |
defT;
|
blanchet@49990
|
847 |
(*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
|
blanchet@50138
|
848 |
val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
|
blanchet@49990
|
849 |
in
|
blanchet@49990
|
850 |
Skip_Proof.prove lthy [] [] goal
|
blanchet@49990
|
851 |
(fn {context = ctxt, ...} => mk_collect_set_natural_tac ctxt (#set_natural axioms))
|
traytel@50124
|
852 |
|> Thm.close_derivation
|
blanchet@49990
|
853 |
end;
|
blanchet@49990
|
854 |
|
blanchet@49990
|
855 |
val collect_set_natural = mk_lazy mk_collect_set_natural;
|
blanchet@49990
|
856 |
|
blanchet@49990
|
857 |
fun mk_in_mono () =
|
blanchet@49990
|
858 |
let
|
blanchet@49990
|
859 |
val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_subset) As As_copy;
|
blanchet@49990
|
860 |
val goal_in_mono =
|
blanchet@49990
|
861 |
fold_rev Logic.all (As @ As_copy)
|
blanchet@49990
|
862 |
(Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
|
blanchet@49990
|
863 |
(mk_subset (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
|
blanchet@49990
|
864 |
in
|
blanchet@49990
|
865 |
Skip_Proof.prove lthy [] [] goal_in_mono (K (mk_in_mono_tac live))
|
traytel@50124
|
866 |
|> Thm.close_derivation
|
blanchet@49990
|
867 |
end;
|
blanchet@49990
|
868 |
|
blanchet@49990
|
869 |
val in_mono = mk_lazy mk_in_mono;
|
blanchet@49990
|
870 |
|
blanchet@49990
|
871 |
fun mk_in_cong () =
|
blanchet@49990
|
872 |
let
|
blanchet@49990
|
873 |
val prems_cong = map2 (HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) As As_copy;
|
blanchet@49990
|
874 |
val goal_in_cong =
|
blanchet@49990
|
875 |
fold_rev Logic.all (As @ As_copy)
|
blanchet@49990
|
876 |
(Logic.list_implies (prems_cong, HOLogic.mk_Trueprop
|
blanchet@49990
|
877 |
(HOLogic.mk_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA'))));
|
blanchet@49990
|
878 |
in
|
blanchet@49990
|
879 |
Skip_Proof.prove lthy [] [] goal_in_cong (K ((TRY o hyp_subst_tac THEN' rtac refl) 1))
|
traytel@50124
|
880 |
|> Thm.close_derivation
|
blanchet@49990
|
881 |
end;
|
blanchet@49990
|
882 |
|
blanchet@49990
|
883 |
val in_cong = mk_lazy mk_in_cong;
|
blanchet@49990
|
884 |
|
blanchet@49990
|
885 |
val map_id' = mk_lazy (fn () => mk_id' (#map_id axioms));
|
blanchet@49990
|
886 |
val map_comp' = mk_lazy (fn () => mk_comp' (#map_comp axioms));
|
blanchet@49990
|
887 |
|
blanchet@49990
|
888 |
val set_natural' =
|
blanchet@49990
|
889 |
map (fn thm => mk_lazy (fn () => mk_set_natural' thm)) (#set_natural axioms);
|
blanchet@49990
|
890 |
|
blanchet@49990
|
891 |
(* relator *)
|
blanchet@49990
|
892 |
|
blanchet@49990
|
893 |
(*%R1 .. Rn. Gr (in R1 .. Rn) (map fst .. fst)^-1 O Gr (in R1 .. Rn) (map snd .. snd)*)
|
blanchet@49990
|
894 |
val rel_rhs =
|
blanchet@49990
|
895 |
let
|
blanchet@49990
|
896 |
val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
|
blanchet@49990
|
897 |
val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
|
blanchet@49990
|
898 |
val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
|
blanchet@49990
|
899 |
in
|
blanchet@49990
|
900 |
fold_rev Term.absfree Rs'
|
blanchet@49990
|
901 |
(mk_rel_comp (mk_converse (mk_Gr bnf_in map1), mk_Gr bnf_in map2))
|
blanchet@49990
|
902 |
end;
|
blanchet@49990
|
903 |
val rel_bind_def = (fn () => Binding.suffix_name ("_" ^ relN) b, rel_rhs);
|
blanchet@49990
|
904 |
|
blanchet@49990
|
905 |
val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
|
blanchet@49990
|
906 |
lthy
|
blanchet@49990
|
907 |
|> maybe_define true rel_bind_def
|
blanchet@49990
|
908 |
||> `(maybe_restore lthy);
|
blanchet@49990
|
909 |
|
blanchet@49990
|
910 |
(*transforms defined frees into consts*)
|
blanchet@49990
|
911 |
val phi = Proof_Context.export_morphism lthy_old lthy;
|
blanchet@49990
|
912 |
val bnf_rel = Morphism.term phi bnf_rel_term;
|
blanchet@49990
|
913 |
|
blanchet@49990
|
914 |
fun mk_bnf_rel setRTs CA' CB' = normalize_rel lthy setRTs CA' CB' bnf_rel;
|
blanchet@49990
|
915 |
|
blanchet@49990
|
916 |
val relAsBs = mk_bnf_rel setRTs CA' CB';
|
blanchet@49990
|
917 |
val bnf_rel_def = Morphism.thm phi raw_rel_def;
|
blanchet@49990
|
918 |
val rel_def_unabs =
|
blanchet@49990
|
919 |
if fact_policy <> Derive_Some_Facts then
|
blanchet@49990
|
920 |
mk_unabs_def live (bnf_rel_def RS meta_eq_to_obj_eq)
|
blanchet@49990
|
921 |
else
|
blanchet@49990
|
922 |
no_fact;
|
blanchet@49990
|
923 |
|
blanchet@49990
|
924 |
val pred_rhs = fold absfree (y' :: x' :: rev Qs') (HOLogic.mk_mem (HOLogic.mk_prod (x, y),
|
blanchet@49990
|
925 |
Term.list_comb (relAsBs, map3 (fn Q => fn T => fn U =>
|
blanchet@49990
|
926 |
HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split Q)
|
blanchet@49990
|
927 |
Qs As' Bs')));
|
blanchet@49990
|
928 |
val pred_bind_def = (fn () => Binding.suffix_name ("_" ^ predN) b, pred_rhs);
|
blanchet@49990
|
929 |
|
blanchet@49990
|
930 |
val ((bnf_pred_term, raw_pred_def), (lthy, lthy_old)) =
|
blanchet@49990
|
931 |
lthy
|
blanchet@49990
|
932 |
|> maybe_define true pred_bind_def
|
blanchet@49990
|
933 |
||> `(maybe_restore lthy);
|
blanchet@49990
|
934 |
|
blanchet@49990
|
935 |
(*transforms defined frees into consts*)
|
blanchet@49990
|
936 |
val phi = Proof_Context.export_morphism lthy_old lthy;
|
blanchet@49990
|
937 |
val bnf_pred = Morphism.term phi bnf_pred_term;
|
blanchet@49990
|
938 |
|
blanchet@49990
|
939 |
fun mk_bnf_pred QTs CA' CB' = normalize_pred lthy QTs CA' CB' bnf_pred;
|
blanchet@49990
|
940 |
|
blanchet@49990
|
941 |
val pred = mk_bnf_pred QTs CA' CB';
|
blanchet@49990
|
942 |
val bnf_pred_def = Morphism.thm phi raw_pred_def;
|
blanchet@49990
|
943 |
val pred_def_unabs =
|
blanchet@49990
|
944 |
if fact_policy <> Derive_Some_Facts then
|
blanchet@49990
|
945 |
mk_unabs_def (live + 2) (bnf_pred_def RS meta_eq_to_obj_eq)
|
blanchet@49990
|
946 |
else
|
blanchet@49990
|
947 |
no_fact;
|
blanchet@49990
|
948 |
|
blanchet@49990
|
949 |
fun mk_map_wppull () =
|
blanchet@49990
|
950 |
let
|
blanchet@49990
|
951 |
val prems = if live = 0 then [] else
|
blanchet@49990
|
952 |
[HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
|
blanchet@49990
|
953 |
(map8 mk_wpull Xs B1s B2s f1s f2s (map SOME (e1s ~~ e2s)) p1s p2s))];
|
blanchet@49990
|
954 |
val CX = mk_bnf_T domTs CA;
|
blanchet@49990
|
955 |
val CB1 = mk_bnf_T B1Ts CA;
|
blanchet@49990
|
956 |
val CB2 = mk_bnf_T B2Ts CA;
|
blanchet@49990
|
957 |
val bnf_sets_CX =
|
blanchet@49990
|
958 |
map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
|
blanchet@49990
|
959 |
val bnf_sets_CB1 =
|
blanchet@49990
|
960 |
map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
|
blanchet@49990
|
961 |
val bnf_sets_CB2 =
|
blanchet@49990
|
962 |
map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
|
blanchet@49990
|
963 |
val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
|
blanchet@49990
|
964 |
val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
|
blanchet@49990
|
965 |
val bnf_map_app_e1 = Term.list_comb (mk_bnf_map B1Ts ranTs', e1s);
|
blanchet@49990
|
966 |
val bnf_map_app_e2 = Term.list_comb (mk_bnf_map B2Ts ranTs'', e2s);
|
blanchet@49990
|
967 |
val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
|
blanchet@49990
|
968 |
val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
|
blanchet@49990
|
969 |
|
blanchet@49990
|
970 |
val concl = mk_wpull (mk_in Xs bnf_sets_CX CX)
|
blanchet@49990
|
971 |
(mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
|
blanchet@49990
|
972 |
bnf_map_app_f1 bnf_map_app_f2 (SOME (bnf_map_app_e1, bnf_map_app_e2))
|
blanchet@49990
|
973 |
bnf_map_app_p1 bnf_map_app_p2;
|
blanchet@49990
|
974 |
|
blanchet@49990
|
975 |
val goal =
|
blanchet@49990
|
976 |
fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ e1s @ e2s @ p1s @ p2s)
|
blanchet@49990
|
977 |
(Logic.list_implies (prems, HOLogic.mk_Trueprop concl))
|
blanchet@49990
|
978 |
in
|
blanchet@49990
|
979 |
Skip_Proof.prove lthy [] [] goal
|
blanchet@49990
|
980 |
(fn _ => mk_map_wppull_tac (#map_id axioms) (#map_cong axioms)
|
blanchet@49990
|
981 |
(#map_wpull axioms) (Lazy.force map_comp') (map Lazy.force set_natural'))
|
traytel@50124
|
982 |
|> Thm.close_derivation
|
blanchet@49990
|
983 |
end;
|
blanchet@49990
|
984 |
|
blanchet@49990
|
985 |
val map_wppull = mk_lazy mk_map_wppull;
|
blanchet@49990
|
986 |
|
blanchet@49990
|
987 |
fun mk_rel_Gr () =
|
blanchet@49990
|
988 |
let
|
blanchet@49990
|
989 |
val lhs = Term.list_comb (relAsBs, map2 mk_Gr As fs);
|
blanchet@49990
|
990 |
val rhs = mk_Gr (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
|
blanchet@50138
|
991 |
val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
|
blanchet@49990
|
992 |
in
|
blanchet@49990
|
993 |
Skip_Proof.prove lthy [] [] goal
|
blanchet@49990
|
994 |
(mk_rel_Gr_tac bnf_rel_def (#map_id axioms) (#map_cong axioms)
|
blanchet@49990
|
995 |
(#map_wpull axioms) (Lazy.force in_cong) (Lazy.force map_id')
|
blanchet@49990
|
996 |
(Lazy.force map_comp') (map Lazy.force set_natural'))
|
traytel@50124
|
997 |
|> Thm.close_derivation
|
blanchet@49990
|
998 |
end;
|
blanchet@49990
|
999 |
|
blanchet@49990
|
1000 |
val rel_Gr = mk_lazy mk_rel_Gr;
|
blanchet@49990
|
1001 |
|
blanchet@49990
|
1002 |
fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
|
blanchet@49990
|
1003 |
fun mk_rel_concl f = HOLogic.mk_Trueprop
|
blanchet@49990
|
1004 |
(f (Term.list_comb (relAsBs, Rs), Term.list_comb (relAsBs, Rs_copy)));
|
blanchet@49990
|
1005 |
|
blanchet@49990
|
1006 |
fun mk_rel_mono () =
|
blanchet@49990
|
1007 |
let
|
blanchet@49990
|
1008 |
val mono_prems = mk_rel_prems mk_subset;
|
blanchet@49990
|
1009 |
val mono_concl = mk_rel_concl (uncurry mk_subset);
|
blanchet@49990
|
1010 |
in
|
blanchet@49990
|
1011 |
Skip_Proof.prove lthy [] []
|
blanchet@49990
|
1012 |
(fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
|
blanchet@49990
|
1013 |
(mk_rel_mono_tac bnf_rel_def (Lazy.force in_mono))
|
traytel@50124
|
1014 |
|> Thm.close_derivation
|
blanchet@49990
|
1015 |
end;
|
blanchet@49990
|
1016 |
|
blanchet@49990
|
1017 |
fun mk_rel_cong () =
|
blanchet@49990
|
1018 |
let
|
blanchet@49990
|
1019 |
val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
|
blanchet@49990
|
1020 |
val cong_concl = mk_rel_concl HOLogic.mk_eq;
|
blanchet@49990
|
1021 |
in
|
blanchet@49990
|
1022 |
Skip_Proof.prove lthy [] []
|
blanchet@49990
|
1023 |
(fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
|
blanchet@49990
|
1024 |
(fn _ => (TRY o hyp_subst_tac THEN' rtac refl) 1)
|
traytel@50124
|
1025 |
|> Thm.close_derivation
|
blanchet@49990
|
1026 |
end;
|
blanchet@49990
|
1027 |
|
blanchet@49990
|
1028 |
val rel_mono = mk_lazy mk_rel_mono;
|
blanchet@49990
|
1029 |
val rel_cong = mk_lazy mk_rel_cong;
|
blanchet@49990
|
1030 |
|
blanchet@49990
|
1031 |
fun mk_rel_Id () =
|
blanchet@49990
|
1032 |
let val relAsAs = mk_bnf_rel self_setRTs CA' CA' in
|
blanchet@49990
|
1033 |
Skip_Proof.prove lthy [] []
|
blanchet@49990
|
1034 |
(HOLogic.mk_Trueprop
|
blanchet@49990
|
1035 |
(HOLogic.mk_eq (Term.list_comb (relAsAs, map Id_const As'), Id_const CA')))
|
blanchet@49990
|
1036 |
(mk_rel_Id_tac live (Lazy.force rel_Gr) (#map_id axioms))
|
traytel@50124
|
1037 |
|> Thm.close_derivation
|
blanchet@49990
|
1038 |
end;
|
blanchet@49990
|
1039 |
|
blanchet@49990
|
1040 |
val rel_Id = mk_lazy mk_rel_Id;
|
blanchet@49990
|
1041 |
|
blanchet@49990
|
1042 |
fun mk_rel_converse () =
|
blanchet@49990
|
1043 |
let
|
blanchet@49990
|
1044 |
val relBsAs = mk_bnf_rel setRT's CB' CA';
|
blanchet@49990
|
1045 |
val lhs = Term.list_comb (relBsAs, map mk_converse Rs);
|
blanchet@49990
|
1046 |
val rhs = mk_converse (Term.list_comb (relAsBs, Rs));
|
blanchet@49990
|
1047 |
val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_subset lhs rhs));
|
blanchet@49990
|
1048 |
val le_thm = Skip_Proof.prove lthy [] [] le_goal
|
blanchet@49990
|
1049 |
(mk_rel_converse_le_tac bnf_rel_def (Lazy.force rel_Id) (#map_cong axioms)
|
blanchet@49990
|
1050 |
(Lazy.force map_comp') (map Lazy.force set_natural'))
|
traytel@50124
|
1051 |
|> Thm.close_derivation
|
blanchet@50138
|
1052 |
val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
|
blanchet@49990
|
1053 |
in
|
blanchet@49990
|
1054 |
Skip_Proof.prove lthy [] [] goal (fn _ => mk_rel_converse_tac le_thm)
|
traytel@50124
|
1055 |
|> Thm.close_derivation
|
blanchet@49990
|
1056 |
end;
|
blanchet@49990
|
1057 |
|
blanchet@49990
|
1058 |
val rel_converse = mk_lazy mk_rel_converse;
|
blanchet@49990
|
1059 |
|
blanchet@49990
|
1060 |
fun mk_rel_O () =
|
blanchet@49990
|
1061 |
let
|
blanchet@49990
|
1062 |
val relAsCs = mk_bnf_rel setRTsAsCs CA' CC';
|
blanchet@49990
|
1063 |
val relBsCs = mk_bnf_rel setRTsBsCs CB' CC';
|
blanchet@49990
|
1064 |
val lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_comp) Rs Ss);
|
blanchet@49990
|
1065 |
val rhs = mk_rel_comp (Term.list_comb (relAsBs, Rs), Term.list_comb (relBsCs, Ss));
|
blanchet@50138
|
1066 |
val goal = fold_rev Logic.all (Rs @ Ss) (mk_Trueprop_eq (lhs, rhs));
|
blanchet@49990
|
1067 |
in
|
blanchet@49990
|
1068 |
Skip_Proof.prove lthy [] [] goal
|
blanchet@49990
|
1069 |
(mk_rel_O_tac bnf_rel_def (Lazy.force rel_Id) (#map_cong axioms)
|
blanchet@49990
|
1070 |
(Lazy.force map_wppull) (Lazy.force map_comp') (map Lazy.force set_natural'))
|
traytel@50124
|
1071 |
|> Thm.close_derivation
|
blanchet@49990
|
1072 |
end;
|
blanchet@49990
|
1073 |
|
blanchet@49990
|
1074 |
val rel_O = mk_lazy mk_rel_O;
|
blanchet@49990
|
1075 |
|
blanchet@49990
|
1076 |
fun mk_in_rel () =
|
blanchet@49990
|
1077 |
let
|
blanchet@49990
|
1078 |
val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
|
blanchet@49990
|
1079 |
val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
|
blanchet@49990
|
1080 |
val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
|
blanchet@49990
|
1081 |
val map_fst_eq = HOLogic.mk_eq (map1 $ z, x);
|
blanchet@49990
|
1082 |
val map_snd_eq = HOLogic.mk_eq (map2 $ z, y);
|
blanchet@49990
|
1083 |
val lhs = HOLogic.mk_mem (HOLogic.mk_prod (x, y), Term.list_comb (relAsBs, Rs));
|
blanchet@49990
|
1084 |
val rhs =
|
blanchet@49990
|
1085 |
HOLogic.mk_exists (fst z', snd z', HOLogic.mk_conj (HOLogic.mk_mem (z, bnf_in),
|
blanchet@49990
|
1086 |
HOLogic.mk_conj (map_fst_eq, map_snd_eq)));
|
blanchet@49990
|
1087 |
val goal =
|
blanchet@50138
|
1088 |
fold_rev Logic.all (x :: y :: Rs) (mk_Trueprop_eq (lhs, rhs));
|
blanchet@49990
|
1089 |
in
|
blanchet@49990
|
1090 |
Skip_Proof.prove lthy [] [] goal (mk_in_rel_tac bnf_rel_def (length bnf_sets))
|
traytel@50124
|
1091 |
|> Thm.close_derivation
|
blanchet@49990
|
1092 |
end;
|
blanchet@49990
|
1093 |
|
blanchet@49990
|
1094 |
val in_rel = mk_lazy mk_in_rel;
|
blanchet@49990
|
1095 |
|
blanchet@49990
|
1096 |
val defs = mk_defs bnf_map_def bnf_set_defs rel_def_unabs pred_def_unabs;
|
blanchet@49990
|
1097 |
|
blanchet@49990
|
1098 |
val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_natural
|
blanchet@49990
|
1099 |
in_cong in_mono in_rel map_comp' map_id' map_wppull
|
blanchet@49990
|
1100 |
rel_cong rel_mono rel_Id rel_Gr rel_converse rel_O set_natural';
|
blanchet@49990
|
1101 |
|
blanchet@49990
|
1102 |
val wits = map2 mk_witness bnf_wits wit_thms;
|
blanchet@49990
|
1103 |
|
blanchet@49990
|
1104 |
val bnf_rel = Term.subst_atomic_types
|
blanchet@49990
|
1105 |
((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) relAsBs;
|
blanchet@49990
|
1106 |
val bnf_pred = Term.subst_atomic_types
|
blanchet@49990
|
1107 |
((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) pred;
|
blanchet@49990
|
1108 |
|
blanchet@49990
|
1109 |
val bnf = mk_bnf b CA live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms defs facts
|
blanchet@49990
|
1110 |
wits bnf_rel bnf_pred;
|
blanchet@49990
|
1111 |
in
|
blanchet@49990
|
1112 |
(bnf, lthy
|
blanchet@49990
|
1113 |
|> (if fact_policy = Note_All_Facts_and_Axioms then
|
blanchet@49990
|
1114 |
let
|
blanchet@49990
|
1115 |
val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
|
traytel@50124
|
1116 |
val notes =
|
traytel@50124
|
1117 |
[(bd_card_orderN, [#bd_card_order axioms]),
|
traytel@50124
|
1118 |
(bd_cinfiniteN, [#bd_cinfinite axioms]),
|
traytel@50124
|
1119 |
(bd_Card_orderN, [#bd_Card_order facts]),
|
traytel@50124
|
1120 |
(bd_CinfiniteN, [#bd_Cinfinite facts]),
|
traytel@50124
|
1121 |
(bd_CnotzeroN, [#bd_Cnotzero facts]),
|
traytel@50124
|
1122 |
(collect_set_naturalN, [Lazy.force (#collect_set_natural facts)]),
|
traytel@50124
|
1123 |
(in_bdN, [#in_bd axioms]),
|
traytel@50124
|
1124 |
(in_monoN, [Lazy.force (#in_mono facts)]),
|
traytel@50124
|
1125 |
(in_relN, [Lazy.force (#in_rel facts)]),
|
traytel@50124
|
1126 |
(map_compN, [#map_comp axioms]),
|
traytel@50124
|
1127 |
(map_idN, [#map_id axioms]),
|
traytel@50124
|
1128 |
(map_wpullN, [#map_wpull axioms]),
|
traytel@50124
|
1129 |
(set_naturalN, #set_natural axioms),
|
traytel@50124
|
1130 |
(set_bdN, #set_bd axioms)] @
|
traytel@50124
|
1131 |
map2 pair witNs wit_thms
|
traytel@50124
|
1132 |
|> map (fn (thmN, thms) =>
|
traytel@50124
|
1133 |
((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
|
traytel@50124
|
1134 |
[(thms, [])]));
|
blanchet@49990
|
1135 |
in
|
traytel@50124
|
1136 |
Local_Theory.notes notes #> snd
|
blanchet@49990
|
1137 |
end
|
blanchet@49990
|
1138 |
else
|
blanchet@49990
|
1139 |
I)
|
blanchet@49990
|
1140 |
|> (if fact_policy = Note_All_Facts_and_Axioms orelse
|
blanchet@49990
|
1141 |
fact_policy = Derive_All_Facts_Note_Most then
|
traytel@50124
|
1142 |
let
|
traytel@50124
|
1143 |
val notes =
|
traytel@50124
|
1144 |
[(map_congN, [#map_cong axioms]),
|
traytel@50124
|
1145 |
(rel_IdN, [Lazy.force (#rel_Id facts)]),
|
traytel@50124
|
1146 |
(rel_GrN, [Lazy.force (#rel_Gr facts)]),
|
traytel@50124
|
1147 |
(rel_converseN, [Lazy.force (#rel_converse facts)]),
|
traytel@50124
|
1148 |
(rel_ON, [Lazy.force (#rel_O facts)]),
|
traytel@50124
|
1149 |
(map_id'N, [Lazy.force (#map_id' facts)]),
|
traytel@50124
|
1150 |
(map_comp'N, [Lazy.force (#map_comp' facts)]),
|
traytel@50124
|
1151 |
(set_natural'N, map Lazy.force (#set_natural' facts))]
|
traytel@50124
|
1152 |
|> map (fn (thmN, thms) =>
|
traytel@50124
|
1153 |
((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
|
traytel@50124
|
1154 |
[(thms, [])]));
|
traytel@50124
|
1155 |
in
|
traytel@50124
|
1156 |
Local_Theory.notes notes #> snd
|
traytel@50124
|
1157 |
#> Local_Theory.declaration {syntax = false, pervasive = true}
|
traytel@50124
|
1158 |
(fn phi => Data.map (Symtab.update_new (key, morph_bnf phi bnf)))
|
traytel@50124
|
1159 |
end
|
blanchet@49990
|
1160 |
else
|
blanchet@49990
|
1161 |
I))
|
blanchet@49990
|
1162 |
end;
|
blanchet@49990
|
1163 |
in
|
blanchet@49990
|
1164 |
(goals, wit_goalss, after_qed, lthy', one_step_defs)
|
blanchet@49990
|
1165 |
end;
|
blanchet@49990
|
1166 |
|
blanchet@50033
|
1167 |
fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds =
|
blanchet@49990
|
1168 |
(fn (goals, wit_goalss, after_qed, lthy, defs) =>
|
blanchet@49990
|
1169 |
let
|
blanchet@49990
|
1170 |
val wits_tac = K (TRYALL Goal.conjunction_tac) THEN' unfold_defs_tac lthy defs wit_tac;
|
blanchet@49990
|
1171 |
val wit_goals = wit_goalss |> map Logic.mk_conjunction_balanced;
|
blanchet@49990
|
1172 |
val wit_goal = Logic.mk_conjunction_balanced wit_goals;
|
blanchet@49990
|
1173 |
val wit_thms =
|
blanchet@49990
|
1174 |
Skip_Proof.prove lthy [] [] wit_goal wits_tac
|
blanchet@49990
|
1175 |
|> Conjunction.elim_balanced (length wit_goals)
|
blanchet@49990
|
1176 |
|> map2 (Conjunction.elim_balanced o length) wit_goalss
|
traytel@50124
|
1177 |
|> map (map (Thm.close_derivation o Thm.forall_elim_vars 0))
|
blanchet@49990
|
1178 |
in
|
blanchet@50126
|
1179 |
map2 (Thm.close_derivation oo Skip_Proof.prove lthy [] [])
|
blanchet@50126
|
1180 |
goals (map (unfold_defs_tac lthy defs) tacs)
|
blanchet@49990
|
1181 |
|> (fn thms => after_qed (map single thms @ wit_thms) lthy)
|
blanchet@50034
|
1182 |
end) oo prepare_def const_policy fact_policy qualify
|
blanchet@50126
|
1183 |
(singleton o Type_Infer_Context.infer_types) Ds;
|
blanchet@49990
|
1184 |
|
blanchet@50033
|
1185 |
val bnf_def_cmd = (fn (goals, wit_goals, after_qed, lthy, defs) =>
|
blanchet@49990
|
1186 |
Proof.unfolding ([[(defs, [])]])
|
blanchet@49990
|
1187 |
(Proof.theorem NONE (snd oo after_qed)
|
blanchet@49990
|
1188 |
(map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
|
blanchet@50034
|
1189 |
prepare_def Do_Inline user_policy I Syntax.read_term NONE;
|
blanchet@49990
|
1190 |
|
blanchet@49990
|
1191 |
fun print_bnfs ctxt =
|
blanchet@49990
|
1192 |
let
|
blanchet@49990
|
1193 |
fun pretty_set sets i = Pretty.block
|
blanchet@49990
|
1194 |
[Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
|
blanchet@49990
|
1195 |
Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
|
blanchet@49990
|
1196 |
|
blanchet@49990
|
1197 |
fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
|
blanchet@49990
|
1198 |
live = live, lives = lives, dead = dead, deads = deads, ...}) =
|
blanchet@49990
|
1199 |
Pretty.big_list
|
blanchet@49990
|
1200 |
(Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
|
blanchet@49990
|
1201 |
Pretty.quote (Syntax.pretty_typ ctxt T)]))
|
blanchet@49990
|
1202 |
([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
|
blanchet@49990
|
1203 |
Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
|
blanchet@49990
|
1204 |
Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
|
blanchet@49990
|
1205 |
Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
|
blanchet@49990
|
1206 |
Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
|
blanchet@49990
|
1207 |
Pretty.quote (Syntax.pretty_term ctxt map)]] @
|
blanchet@49990
|
1208 |
List.map (pretty_set sets) (0 upto length sets - 1) @
|
blanchet@49990
|
1209 |
[Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
|
blanchet@49990
|
1210 |
Pretty.quote (Syntax.pretty_term ctxt bd)]]);
|
blanchet@49990
|
1211 |
in
|
blanchet@49990
|
1212 |
Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
|
blanchet@49990
|
1213 |
|> Pretty.writeln
|
blanchet@49990
|
1214 |
end;
|
blanchet@49990
|
1215 |
|
blanchet@49990
|
1216 |
val _ =
|
blanchet@49990
|
1217 |
Outer_Syntax.improper_command @{command_spec "print_bnfs"} "print all BNFs"
|
blanchet@49990
|
1218 |
(Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
|
blanchet@49990
|
1219 |
|
blanchet@49990
|
1220 |
val _ =
|
blanchet@49990
|
1221 |
Outer_Syntax.local_theory_to_proof @{command_spec "bnf_def"} "define a BNF for an existing type"
|
blanchet@49990
|
1222 |
(((Parse.binding --| Parse.$$$ "=") -- Parse.term --
|
blanchet@49990
|
1223 |
(Parse.$$$ "[" |-- Parse.list Parse.term --| Parse.$$$ "]") -- Parse.term --
|
blanchet@50033
|
1224 |
(Parse.$$$ "[" |-- Parse.list Parse.term --| Parse.$$$ "]")) >> bnf_def_cmd);
|
blanchet@49990
|
1225 |
|
blanchet@49990
|
1226 |
end;
|