1(* Title: HOL/Tools/BNF/bnf_def.ML 2 Author: Dmitriy Traytel, TU Muenchen 3 Author: Jasmin Blanchette, TU Muenchen 4 Author: Martin Desharnais, TU Muenchen 5 Copyright 2012, 2013, 2014 6 7Definition of bounded natural functors. 8*) 9 10signature BNF_DEF = 11sig 12 type bnf 13 type nonemptiness_witness = {I: int list, wit: term, prop: thm list} 14 15 val morph_bnf: morphism -> bnf -> bnf 16 val morph_bnf_defs: morphism -> bnf -> bnf 17 val permute_deads: (typ list -> typ list) -> bnf -> bnf 18 val transfer_bnf: theory -> bnf -> bnf 19 val bnf_of: Proof.context -> string -> bnf option 20 val bnf_of_global: theory -> string -> bnf option 21 val bnf_interpretation: string -> (bnf -> local_theory -> local_theory) -> theory -> theory 22 val interpret_bnf: (string -> bool) -> bnf -> local_theory -> local_theory 23 val register_bnf_raw: string -> bnf -> local_theory -> local_theory 24 val register_bnf: (string -> bool) -> string -> bnf -> local_theory -> local_theory 25 26 val name_of_bnf: bnf -> binding 27 val T_of_bnf: bnf -> typ 28 val live_of_bnf: bnf -> int 29 val lives_of_bnf: bnf -> typ list 30 val dead_of_bnf: bnf -> int 31 val deads_of_bnf: bnf -> typ list 32 val bd_of_bnf: bnf -> term 33 val nwits_of_bnf: bnf -> int 34 35 val mapN: string 36 val predN: string 37 val relN: string 38 val setN: string 39 val mk_setN: int -> string 40 val mk_witN: int -> string 41 42 val map_of_bnf: bnf -> term 43 val pred_of_bnf: bnf -> term 44 val rel_of_bnf: bnf -> term 45 val sets_of_bnf: bnf -> term list 46 47 val mk_T_of_bnf: typ list -> typ list -> bnf -> typ 48 val mk_bd_of_bnf: typ list -> typ list -> bnf -> term 49 val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term 50 val mk_pred_of_bnf: typ list -> typ list -> bnf -> term 51 val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term 52 val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list 53 val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list 54 55 val bd_Card_order_of_bnf: bnf -> thm 56 val bd_Cinfinite_of_bnf: bnf -> thm 57 val bd_Cnotzero_of_bnf: bnf -> thm 58 val bd_card_order_of_bnf: bnf -> thm 59 val bd_cinfinite_of_bnf: bnf -> thm 60 val collect_set_map_of_bnf: bnf -> thm 61 val in_bd_of_bnf: bnf -> thm 62 val in_cong_of_bnf: bnf -> thm 63 val in_mono_of_bnf: bnf -> thm 64 val in_rel_of_bnf: bnf -> thm 65 val inj_map_of_bnf: bnf -> thm 66 val inj_map_strong_of_bnf: bnf -> thm 67 val le_rel_OO_of_bnf: bnf -> thm 68 val map_comp0_of_bnf: bnf -> thm 69 val map_comp_of_bnf: bnf -> thm 70 val map_cong0_of_bnf: bnf -> thm 71 val map_cong_of_bnf: bnf -> thm 72 val map_cong_pred_of_bnf: bnf -> thm 73 val map_cong_simp_of_bnf: bnf -> thm 74 val map_def_of_bnf: bnf -> thm 75 val map_id0_of_bnf: bnf -> thm 76 val map_id_of_bnf: bnf -> thm 77 val map_ident0_of_bnf: bnf -> thm 78 val map_ident_of_bnf: bnf -> thm 79 val map_transfer_of_bnf: bnf -> thm 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 87 val pred_mono_of_bnf: bnf -> thm 88 val pred_set_of_bnf: bnf -> thm 89 val pred_rel_of_bnf: bnf -> thm 90 val pred_transfer_of_bnf: bnf -> thm 91 val pred_True_of_bnf: bnf -> thm 92 val rel_Grp_of_bnf: bnf -> thm 93 val rel_OO_Grp_of_bnf: bnf -> thm 94 val rel_OO_of_bnf: bnf -> thm 95 val rel_cong0_of_bnf: bnf -> thm 96 val rel_cong_of_bnf: bnf -> thm 97 val rel_cong_simp_of_bnf: bnf -> thm 98 val rel_conversep_of_bnf: bnf -> thm 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 103 val rel_mono_of_bnf: bnf -> thm 104 val rel_mono_strong0_of_bnf: bnf -> thm 105 val rel_mono_strong_of_bnf: bnf -> thm 106 val rel_eq_onp_of_bnf: bnf -> thm 107 val rel_refl_of_bnf: bnf -> thm 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 111 val rel_transfer_of_bnf: bnf -> thm 112 val rel_transp_of_bnf: bnf -> thm 113 val set_bd_of_bnf: bnf -> thm list 114 val set_defs_of_bnf: bnf -> thm list 115 val set_map0_of_bnf: bnf -> thm list 116 val set_map_of_bnf: bnf -> thm list 117 val set_transfer_of_bnf: bnf -> thm list 118 val wit_thms_of_bnf: bnf -> thm list 119 val wit_thmss_of_bnf: bnf -> thm list list 120 121 val mk_map: int -> typ list -> typ list -> term -> term 122 val mk_pred: typ list -> term -> term 123 val mk_rel: int -> typ list -> typ list -> term -> term 124 val mk_set: typ list -> term -> term 125 val build_map: Proof.context -> typ list -> typ list -> (typ * typ -> term) -> typ * typ -> term 126 val build_rel: (string * (int * term)) list -> Proof.context -> typ list -> typ list -> 127 (typ * typ -> term) -> typ * typ -> term 128 val build_set: Proof.context -> typ -> typ -> term 129 val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list 130 val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list -> 131 'a list 132 133 val mk_witness: int list * term -> thm list -> nonemptiness_witness 134 val mk_wit_goals: term list -> term list -> term list -> int list * term -> term list 135 val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list 136 val wits_of_bnf: bnf -> nonemptiness_witness list 137 138 val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list 139 140 datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline 141 datatype fact_policy = Dont_Note | Note_Some | Note_All 142 143 val bnf_internals: bool Config.T 144 val bnf_timing: bool Config.T 145 val user_policy: fact_policy -> Proof.context -> fact_policy 146 val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> local_theory -> 147 bnf * local_theory 148 val note_bnf_defs: bnf -> local_theory -> bnf * local_theory 149 150 val print_bnfs: Proof.context -> unit 151 val prepare_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> 152 (binding -> binding) -> (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> 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 -> 156 string * term list * ((Proof.context -> thm list -> tactic) option * term list list) * 157 ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) * 158 local_theory * thm list 159 val define_bnf_consts: inline_policy -> fact_policy -> bool -> typ list option -> 160 binding -> binding -> binding -> binding list -> 161 ((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option -> 162 local_theory -> 163 ((typ list * typ list * typ list * typ) * 164 (term * term list * term * (int list * term) list * term * term) * 165 (thm * thm list * thm * thm list * thm * thm) * 166 ((typ list -> typ list -> typ list -> term) * 167 (typ list -> typ list -> term -> term) * 168 (typ list -> typ list -> typ -> typ) * 169 (typ list -> typ list -> typ list -> term) * 170 (typ list -> typ list -> term) * 171 (typ list -> typ list -> typ list -> term) * 172 (typ list -> typ list -> term))) * local_theory 173 174 val bnf_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> (binding -> binding) -> 175 (Proof.context -> tactic) list -> (Proof.context -> tactic) -> typ list option -> binding -> 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) -> 181 Proof.context -> Proof.state 182end; 183 184structure BNF_Def : BNF_DEF = 185struct 186 187open BNF_Util 188open BNF_Tactics 189open BNF_Def_Tactics 190 191val fundefcong_attrs = @{attributes [fundef_cong]}; 192val mono_attrs = @{attributes [mono]}; 193 194type axioms = { 195 map_id0: thm, 196 map_comp0: thm, 197 map_cong0: thm, 198 set_map0: thm list, 199 bd_card_order: thm, 200 bd_cinfinite: thm, 201 set_bd: thm list, 202 le_rel_OO: thm, 203 rel_OO_Grp: thm, 204 pred_set: thm 205}; 206 207fun mk_axioms' (((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel), pred) = 208 {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o, 209 bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel, pred_set = pred}; 210 211fun dest_cons [] = raise List.Empty 212 | dest_cons (x :: xs) = (x, xs); 213 214fun mk_axioms n thms = thms 215 |> map the_single 216 |> dest_cons 217 ||>> dest_cons 218 ||>> dest_cons 219 ||>> chop n 220 ||>> dest_cons 221 ||>> dest_cons 222 ||>> chop n 223 ||>> dest_cons 224 ||>> dest_cons 225 ||> the_single 226 |> mk_axioms'; 227 228fun 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]; 230 231fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd, 232 le_rel_OO, rel_OO_Grp, pred_set} = 233 {map_id0 = f map_id0, 234 map_comp0 = f map_comp0, 235 map_cong0 = f map_cong0, 236 set_map0 = map f set_map0, 237 bd_card_order = f bd_card_order, 238 bd_cinfinite = f bd_cinfinite, 239 set_bd = map f set_bd, 240 le_rel_OO = f le_rel_OO, 241 rel_OO_Grp = f rel_OO_Grp, 242 pred_set = f pred_set}; 243 244val morph_axioms = map_axioms o Morphism.thm; 245 246type defs = { 247 map_def: thm, 248 set_defs: thm list, 249 rel_def: thm, 250 pred_def: thm 251} 252 253fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred}; 254 255fun 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}; 257 258val morph_defs = map_defs o Morphism.thm; 259 260type facts = { 261 bd_Card_order: thm, 262 bd_Cinfinite: thm, 263 bd_Cnotzero: thm, 264 collect_set_map: thm lazy, 265 in_bd: thm lazy, 266 in_cong: thm lazy, 267 in_mono: thm lazy, 268 in_rel: thm lazy, 269 inj_map: thm lazy, 270 inj_map_strong: thm lazy, 271 map_comp: thm lazy, 272 map_cong: thm lazy, 273 map_cong_simp: thm lazy, 274 map_cong_pred: thm lazy, 275 map_id: thm lazy, 276 map_ident0: thm lazy, 277 map_ident: thm lazy, 278 map_transfer: thm lazy, 279 rel_eq: thm lazy, 280 rel_flip: thm lazy, 281 set_map: thm lazy list, 282 rel_cong0: thm lazy, 283 rel_cong: thm lazy, 284 rel_cong_simp: thm lazy, 285 rel_map: thm list lazy, 286 rel_mono: thm lazy, 287 rel_mono_strong0: thm lazy, 288 rel_mono_strong: thm lazy, 289 set_transfer: thm list lazy, 290 rel_Grp: thm lazy, 291 rel_conversep: thm lazy, 292 rel_OO: thm lazy, 293 rel_refl: thm lazy, 294 rel_refl_strong: thm lazy, 295 rel_reflp: thm lazy, 296 rel_symp: thm lazy, 297 rel_transp: thm lazy, 298 rel_transfer: thm lazy, 299 rel_eq_onp: thm lazy, 300 pred_transfer: thm lazy, 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, 306 pred_mono: thm lazy, 307 pred_cong0: thm lazy, 308 pred_cong: thm lazy, 309 pred_cong_simp: thm lazy 310}; 311 312fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel 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 316 rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp pred_transfer pred_True 317 pred_map pred_rel pred_mono_strong0 pred_mono_strong pred_mono pred_cong0 pred_cong 318 pred_cong_simp = { 319 bd_Card_order = bd_Card_order, 320 bd_Cinfinite = bd_Cinfinite, 321 bd_Cnotzero = bd_Cnotzero, 322 collect_set_map = collect_set_map, 323 in_bd = in_bd, 324 in_cong = in_cong, 325 in_mono = in_mono, 326 in_rel = in_rel, 327 inj_map = inj_map, 328 inj_map_strong = inj_map_strong, 329 map_comp = map_comp, 330 map_cong = map_cong, 331 map_cong_simp = map_cong_simp, 332 map_cong_pred = map_cong_pred, 333 map_id = map_id, 334 map_ident0 = map_ident0, 335 map_ident = map_ident, 336 map_transfer = map_transfer, 337 rel_eq = rel_eq, 338 rel_flip = rel_flip, 339 set_map = set_map, 340 rel_cong0 = rel_cong0, 341 rel_cong = rel_cong, 342 rel_cong_simp = rel_cong_simp, 343 rel_map = rel_map, 344 rel_mono = rel_mono, 345 rel_mono_strong0 = rel_mono_strong0, 346 rel_mono_strong = rel_mono_strong, 347 rel_transfer = rel_transfer, 348 rel_Grp = rel_Grp, 349 rel_conversep = rel_conversep, 350 rel_OO = rel_OO, 351 rel_refl = rel_refl, 352 rel_refl_strong = rel_refl_strong, 353 rel_reflp = rel_reflp, 354 rel_symp = rel_symp, 355 rel_transp = rel_transp, 356 set_transfer = set_transfer, 357 rel_eq_onp = rel_eq_onp, 358 pred_transfer = pred_transfer, 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, 364 pred_mono = pred_mono, 365 pred_cong0 = pred_cong0, 366 pred_cong = pred_cong, 367 pred_cong_simp = pred_cong_simp}; 368 369fun map_facts f { 370 bd_Card_order, 371 bd_Cinfinite, 372 bd_Cnotzero, 373 collect_set_map, 374 in_bd, 375 in_cong, 376 in_mono, 377 in_rel, 378 inj_map, 379 inj_map_strong, 380 map_comp, 381 map_cong, 382 map_cong_simp, 383 map_cong_pred, 384 map_id, 385 map_ident0, 386 map_ident, 387 map_transfer, 388 rel_eq, 389 rel_flip, 390 set_map, 391 rel_cong0, 392 rel_cong, 393 rel_cong_simp, 394 rel_map, 395 rel_mono, 396 rel_mono_strong0, 397 rel_mono_strong, 398 rel_transfer, 399 rel_Grp, 400 rel_conversep, 401 rel_OO, 402 rel_refl, 403 rel_refl_strong, 404 rel_reflp, 405 rel_symp, 406 rel_transp, 407 set_transfer, 408 rel_eq_onp, 409 pred_transfer, 410 pred_True, 411 pred_map, 412 pred_rel, 413 pred_mono_strong0, 414 pred_mono_strong, 415 pred_mono, 416 pred_cong0, 417 pred_cong, 418 pred_cong_simp} = 419 {bd_Card_order = f bd_Card_order, 420 bd_Cinfinite = f bd_Cinfinite, 421 bd_Cnotzero = f bd_Cnotzero, 422 collect_set_map = Lazy.map f collect_set_map, 423 in_bd = Lazy.map f in_bd, 424 in_cong = Lazy.map f in_cong, 425 in_mono = Lazy.map f in_mono, 426 in_rel = Lazy.map f in_rel, 427 inj_map = Lazy.map f inj_map, 428 inj_map_strong = Lazy.map f inj_map_strong, 429 map_comp = Lazy.map f map_comp, 430 map_cong = Lazy.map f map_cong, 431 map_cong_simp = Lazy.map f map_cong_simp, 432 map_cong_pred = Lazy.map f map_cong_pred, 433 map_id = Lazy.map f map_id, 434 map_ident0 = Lazy.map f map_ident0, 435 map_ident = Lazy.map f map_ident, 436 map_transfer = Lazy.map f map_transfer, 437 rel_eq = Lazy.map f rel_eq, 438 rel_flip = Lazy.map f rel_flip, 439 set_map = map (Lazy.map f) set_map, 440 rel_cong0 = Lazy.map f rel_cong0, 441 rel_cong = Lazy.map f rel_cong, 442 rel_cong_simp = Lazy.map f rel_cong_simp, 443 rel_map = Lazy.map (map f) rel_map, 444 rel_mono = Lazy.map f rel_mono, 445 rel_mono_strong0 = Lazy.map f rel_mono_strong0, 446 rel_mono_strong = Lazy.map f rel_mono_strong, 447 rel_transfer = Lazy.map f rel_transfer, 448 rel_Grp = Lazy.map f rel_Grp, 449 rel_conversep = Lazy.map f rel_conversep, 450 rel_OO = Lazy.map f rel_OO, 451 rel_refl = Lazy.map f rel_refl, 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, 456 set_transfer = Lazy.map (map f) set_transfer, 457 rel_eq_onp = Lazy.map f rel_eq_onp, 458 pred_transfer = Lazy.map f pred_transfer, 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, 464 pred_mono = Lazy.map f pred_mono, 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}; 468 469val morph_facts = map_facts o Morphism.thm; 470 471type nonemptiness_witness = { 472 I: int list, 473 wit: term, 474 prop: thm list 475}; 476 477fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop}; 478fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop}; 479fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi); 480 481datatype bnf = BNF of { 482 name: binding, 483 T: typ, 484 live: int, 485 lives: typ list, (*source type variables of map*) 486 lives': typ list, (*target type variables of map*) 487 dead: int, 488 deads: typ list, 489 map: term, 490 sets: term list, 491 bd: term, 492 axioms: axioms, 493 defs: defs, 494 facts: facts, 495 nwits: int, 496 wits: nonemptiness_witness list, 497 rel: term, 498 pred: term 499}; 500 501(* getters *) 502 503fun rep_bnf (BNF bnf) = bnf; 504val name_of_bnf = #name o rep_bnf; 505val T_of_bnf = #T o rep_bnf; 506fun mk_T_of_bnf Ds Ts bnf = 507 let val bnf_rep = rep_bnf bnf 508 in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end; 509val live_of_bnf = #live o rep_bnf; 510val lives_of_bnf = #lives o rep_bnf; 511val dead_of_bnf = #dead o rep_bnf; 512val deads_of_bnf = #deads o rep_bnf; 513val axioms_of_bnf = #axioms o rep_bnf; 514val facts_of_bnf = #facts o rep_bnf; 515val nwits_of_bnf = #nwits o rep_bnf; 516val wits_of_bnf = #wits o rep_bnf; 517 518fun 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 524 permute_like_unique (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs) 525 end; 526 527(*terms*) 528val map_of_bnf = #map o rep_bnf; 529val sets_of_bnf = #sets o rep_bnf; 530fun mk_map_of_bnf Ds Ts Us bnf = 531 let val bnf_rep = rep_bnf bnf; 532 in 533 Term.subst_atomic_types 534 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep) 535 end; 536fun mk_sets_of_bnf Dss Tss bnf = 537 let val bnf_rep = rep_bnf bnf; 538 in 539 map2 (fn (Ds, Ts) => Term.subst_atomic_types 540 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep) 541 end; 542val bd_of_bnf = #bd o rep_bnf; 543fun mk_bd_of_bnf Ds Ts bnf = 544 let val bnf_rep = rep_bnf bnf; 545 in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end; 546fun mk_wits_of_bnf Dss Tss bnf = 547 let 548 val bnf_rep = rep_bnf bnf; 549 val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep); 550 in 551 map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types 552 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits 553 end; 554val rel_of_bnf = #rel o rep_bnf; 555fun mk_rel_of_bnf Ds Ts Us bnf = 556 let val bnf_rep = rep_bnf bnf; 557 in 558 Term.subst_atomic_types 559 ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep) 560 end; 561val pred_of_bnf = #pred o rep_bnf; 562fun 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; 568 569(*thms*) 570val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf; 571val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf; 572val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf; 573val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf; 574val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf; 575val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf; 576val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf; 577val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf; 578val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf; 579val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf; 580val inj_map_of_bnf = Lazy.force o #inj_map o #facts o rep_bnf; 581val inj_map_strong_of_bnf = Lazy.force o #inj_map_strong o #facts o rep_bnf; 582val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf; 583val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf; 584val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf; 585val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf; 586val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf; 587val map_cong_pred_of_bnf = Lazy.force o #map_cong_pred o #facts o rep_bnf; 588val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf; 589val map_def_of_bnf = #map_def o #defs o rep_bnf; 590val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf; 591val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf; 592val map_ident0_of_bnf = Lazy.force o #map_ident0 o #facts o rep_bnf; 593val map_ident_of_bnf = Lazy.force o #map_ident o #facts o rep_bnf; 594val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf; 595val rel_eq_onp_of_bnf = Lazy.force o #rel_eq_onp o #facts o rep_bnf; 596val pred_def_of_bnf = #pred_def o #defs o rep_bnf; 597val pred_map_of_bnf = Lazy.force o #pred_map o #facts o rep_bnf; 598val pred_mono_strong0_of_bnf = Lazy.force o #pred_mono_strong0 o #facts o rep_bnf; 599val pred_mono_strong_of_bnf = Lazy.force o #pred_mono_strong o #facts o rep_bnf; 600val pred_mono_of_bnf = Lazy.force o #pred_mono o #facts o rep_bnf; 601val pred_cong0_of_bnf = Lazy.force o #pred_cong0 o #facts o rep_bnf; 602val pred_cong_of_bnf = Lazy.force o #pred_cong o #facts o rep_bnf; 603val pred_cong_simp_of_bnf = Lazy.force o #pred_cong_simp o #facts o rep_bnf; 604val pred_rel_of_bnf = Lazy.force o #pred_rel o #facts o rep_bnf; 605val pred_set_of_bnf = #pred_set o #axioms o rep_bnf; 606val pred_transfer_of_bnf = Lazy.force o #pred_transfer o #facts o rep_bnf; 607val pred_True_of_bnf = Lazy.force o #pred_True o #facts o rep_bnf; 608val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf; 609val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf; 610val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf; 611val rel_cong0_of_bnf = Lazy.force o #rel_cong0 o #facts o rep_bnf; 612val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf; 613val rel_cong_simp_of_bnf = Lazy.force o #rel_cong_simp o #facts o rep_bnf; 614val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf; 615val rel_def_of_bnf = #rel_def o #defs o rep_bnf; 616val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf; 617val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf; 618val rel_map_of_bnf = Lazy.force o #rel_map o #facts o rep_bnf; 619val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf; 620val rel_mono_strong0_of_bnf = Lazy.force o #rel_mono_strong0 o #facts o rep_bnf; 621val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf; 622val rel_refl_of_bnf = Lazy.force o #rel_refl o #facts o rep_bnf; 623val rel_refl_strong_of_bnf = Lazy.force o #rel_refl_strong o #facts o rep_bnf; 624val rel_reflp_of_bnf = Lazy.force o #rel_reflp o #facts o rep_bnf; 625val rel_symp_of_bnf = Lazy.force o #rel_symp o #facts o rep_bnf; 626val rel_transfer_of_bnf = Lazy.force o #rel_transfer o #facts o rep_bnf; 627val rel_transp_of_bnf = Lazy.force o #rel_transp o #facts o rep_bnf; 628val set_bd_of_bnf = #set_bd o #axioms o rep_bnf; 629val set_defs_of_bnf = #set_defs o #defs o rep_bnf; 630val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf; 631val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf; 632val set_transfer_of_bnf = Lazy.force o #set_transfer o #facts o rep_bnf; 633val wit_thms_of_bnf = maps #prop o wits_of_bnf; 634val wit_thmss_of_bnf = map #prop o wits_of_bnf; 635 636fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred = 637 BNF {name = name, T = T, 638 live = live, lives = lives, lives' = lives', dead = dead, deads = deads, 639 map = map, sets = sets, bd = bd, 640 axioms = axioms, defs = defs, facts = facts, 641 nwits = length wits, wits = wits, rel = rel, pred = pred}; 642 643fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 644 (BNF {name = name, T = T, live = live, lives = lives, lives' = lives', 645 dead = dead, deads = deads, map = map, sets = sets, bd = bd, 646 axioms = axioms, defs = defs, facts = facts, 647 nwits = nwits, wits = wits, rel = rel, pred = pred}) = 648 BNF {name = f1 name, T = f2 T, 649 live = f3 live, lives = f4 lives, lives' = f5 lives', dead = f6 dead, deads = f7 deads, 650 map = f8 map, sets = f9 sets, bd = f10 bd, 651 axioms = f11 axioms, defs = f12 defs, facts = f13 facts, 652 nwits = f14 nwits, wits = f15 wits, rel = f16 rel, pred = f17 pred}; 653 654fun morph_bnf phi = 655 let 656 val Tphi = Morphism.typ phi; 657 val tphi = Morphism.term phi; 658 in 659 map_bnf (Morphism.binding phi) Tphi I (map Tphi) (map Tphi) I (map Tphi) tphi (map tphi) tphi 660 (morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi tphi 661 end; 662 663fun 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; 664 665fun permute_deads perm = map_bnf I I I I I I perm I I I I I I I I I I; 666 667val transfer_bnf = morph_bnf o Morphism.transfer_morphism; 668 669structure Data = Generic_Data 670( 671 type T = bnf Symtab.table; 672 val empty = Symtab.empty; 673 val extend = I; 674 fun merge data : T = Symtab.merge (K true) data; 675); 676 677fun bnf_of_generic context = 678 Option.map (transfer_bnf (Context.theory_of context)) o Symtab.lookup (Data.get context); 679 680val bnf_of = bnf_of_generic o Context.Proof; 681val bnf_of_global = bnf_of_generic o Context.Theory; 682 683 684(* Utilities *) 685 686fun normalize_set insts instA set = 687 let 688 val (T, T') = dest_funT (fastype_of set); 689 val A = fst (Term.dest_TVar (HOLogic.dest_setT T')); 690 val params = Term.add_tvar_namesT T []; 691 in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end; 692 693fun normalize_rel ctxt instTs instA instB rel = 694 let 695 val thy = Proof_Context.theory_of ctxt; 696 val tyenv = 697 Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB)) 698 Vartab.empty; 699 in Envir.subst_term (tyenv, Vartab.empty) rel end 700 handle Type.TYPE_MATCH => error "Bad relator"; 701 702fun 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 711fun normalize_wit insts CA As wit = 712 let 713 fun strip_param (Ts, T as Type (\<^type_name>\<open>fun\<close>, [T1, T2])) = 714 if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2) 715 | strip_param x = x; 716 val (Ts, T) = strip_param ([], fastype_of wit); 717 val subst = Term.add_tvar_namesT T [] ~~ insts; 718 fun find y = find_index (fn x => x = y) As; 719 in 720 (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit) 721 end; 722 723fun minimize_wits wits = 724 let 725 fun minimize done [] = done 726 | minimize done ((I, wit) :: todo) = 727 if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo) 728 then minimize done todo 729 else minimize ((I, wit) :: done) todo; 730 in minimize [] wits end; 731 732fun 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 737fun mk_pred Ts t = 738 let val Type (_, Ts0) = domain_type (body_fun_type (fastype_of t)) in 739 Term.subst_atomic_types (Ts0 ~~ Ts) t 740 end; 741val mk_set = mk_pred; 742 743fun 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 748fun build_map_or_rel mk const of_bnf dest pre_cst_table ctxt simple_Ts simple_Us build_simple = 749 let 750 fun build (TU as (T, U)) = 751 if exists (curry (op =) T) simple_Ts orelse exists (curry (op =) U) simple_Us then 752 build_simple TU 753 else if T = U andalso not (exists_subtype_in simple_Ts T) andalso 754 not (exists_subtype_in simple_Us U) then 755 const T 756 else 757 (case TU of 758 (Type (s, Ts), Type (s', Us)) => 759 if s = s' then 760 let 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 774 else 775 build_simple TU 776 | _ => build_simple TU); 777 in build end; 778 779val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT 780 [(\<^type_name>\<open>set\<close>, (1, \<^term>\<open>image\<close>))]; 781val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T o append 782 [(\<^type_name>\<open>set\<close>, (1, \<^term>\<open>rel_set\<close>)), (\<^type_name>\<open>fun\<close>, (2, \<^term>\<open>rel_fun\<close>))]; 783 784fun 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 = 799 let val Type (\<^type_name>\<open>set\<close>, [elemT]) = fastype_of set_app in 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 [] 804 else Library.foldl1 mk_union (map recurse set_apps) 805 end 806 | _ => HOLogic.mk_set A [])); 807 in build end; 808 809fun map_flattened_map_args ctxt s map_args fs = 810 let 811 val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs; 812 val flat_fs' = map_args flat_fs; 813 in 814 permute_like_unique (op aconv) flat_fs fs flat_fs' 815 end; 816 817 818(* Names *) 819 820val mapN = "map"; 821val setN = "set"; 822fun mk_setN i = setN ^ nonzero_string_of_int i; 823val bdN = "bd"; 824val witN = "wit"; 825fun mk_witN i = witN ^ nonzero_string_of_int i; 826val relN = "rel"; 827val predN = "pred"; 828 829val bd_Card_orderN = "bd_Card_order"; 830val bd_CinfiniteN = "bd_Cinfinite"; 831val bd_CnotzeroN = "bd_Cnotzero"; 832val bd_card_orderN = "bd_card_order"; 833val bd_cinfiniteN = "bd_cinfinite"; 834val collect_set_mapN = "collect_set_map"; 835val in_bdN = "in_bd"; 836val in_monoN = "in_mono"; 837val in_relN = "in_rel"; 838val inj_mapN = "inj_map"; 839val inj_map_strongN = "inj_map_strong"; 840val map_comp0N = "map_comp0"; 841val map_compN = "map_comp"; 842val map_cong0N = "map_cong0"; 843val map_congN = "map_cong"; 844val map_cong_simpN = "map_cong_simp"; 845val map_cong_predN = "map_cong_pred"; 846val map_id0N = "map_id0"; 847val map_idN = "map_id"; 848val map_identN = "map_ident"; 849val map_transferN = "map_transfer"; 850val pred_mono_strong0N = "pred_mono_strong0"; 851val pred_mono_strongN = "pred_mono_strong"; 852val pred_monoN = "pred_mono"; 853val pred_transferN = "pred_transfer"; 854val pred_TrueN = "pred_True"; 855val pred_mapN = "pred_map"; 856val pred_relN = "pred_rel"; 857val pred_setN = "pred_set"; 858val pred_congN = "pred_cong"; 859val pred_cong_simpN = "pred_cong_simp"; 860val rel_GrpN = "rel_Grp"; 861val rel_comppN = "rel_compp"; 862val rel_compp_GrpN = "rel_compp_Grp"; 863val rel_congN = "rel_cong"; 864val rel_cong_simpN = "rel_cong_simp"; 865val rel_conversepN = "rel_conversep"; 866val rel_eqN = "rel_eq"; 867val rel_eq_onpN = "rel_eq_onp"; 868val rel_flipN = "rel_flip"; 869val rel_mapN = "rel_map"; 870val rel_monoN = "rel_mono"; 871val rel_mono_strong0N = "rel_mono_strong0"; 872val rel_mono_strongN = "rel_mono_strong"; 873val rel_reflN = "rel_refl"; 874val rel_refl_strongN = "rel_refl_strong"; 875val rel_reflpN = "rel_reflp"; 876val rel_sympN = "rel_symp"; 877val rel_transferN = "rel_transfer"; 878val rel_transpN = "rel_transp"; 879val set_bdN = "set_bd"; 880val set_map0N = "set_map0"; 881val set_mapN = "set_map"; 882val set_transferN = "set_transfer"; 883 884datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline; 885 886datatype fact_policy = Dont_Note | Note_Some | Note_All; 887 888val bnf_internals = Attrib.setup_config_bool \<^binding>\<open>bnf_internals\<close> (K false); 889val bnf_timing = Attrib.setup_config_bool \<^binding>\<open>bnf_timing\<close> (K false); 890 891fun user_policy policy ctxt = if Config.get ctxt bnf_internals then Note_All else policy; 892 893val smart_max_inline_term_size = 25; (*FUDGE*) 894 895fun note_bnf_thms fact_policy qualify0 bnf_b bnf lthy = 896 let 897 val axioms = axioms_of_bnf bnf; 898 val facts = facts_of_bnf bnf; 899 val wits = wits_of_bnf bnf; 900 val qualify = 901 let val qs = Binding.path_of bnf_b; 902 in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify0 end; 903 904 fun note_if_note_all (noted0, lthy0) = 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]), 909 (bd_cinfiniteN, [#bd_cinfinite axioms]), 910 (bd_Card_orderN, [#bd_Card_order facts]), 911 (bd_CinfiniteN, [#bd_Cinfinite facts]), 912 (bd_CnotzeroN, [#bd_Cnotzero facts]), 913 (collect_set_mapN, [Lazy.force (#collect_set_map facts)]), 914 (in_bdN, [Lazy.force (#in_bd facts)]), 915 (in_monoN, [Lazy.force (#in_mono facts)]), 916 (map_comp0N, [#map_comp0 axioms]), 917 (rel_mono_strong0N, [Lazy.force (#rel_mono_strong0 facts)]), 918 (pred_mono_strong0N, [Lazy.force (#pred_mono_strong0 facts)]), 919 (set_map0N, #set_map0 axioms), 920 (set_bdN, #set_bd axioms)] @ 921 (witNs ~~ wit_thmss_of_bnf bnf) 922 |> map (fn (thmN, thms) => 923 ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []), 924 [(thms, [])])); 925 in 926 Local_Theory.notes notes lthy0 |>> append noted0 927 end; 928 929 fun note_unless_dont_note (noted0, lthy0) = 930 let 931 val notes = 932 [(in_relN, [Lazy.force (#in_rel facts)], []), 933 (inj_mapN, [Lazy.force (#inj_map facts)], []), 934 (inj_map_strongN, [Lazy.force (#inj_map_strong facts)], []), 935 (map_compN, [Lazy.force (#map_comp facts)], []), 936 (map_cong0N, [#map_cong0 axioms], []), 937 (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs), 938 (map_cong_simpN, [Lazy.force (#map_cong_simp facts)], []), 939 (map_cong_predN, [Lazy.force (#map_cong_pred facts)], []), 940 (map_idN, [Lazy.force (#map_id facts)], []), 941 (map_id0N, [#map_id0 axioms], []), 942 (map_transferN, [Lazy.force (#map_transfer facts)], []), 943 (map_identN, [Lazy.force (#map_ident facts)], []), 944 (pred_mono_strongN, [Lazy.force (#pred_mono_strong facts)], []), 945 (pred_monoN, [Lazy.force (#pred_mono facts)], []), 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)], []), 950 (pred_transferN, [Lazy.force (#pred_transfer facts)], []), 951 (pred_TrueN, [Lazy.force (#pred_True facts)], []), 952 (pred_setN, [#pred_set axioms], []), 953 (rel_comppN, [Lazy.force (#rel_OO facts)], []), 954 (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []), 955 (rel_conversepN, [Lazy.force (#rel_conversep facts)], []), 956 (rel_eqN, [Lazy.force (#rel_eq facts)], []), 957 (rel_eq_onpN, [Lazy.force (#rel_eq_onp facts)], []), 958 (rel_flipN, [Lazy.force (#rel_flip facts)], []), 959 (rel_GrpN, [Lazy.force (#rel_Grp facts)], []), 960 (rel_mapN, Lazy.force (#rel_map facts), []), 961 (rel_monoN, [Lazy.force (#rel_mono facts)], mono_attrs), 962 (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)], []), 963 (rel_congN, [Lazy.force (#rel_cong facts)], fundefcong_attrs), 964 (rel_cong_simpN, [Lazy.force (#rel_cong_simp facts)], []), 965 (rel_reflN, [Lazy.force (#rel_refl facts)], []), 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)], []), 970 (rel_transferN, [Lazy.force (#rel_transfer facts)], []), 971 (set_mapN, map Lazy.force (#set_map facts), []), 972 (set_transferN, Lazy.force (#set_transfer facts), [])] 973 |> filter_out (null o #2) 974 |> map (fn (thmN, thms, attrs) => 975 ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), attrs), 976 [(thms, [])])); 977 in 978 Local_Theory.notes notes lthy0 |>> append noted0 979 end; 980 in 981 ([], lthy) 982 |> fact_policy = Note_All ? note_if_note_all 983 |> fact_policy <> Dont_Note ? note_unless_dont_note 984 |>> (fn [] => bnf | noted => morph_bnf (substitute_noted_thm noted) bnf) 985 end; 986 987fun note_bnf_defs bnf lthy = 988 let 989 fun mk_def_binding cst_of = 990 Thm.def_binding (Binding.qualified_name (dest_Const (cst_of bnf) |> fst)); 991 val notes = 992 [(mk_def_binding map_of_bnf, map_def_of_bnf bnf), 993 (mk_def_binding rel_of_bnf, rel_def_of_bnf bnf), 994 (mk_def_binding pred_of_bnf, pred_def_of_bnf bnf)] @ 995 @{map 2} (pair o mk_def_binding o K) (sets_of_bnf bnf) (set_defs_of_bnf bnf) 996 |> map (fn (b, thm) => ((b, []), [([thm], [])])); 997 in 998 lthy 999 |> Local_Theory.notes notes 1000 |>> (fn noted => morph_bnf (substitute_noted_thm noted) bnf) 1001 end; 1002 1003fun mk_wit_goals zs bs sets (I, wit) = 1004 let 1005 val xs = map (nth bs) I; 1006 fun wit_goal i = 1007 let 1008 val z = nth zs i; 1009 val set_wit = nth sets i $ Term.list_comb (wit, xs); 1010 val concl = HOLogic.mk_Trueprop 1011 (if member (op =) I i then HOLogic.mk_eq (z, nth bs i) else \<^term>\<open>False\<close>); 1012 in 1013 fold_rev Logic.all (z :: xs) (Logic.mk_implies (mk_Trueprop_mem (z, set_wit), concl)) 1014 end; 1015 in 1016 map wit_goal (0 upto length sets - 1) 1017 end; 1018 1019 1020(* Define new BNFs *) 1021 1022fun 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 = 1025 let 1026 val live = length set_rhss; 1027 1028 val def_qualify = Binding.qualify false (Binding.name_of bnf_b); 1029 1030 fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b; 1031 1032 fun maybe_define user_specified (b, rhs) lthy = 1033 let 1034 val inline = 1035 (user_specified orelse fact_policy = Dont_Note) andalso 1036 (case const_policy of 1037 Dont_Inline => false 1038 | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs 1039 | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_term_size 1040 | Do_Inline => true); 1041 in 1042 if inline then 1043 ((rhs, Drule.reflexive_thm), lthy) 1044 else 1045 let val b = b () in 1046 apfst (apsnd snd) 1047 ((if internal then Local_Theory.define_internal else Local_Theory.define) 1048 ((b, NoSyn), ((Binding.concealed (Thm.def_binding b), []), rhs)) lthy) 1049 end 1050 end; 1051 1052 val map_bind_def = 1053 (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b), 1054 map_rhs); 1055 val set_binds_defs = 1056 let 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 1060 | NONE => get_b) #> def_qualify; 1061 val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)] 1062 else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live); 1063 in bs ~~ set_rhss end; 1064 val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs); 1065 1066 val ((((bnf_map_term, raw_map_def), 1067 (bnf_set_terms, raw_set_defs)), 1068 (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) = 1069 no_defs_lthy 1070 |> Local_Theory.open_target |> snd 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 1074 ||> `Local_Theory.close_target; 1075 1076 val phi = Proof_Context.export_morphism lthy_old lthy; 1077 1078 val bnf_map_def = Morphism.thm phi raw_map_def; 1079 val bnf_set_defs = map (Morphism.thm phi) raw_set_defs; 1080 val bnf_bd_def = Morphism.thm phi raw_bd_def; 1081 1082 val bnf_map = Morphism.term phi bnf_map_term; 1083 1084 (*TODO: handle errors*) 1085 (*simple shape analysis of a map function*) 1086 val ((alphas, betas), (Calpha, _)) = 1087 fastype_of bnf_map 1088 |> strip_typeN live 1089 |>> map_split dest_funT 1090 ||> dest_funT 1091 handle TYPE _ => error "Bad map function"; 1092 1093 val Calpha_params = map TVar (Term.add_tvarsT Calpha []); 1094 1095 val bnf_T = Morphism.typ phi T_rhs; 1096 val bad_args = Term.add_tfreesT bnf_T []; 1097 val _ = null bad_args orelse error ("Locally fixed type arguments " ^ 1098 commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args)); 1099 1100 val bnf_sets = 1101 map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms); 1102 val bnf_bd = 1103 Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params) 1104 (Morphism.term phi bnf_bd_term); 1105 1106 (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*) 1107 val deads = (case Ds_opt of 1108 NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map [])) 1109 | SOME Ds => map (Morphism.typ phi) Ds); 1110 1111 (*TODO: further checks of type of bnf_map*) 1112 (*TODO: check types of bnf_sets*) 1113 (*TODO: check type of bnf_bd*) 1114 (*TODO: check type of bnf_rel*) 1115 1116 fun mk_bnf_map Ds As' Bs' = 1117 Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map; 1118 fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As')); 1119 fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As')); 1120 1121 val (((As, Bs), unsorted_Ds), names_lthy) = lthy 1122 |> mk_TFrees live 1123 ||>> mk_TFrees live 1124 ||>> mk_TFrees (length deads); 1125 1126 val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds; 1127 1128 val RTs = map2 (curry HOLogic.mk_prodT) As Bs; 1129 val pred2RTs = map2 mk_pred2T As Bs; 1130 val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst; 1131 val CA = mk_bnf_T Ds As Calpha; 1132 val CR = mk_bnf_T Ds RTs Calpha; 1133 val setRs = 1134 @{map 3} (fn R => fn T => fn U => 1135 HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_case_prod R) Rs As Bs; 1136 1137 (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO 1138 Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*) 1139 val rel_spec = 1140 let 1141 val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs); 1142 val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs); 1143 val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR; 1144 in 1145 mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2) 1146 |> fold_rev Term.absfree Rs' 1147 end; 1148 1149 val rel_rhs = the_default rel_spec rel_rhs_opt; 1150 1151 val rel_bind_def = 1152 (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b), 1153 rel_rhs); 1154 1155 val pred_spec = 1156 if live = 0 then Term.absdummy (mk_bnf_T Ds As Calpha) \<^term>\<open>True\<close> else 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 1177 val wit_rhss = 1178 if null wit_rhss then 1179 [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As, 1180 map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $ 1181 Const (\<^const_name>\<open>undefined\<close>, CA))] 1182 else wit_rhss; 1183 val nwits = length wit_rhss; 1184 val wit_binds_defs = 1185 let 1186 val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)] 1187 else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits); 1188 in bs ~~ wit_rhss end; 1189 1190 val ((((bnf_rel_term, raw_rel_def), (bnf_pred_term, raw_pred_def)), 1191 (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) = 1192 lthy 1193 |> Local_Theory.open_target |> snd 1194 |> maybe_define (is_some rel_rhs_opt) rel_bind_def 1195 ||>> maybe_define (is_some pred_rhs_opt) pred_bind_def 1196 ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs 1197 ||> `Local_Theory.close_target; 1198 1199 val phi = Proof_Context.export_morphism lthy_old lthy; 1200 val bnf_rel_def = Morphism.thm phi raw_rel_def; 1201 val bnf_rel = Morphism.term phi bnf_rel_term; 1202 fun mk_bnf_rel Ds As' Bs' = 1203 normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha) 1204 bnf_rel; 1205 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 1211 val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs; 1212 val bnf_wits = 1213 map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms; 1214 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; 1220 in 1221 (((alphas, betas, deads, Calpha), 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) 1225 end; 1226 1227fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term Ds_opt map_b rel_b 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 = 1230 let 1231 val fact_policy = mk_fact_policy no_defs_lthy; 1232 val bnf_b = qualify raw_bnf_b; 1233 val live = length raw_sets; 1234 1235 val T_rhs = prep_typ no_defs_lthy raw_bnf_T; 1236 val map_rhs = prep_term no_defs_lthy raw_map; 1237 val set_rhss = map (prep_term no_defs_lthy) raw_sets; 1238 val bd_rhs = prep_term no_defs_lthy raw_bd; 1239 val wit_rhss = map (prep_term no_defs_lthy) raw_wits; 1240 val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt; 1241 val pred_rhs_opt = Option.map (prep_term no_defs_lthy) raw_pred_opt; 1242 1243 fun err T = 1244 error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^ 1245 " as unnamed BNF"); 1246 1247 val (bnf_b, key) = 1248 if Binding.is_empty bnf_b then 1249 (case T_rhs of 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 1255 | T => err T) 1256 else 1257 (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b); 1258 1259 val (((alphas, betas, deads, Calpha), 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; 1266 1267 val dead = length deads; 1268 1269 val (((((((As', Bs'), Cs), unsorted_Ds), Es), B1Ts), B2Ts), (Ts, T)) = lthy 1270 |> mk_TFrees live 1271 ||>> mk_TFrees live 1272 ||>> mk_TFrees live 1273 ||>> mk_TFrees dead 1274 ||>> mk_TFrees live 1275 ||>> mk_TFrees live 1276 ||>> mk_TFrees live 1277 ||> fst o mk_TFrees 1 1278 ||> the_single 1279 ||> `(replicate live); 1280 1281 val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds; 1282 1283 val mk_bnf_map = mk_bnf_map_Ds Ds; 1284 val mk_bnf_t = mk_bnf_t_Ds Ds; 1285 val mk_bnf_T = mk_bnf_T_Ds Ds; 1286 1287 val pred1PTs = map mk_pred1T As'; 1288 val pred1QTs = map mk_pred1T Bs'; 1289 val pred2RTs = map2 mk_pred2T As' Bs'; 1290 val pred2RTsAsCs = map2 mk_pred2T As' Cs; 1291 val pred2RTsBsCs = map2 mk_pred2T Bs' Cs; 1292 val pred2RTsBsEs = map2 mk_pred2T Bs' Es; 1293 val pred2RTsCsBs = map2 mk_pred2T Cs Bs'; 1294 val pred2RTsCsEs = map2 mk_pred2T Cs Es; 1295 val pred2RT's = map2 mk_pred2T Bs' As'; 1296 val self_pred2RTs = map2 mk_pred2T As' As'; 1297 val transfer_domRTs = map2 mk_pred2T As' B1Ts; 1298 val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts; 1299 1300 val CA' = mk_bnf_T As' Calpha; 1301 val CB' = mk_bnf_T Bs' Calpha; 1302 val CC' = mk_bnf_T Cs Calpha; 1303 val CE' = mk_bnf_T Es Calpha; 1304 val CB1 = mk_bnf_T B1Ts Calpha; 1305 val CB2 = mk_bnf_T B2Ts Calpha; 1306 1307 val bnf_map_AsAs = mk_bnf_map As' As'; 1308 val bnf_map_AsBs = mk_bnf_map As' Bs'; 1309 val bnf_map_AsCs = mk_bnf_map As' Cs; 1310 val bnf_map_BsCs = mk_bnf_map Bs' Cs; 1311 val bnf_sets_As = map (mk_bnf_t As') bnf_sets; 1312 val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets; 1313 val bnf_bd_As = mk_bnf_t As' bnf_bd; 1314 fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel; 1315 fun mk_bnf_pred PTs CA = normalize_pred lthy PTs CA bnf_pred; 1316 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 1320 |> mk_Frees "f" (map2 (curry op -->) As' Bs') 1321 ||>> mk_Frees "f" (map2 (curry op -->) As' Bs') 1322 ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs) 1323 ||>> mk_Frees "h" (map2 (curry op -->) As' Ts) 1324 ||>> mk_Frees "i" (map2 (curry op -->) As' Cs) 1325 ||>> yield_singleton (mk_Frees "x") CA' 1326 ||>> yield_singleton (mk_Frees "x") CA' 1327 ||>> yield_singleton (mk_Frees "y") CB' 1328 ||>> yield_singleton (mk_Frees "y") CB' 1329 ||>> mk_Frees "z" As' 1330 ||>> mk_Frees "z" As' 1331 ||>> mk_Frees "y" Bs' 1332 ||>> mk_Frees "A" (map HOLogic.mk_setT As') 1333 ||>> mk_Frees "A" (map HOLogic.mk_setT As') 1334 ||>> mk_Frees "b" As' 1335 ||>> mk_Frees' "P" pred1PTs 1336 ||>> mk_Frees "P" pred1PTs 1337 ||>> mk_Frees "Q" pred1QTs 1338 ||>> mk_Frees "R" pred2RTs 1339 ||>> mk_Frees "R" pred2RTs 1340 ||>> mk_Frees "S" pred2RTsBsCs 1341 ||>> mk_Frees "S" pred2RTsAsCs 1342 ||>> mk_Frees "S" pred2RTsCsBs 1343 ||>> mk_Frees "S" pred2RTsBsEs 1344 ||>> mk_Frees "R" transfer_domRTs 1345 ||>> mk_Frees "S" transfer_ranRTs; 1346 1347 val fs_copy = map2 (retype_const_or_free o fastype_of) fs gs; 1348 val x_copy = retype_const_or_free CA' y'; 1349 val y_copy = retype_const_or_free CB' x'; 1350 1351 val rel = mk_bnf_rel pred2RTs CA' CB'; 1352 val pred = mk_bnf_pred pred1PTs CA'; 1353 val pred' = mk_bnf_pred pred1QTs CB'; 1354 val relCsEs = mk_bnf_rel pred2RTsCsEs CC' CE'; 1355 val relAsAs = mk_bnf_rel self_pred2RTs CA' CA'; 1356 val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits; 1357 1358 val map_id0_goal = 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') 1361 end; 1362 1363 val map_comp0_goal = 1364 let 1365 val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs); 1366 val comp_bnf_map_app = HOLogic.mk_comp 1367 (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs)); 1368 in 1369 fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app)) 1370 end; 1371 1372 fun mk_map_cong_prem mk_implies x z set f f_copy = 1373 Logic.all z (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (f $ z, f_copy $ z))); 1374 1375 val map_cong0_goal = 1376 let 1377 val prems = @{map 4} (mk_map_cong_prem Logic.mk_implies x) zs bnf_sets_As fs fs_copy; 1378 val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x, 1379 Term.list_comb (bnf_map_AsBs, fs_copy) $ x); 1380 in 1381 fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq)) 1382 end; 1383 1384 val set_map0s_goal = 1385 let 1386 fun mk_goal setA setB f = 1387 let 1388 val set_comp_map = HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs)); 1389 val image_comp_set = HOLogic.mk_comp (mk_image f, setA); 1390 in 1391 fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set)) 1392 end; 1393 in 1394 @{map 3} mk_goal bnf_sets_As bnf_sets_Bs fs 1395 end; 1396 1397 val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As); 1398 1399 val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As); 1400 1401 val set_bds_goal = 1402 let 1403 fun mk_goal set = 1404 Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As)); 1405 in 1406 map mk_goal bnf_sets_As 1407 end; 1408 1409 val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC'; 1410 val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC'; 1411 val relCsBs = mk_bnf_rel pred2RTsCsBs CC' CB'; 1412 val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss); 1413 val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss)); 1414 val le_rel_OO_goal = 1415 fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs)); 1416 1417 val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs), 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))); 1422 1423 val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal 1424 card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal pred_set_goal; 1425 1426 val mk_wit_goals = mk_wit_goals bs zs bnf_sets_As; 1427 fun triv_wit_tac ctxt = mk_trivial_wit_tac ctxt bnf_wit_defs; 1428 1429 val wit_goalss = 1430 (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As); 1431 1432 fun after_qed mk_wit_thms thms lthy = 1433 let 1434 val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms); 1435 1436 val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]}; 1437 val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order]; 1438 val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero}; 1439 1440 fun mk_collect_set_map () = 1441 let 1442 val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T; 1443 val collect_map = HOLogic.mk_comp (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT, 1444 Term.list_comb (mk_bnf_map As' Ts, hs)); 1445 val image_collect = mk_collect 1446 (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As) defT; 1447 (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*) 1448 val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect)); 1449 in 1450 Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => 1451 mk_collect_set_map_tac ctxt (#set_map0 axioms)) 1452 |> Thm.close_derivation \<^here> 1453 end; 1454 1455 val collect_set_map = Lazy.lazy mk_collect_set_map; 1456 1457 fun mk_in_mono () = 1458 let 1459 val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy; 1460 val in_mono_goal = 1461 fold_rev Logic.all (As @ As_copy) 1462 (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop 1463 (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA')))); 1464 in 1465 Goal.prove_sorry lthy [] [] in_mono_goal (fn {context = ctxt, prems = _} => 1466 mk_in_mono_tac ctxt live) 1467 |> Thm.close_derivation \<^here> 1468 end; 1469 1470 val in_mono = Lazy.lazy mk_in_mono; 1471 1472 fun mk_in_cong () = 1473 let 1474 val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy; 1475 val in_cong_goal = 1476 fold_rev Logic.all (As @ As_copy) 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'))); 1479 in 1480 Goal.prove_sorry lthy [] [] in_cong_goal 1481 (fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1) 1482 |> Thm.close_derivation \<^here> 1483 end; 1484 1485 val in_cong = Lazy.lazy mk_in_cong; 1486 1487 val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms)); 1488 val map_ident0 = Lazy.lazy (fn () => mk_map_ident lthy (#map_id0 axioms)); 1489 val map_ident = Lazy.lazy (fn () => mk_map_ident lthy (Lazy.force map_id)); 1490 val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms)); 1491 1492 fun mk_map_cong mk_implies () = 1493 let 1494 val prem0 = mk_Trueprop_eq (x, x_copy); 1495 val prems = @{map 4} (mk_map_cong_prem mk_implies x_copy) zs bnf_sets_As fs fs_copy; 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 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)) 1504 |> Thm.close_derivation \<^here> 1505 end; 1506 1507 val map_cong = Lazy.lazy (mk_map_cong Logic.mk_implies); 1508 val map_cong_simp = Lazy.lazy (mk_map_cong (fn (a, b) => \<^term>\<open>simp_implies\<close> $ a $ b)); 1509 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 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)) 1519 |> Thm.close_derivation \<^here> 1520 end; 1521 1522 val inj_map = Lazy.lazy mk_inj_map; 1523 1524 val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms); 1525 1526 val wit_thms = 1527 if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms; 1528 1529 fun mk_in_bd () = 1530 let 1531 val bdT = fst (dest_relT (fastype_of bnf_bd_As)); 1532 val bdTs = replicate live bdT; 1533 val bd_bnfT = mk_bnf_T bdTs Calpha; 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; 1538 val ran_bnfT = mk_bnf_T ranTs Calpha; 1539 val (revTs, Ts) = `rev (bd_bnfT :: funTs); 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)); 1546 val cts = [NONE, SOME (Thm.cterm_of lthy tinst)]; 1547 in 1548 Thm.instantiate' cTs cts @{thm surj_imp_ordLeq} 1549 end); 1550 val bd = mk_cexp 1551 (if live = 0 then ctwo 1552 else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo) 1553 (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT))); 1554 val in_bd_goal = 1555 fold_rev Logic.all As 1556 (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd)); 1557 in 1558 Goal.prove_sorry lthy [] [] in_bd_goal 1559 (fn {context = ctxt, prems = _} => mk_in_bd_tac ctxt live surj_imp_ordLeq_inst 1560 (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms) 1561 (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms) 1562 bd_Card_order bd_Cinfinite bd_Cnotzero) 1563 |> Thm.close_derivation \<^here> 1564 end; 1565 1566 val in_bd = Lazy.lazy mk_in_bd; 1567 1568 val rel_OO_Grp = #rel_OO_Grp axioms; 1569 val rel_OO_Grps = no_refl [rel_OO_Grp]; 1570 1571 fun mk_rel_Grp () = 1572 let 1573 val lhs = Term.list_comb (rel, map2 mk_Grp As fs); 1574 val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs)); 1575 val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs)); 1576 in 1577 Goal.prove_sorry lthy [] [] goal 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)) 1581 |> Thm.close_derivation \<^here> 1582 end; 1583 1584 val rel_Grp = Lazy.lazy mk_rel_Grp; 1585 1586 fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy; 1587 fun mk_rel_concl f = HOLogic.mk_Trueprop 1588 (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy))); 1589 1590 fun mk_rel_mono () = 1591 let 1592 val mono_prems = mk_rel_prems mk_leq; 1593 val mono_concl = mk_rel_concl (uncurry mk_leq); 1594 in 1595 Goal.prove_sorry lthy [] [] 1596 (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl))) 1597 (fn {context = ctxt, prems = _} => 1598 mk_rel_mono_tac ctxt rel_OO_Grps (Lazy.force in_mono)) 1599 |> Thm.close_derivation \<^here> 1600 end; 1601 1602 fun mk_rel_cong0 () = 1603 let 1604 val cong_prems = mk_rel_prems (curry HOLogic.mk_eq); 1605 val cong_concl = mk_rel_concl HOLogic.mk_eq; 1606 in 1607 Goal.prove_sorry lthy [] [] 1608 (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl))) 1609 (fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1) 1610 |> Thm.close_derivation \<^here> 1611 end; 1612 1613 val rel_mono = Lazy.lazy mk_rel_mono; 1614 val rel_cong0 = Lazy.lazy mk_rel_cong0; 1615 1616 fun mk_rel_eq () = 1617 Goal.prove_sorry lthy [] [] 1618 (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'), 1619 HOLogic.eq_const CA')) 1620 (fn {context = ctxt, prems = _} => 1621 mk_rel_eq_tac ctxt live (Lazy.force rel_Grp) (Lazy.force rel_cong0) (#map_id0 axioms)) 1622 |> Thm.close_derivation \<^here>; 1623 1624 val rel_eq = Lazy.lazy mk_rel_eq; 1625 1626 fun mk_rel_conversep () = 1627 let 1628 val relBsAs = mk_bnf_rel pred2RT's CB' CA'; 1629 val lhs = Term.list_comb (relBsAs, map mk_conversep Rs); 1630 val rhs = mk_conversep (Term.list_comb (rel, Rs)); 1631 val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs)); 1632 val le_thm = Goal.prove_sorry lthy [] [] le_goal 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)) 1636 |> Thm.close_derivation \<^here> 1637 val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs)); 1638 in 1639 Goal.prove_sorry lthy [] [] goal 1640 (fn {context = ctxt, prems = _} => 1641 mk_rel_conversep_tac ctxt le_thm (Lazy.force rel_mono)) 1642 |> Thm.close_derivation \<^here> 1643 end; 1644 1645 val rel_conversep = Lazy.lazy mk_rel_conversep; 1646 1647 fun mk_rel_OO () = 1648 Goal.prove_sorry lthy [] [] 1649 (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs))) 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)) 1652 |> Thm.close_derivation \<^here> 1653 |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]); 1654 1655 val rel_OO = Lazy.lazy mk_rel_OO; 1656 1657 fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD}; 1658 1659 val in_rel = Lazy.lazy mk_in_rel; 1660 1661 fun mk_rel_flip () = 1662 unfold_thms lthy @{thms conversep_iff} 1663 (Lazy.force rel_conversep RS @{thm predicate2_eqD}); 1664 1665 val rel_flip = Lazy.lazy mk_rel_flip; 1666 1667 fun mk_rel_mono_strong0 () = 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)))))); 1674 val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) :: 1675 @{map 6} mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys; 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))) 1680 (fn {context = ctxt, prems = _} => mk_rel_mono_strong0_tac ctxt (Lazy.force in_rel) 1681 (map Lazy.force set_map)) 1682 |> Thm.close_derivation \<^here> 1683 end; 1684 1685 val rel_mono_strong0 = Lazy.lazy mk_rel_mono_strong0; 1686 1687 val rel_mono_strong = Lazy.map (Object_Logic.rulify lthy) rel_mono_strong0; 1688 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 1703 fold (Variable.add_free_names lthy) (eq :: prem0 :: prem1 :: prems) [] 1704 |> (fn vars => Goal.prove_sorry lthy vars (prem0 :: prem1 :: prems) eq 1705 (fn {context = ctxt, prems} => 1706 mk_rel_cong_tac ctxt (chop 2 prems) (Lazy.force rel_mono_strong))) 1707 |> Thm.close_derivation \<^here> 1708 end; 1709 1710 val rel_cong = Lazy.lazy (mk_rel_cong Logic.mk_implies); 1711 val rel_cong_simp = Lazy.lazy (mk_rel_cong (fn (a, b) => \<^term>\<open>simp_implies\<close> $ a $ b)); 1712 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) 1725 |> Thm.close_derivation \<^here> 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)) 1738 |> Thm.close_derivation \<^here> 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)) 1757 |> Thm.close_derivation \<^here> 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 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)) 1773 |> Thm.close_derivation \<^here> 1774 end; 1775 1776 val pred_mono = Lazy.lazy mk_pred_mono; 1777 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))) 1793 |> Thm.close_derivation \<^here> 1794 end; 1795 1796 val pred_cong = Lazy.lazy (mk_pred_cong Logic.mk_implies); 1797 val pred_cong_simp = Lazy.lazy (mk_pred_cong (fn (a, b) => \<^term>\<open>simp_implies\<close> $ a $ b)); 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 1814 (etac ctxt @{thm bspec} THEN' assume_tac ctxt)])) 1815 |> Thm.close_derivation \<^here> 1816 end; 1817 1818 val map_cong_pred = Lazy.lazy mk_map_cong_pred; 1819 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 = 1829 [Term.list_comb (rel, @{map 3} (fn f => fn P => fn T => 1830 mk_vimage2p f (HOLogic.id_const T) $ P) is S_CsBs Bs') $ x $ y, 1831 Term.list_comb (rel, @{map 3} (fn f => fn P => fn T => 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 1835 goals 1836 |> map (fn goal => Goal.prove_sorry lthy [] [] goal 1837 (fn {context = ctxt, prems = _} => 1838 mk_rel_map0_tac ctxt live (Lazy.force rel_OO) (Lazy.force rel_conversep) 1839 (Lazy.force rel_Grp) (Lazy.force map_id))) 1840 |> map (unfold_thms lthy @{thms vimage2p_def[of id, simplified id_apply] 1841 vimage2p_def[of _ id, simplified id_apply]}) 1842 |> map (Thm.close_derivation \<^here>) 1843 end; 1844 1845 val rel_map = Lazy.lazy mk_rel_map; 1846 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 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))); 1865 val vars = fold (Variable.add_free_names lthy) (goal :: prems) []; 1866 in 1867 Goal.prove_sorry lthy vars [] (Logic.list_implies (prems, goal)) 1868 (fn {context = ctxt, prems = _} => 1869 unfold_thms_tac ctxt [prop_conv_thm] THEN 1870 HEADGOAL (rtac ctxt (Lazy.force thm RS sym RS @{thm ord_eq_le_trans}) 1871 THEN' rtac ctxt (Lazy.force rel_mono) THEN_ALL_NEW assume_tac ctxt)) 1872 |> Thm.close_derivation \<^here> 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 1879 fun mk_pred_True () = 1880 let 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>; 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]}]))) 1891 |> Thm.close_derivation \<^here> 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 1907 unfold_thms_tac ctxt 1908 (@{thms Ball_image_comp ball_empty} @ map Lazy.force set_map) THEN 1909 HEADGOAL (rtac ctxt refl)) 1910 |> Thm.close_derivation \<^here> 1911 end; 1912 1913 val pred_map = Lazy.lazy mk_pred_map; 1914 1915 fun mk_map_transfer () = 1916 let 1917 val rels = map2 mk_rel_fun transfer_domRs transfer_ranRs; 1918 val rel = mk_rel_fun 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 1922 (fold_rev mk_rel_fun rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts); 1923 in 1924 Goal.prove_sorry lthy [] [] 1925 (fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl) 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)) 1929 |> Thm.close_derivation \<^here> 1930 end; 1931 1932 val map_transfer = Lazy.lazy mk_map_transfer; 1933 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)) 1946 |> Thm.close_derivation \<^here> 1947 end; 1948 1949 val pred_transfer = Lazy.lazy mk_pred_transfer; 1950 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); 1961 val vars = Variable.add_free_names lthy goal []; 1962 in 1963 Goal.prove_sorry lthy vars [] goal 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)) 1967 |> Thm.close_derivation \<^here> 1968 end; 1969 1970 val rel_transfer = Lazy.lazy mk_rel_transfer; 1971 1972 fun mk_set_transfer () = 1973 let 1974 val rel_sets = map2 (fn A => fn B => mk_rel 1 [A] [B] \<^term>\<open>rel_set\<close>) As' Bs'; 1975 val rel_Rs = Term.list_comb (rel, Rs); 1976 val goals = @{map 4} (fn R => fn rel_set => fn setA => fn setB => HOLogic.mk_Trueprop 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 1981 let 1982 val goal = Logic.mk_conjunction_balanced goals; 1983 val vars = Variable.add_free_names lthy goal []; 1984 in 1985 Goal.prove_sorry lthy vars [] goal 1986 (fn {context = ctxt, prems = _} => 1987 mk_set_transfer_tac ctxt (Lazy.force in_rel) (map Lazy.force set_map)) 1988 |> Thm.close_derivation \<^here> 1989 |> Conjunction.elim_balanced (length goals) 1990 end 1991 end; 1992 1993 val set_transfer = Lazy.lazy mk_set_transfer; 1994 1995 fun mk_inj_map_strong () = 1996 let 1997 val assms = @{map 5} (fn setA => fn z => fn f => fn z' => fn f' => 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)) 2014 |> Thm.close_derivation \<^here> 2015 end; 2016 2017 val inj_map_strong = Lazy.lazy mk_inj_map_strong; 2018 2019 val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_pred_def; 2020 2021 val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong 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 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; 2028 2029 val wits = map2 mk_witness bnf_wits wit_thms; 2030 2031 val bnf_rel = 2032 Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel; 2033 2034 val bnf_pred = Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas)) pred; 2035 2036 val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms 2037 defs facts wits bnf_rel bnf_pred; 2038 in 2039 note_bnf_thms fact_policy qualify bnf_b bnf lthy 2040 end; 2041 2042 val one_step_defs = 2043 no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ 2044 [bnf_rel_def, bnf_pred_def]); 2045 in 2046 (key, goals, wit_goalss, after_qed, lthy, one_step_defs) 2047 end; 2048 2049structure BNF_Plugin = Plugin(type T = bnf); 2050 2051fun bnf_interpretation name f = 2052 BNF_Plugin.interpretation name 2053 (fn bnf => fn lthy => f (transfer_bnf (Proof_Context.theory_of lthy) bnf) lthy); 2054 2055val interpret_bnf = BNF_Plugin.data; 2056 2057fun register_bnf_raw key bnf = 2058 Local_Theory.declaration {syntax = false, pervasive = true} 2059 (fn phi => Data.map (Symtab.update (key, morph_bnf phi bnf))); 2060 2061fun register_bnf plugins key bnf = 2062 register_bnf_raw key bnf #> interpret_bnf plugins bnf; 2063 2064fun bnf_def const_policy fact_policy internal qualify tacs wit_tac Ds map_b rel_b pred_b set_bs 2065 raw_csts = 2066 (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) => 2067 let 2068 fun mk_wits_tac ctxt set_maps = 2069 TRYALL Goal.conjunction_tac THEN 2070 (case triv_tac_opt of 2071 SOME tac => tac ctxt set_maps 2072 | NONE => unfold_thms_tac ctxt one_step_defs THEN wit_tac ctxt); 2073 val wit_goals = map Logic.mk_conjunction_balanced wit_goalss; 2074 fun mk_wit_thms set_maps = 2075 Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) 2076 (fn {context = ctxt, prems = _} => mk_wits_tac ctxt set_maps) 2077 |> Thm.close_derivation \<^here> 2078 |> Conjunction.elim_balanced (length wit_goals) 2079 |> map2 (Conjunction.elim_balanced o length) wit_goalss 2080 |> (map o map) (Thm.forall_elim_vars 0); 2081 in 2082 map2 (Thm.close_derivation \<^here> oo Goal.prove_sorry lthy [] []) 2083 goals (map (fn tac => fn {context = ctxt, prems = _} => 2084 unfold_thms_tac ctxt one_step_defs THEN tac ctxt) tacs) 2085 |> (fn thms => after_qed mk_wit_thms (map single thms) lthy) 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; 2088 2089fun bnf_cmd (raw_csts, raw_plugins) = 2090 (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) => 2091 let 2092 val plugins = raw_plugins lthy; 2093 val wit_goals = map Logic.mk_conjunction_balanced wit_goalss; 2094 fun mk_triv_wit_thms tac set_maps = 2095 Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) 2096 (fn {context = ctxt, prems = _} => TRYALL Goal.conjunction_tac THEN tac ctxt set_maps) 2097 |> Thm.close_derivation \<^here> 2098 |> Conjunction.elim_balanced (length wit_goals) 2099 |> map2 (Conjunction.elim_balanced o length) wit_goalss 2100 |> (map o map) (Thm.forall_elim_vars 0); 2101 val (mk_wit_thms, nontriv_wit_goals) = 2102 (case triv_tac_opt of 2103 NONE => (fn _ => [], map (map (rpair [])) wit_goalss) 2104 | SOME tac => (mk_triv_wit_thms tac, [])); 2105 in 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)))) 2112 end) o prepare_def Do_Inline (user_policy Note_Some) false I Syntax.read_typ Syntax.read_term 2113 NONE Binding.empty Binding.empty Binding.empty [] raw_csts; 2114 2115fun print_bnfs ctxt = 2116 let 2117 fun pretty_set sets i = Pretty.block 2118 [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1, 2119 Pretty.quote (Syntax.pretty_term ctxt (nth sets i))]; 2120 2121 fun pretty_bnf (key, BNF {T, map, sets, bd, live, lives, dead, deads, ...}) = 2122 Pretty.big_list 2123 (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1, 2124 Pretty.quote (Syntax.pretty_typ ctxt T)])) 2125 ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live), 2126 Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)], 2127 Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead), 2128 Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)], 2129 Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1, 2130 Pretty.quote (Syntax.pretty_term ctxt map)]] @ 2131 List.map (pretty_set sets) (0 upto length sets - 1) @ 2132 [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1, 2133 Pretty.quote (Syntax.pretty_term ctxt bd)]]); 2134 in 2135 Pretty.big_list "Registered bounded natural functors:" 2136 (map pretty_bnf (sort_by fst (Symtab.dest (Data.get (Context.Proof ctxt))))) 2137 |> Pretty.writeln 2138 end; 2139 2140val _ = 2141 Outer_Syntax.command \<^command_keyword>\<open>print_bnfs\<close> 2142 "print all bounded natural functors" 2143 (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of))); 2144 2145val _ = 2146 Outer_Syntax.local_theory_to_proof \<^command_keyword>\<open>bnf\<close> 2147 "register a type as a bounded natural functor" 2148 (parse_opt_binding_colon -- Parse.typ --| 2149 (Parse.reserved "map" -- \<^keyword>\<open>:\<close>) -- Parse.term -- 2150 Scan.optional ((Parse.reserved "sets" -- \<^keyword>\<open>:\<close>) |-- 2151 Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) [] --| 2152 (Parse.reserved "bd" -- \<^keyword>\<open>:\<close>) -- Parse.term -- 2153 Scan.optional ((Parse.reserved "wits" -- \<^keyword>\<open>:\<close>) |-- 2154 Scan.repeat1 (Scan.unless (Parse.reserved "rel" || 2155 Parse.reserved "plugins") Parse.term)) [] -- 2156 Scan.option ((Parse.reserved "rel" -- \<^keyword>\<open>:\<close>) |-- Parse.term) -- 2157 Scan.option ((Parse.reserved "pred" -- \<^keyword>\<open>:\<close>) |-- Parse.term) -- 2158 Scan.optional Plugin_Name.parse_filter (K Plugin_Name.default_filter) 2159 >> bnf_cmd); 2160 2161end; 2162