10 val create_nom_typedecls : string list -> theory -> theory |
10 val create_nom_typedecls : string list -> theory -> theory |
11 type atom_info |
11 type atom_info |
12 val get_atom_infos : theory -> atom_info Symtab.table |
12 val get_atom_infos : theory -> atom_info Symtab.table |
13 val get_atom_info : theory -> string -> atom_info option |
13 val get_atom_info : theory -> string -> atom_info option |
14 val the_atom_info : theory -> string -> atom_info |
14 val the_atom_info : theory -> string -> atom_info |
|
15 val fs_class_of : theory -> string -> string |
|
16 val pt_class_of : theory -> string -> string |
|
17 val cp_class_of : theory -> string -> string -> string |
|
18 val at_inst_of : theory -> string -> thm |
|
19 val pt_inst_of : theory -> string -> thm |
|
20 val cp_inst_of : theory -> string -> string -> thm |
|
21 val dj_thm_of : theory -> string -> string -> thm |
15 val atoms_of : theory -> string list |
22 val atoms_of : theory -> string list |
16 val mk_permT : typ -> typ |
23 val mk_permT : typ -> typ |
17 end |
24 end |
18 |
25 |
19 structure NominalAtoms : NOMINAL_ATOMS = |
26 structure NominalAtoms : NOMINAL_ATOMS = |
28 (* theory data *) |
35 (* theory data *) |
29 |
36 |
30 type atom_info = |
37 type atom_info = |
31 {pt_class : string, |
38 {pt_class : string, |
32 fs_class : string, |
39 fs_class : string, |
33 cp_classes : (string * string) list, |
40 cp_classes : string Symtab.table, |
34 at_inst : thm, |
41 at_inst : thm, |
35 pt_inst : thm, |
42 pt_inst : thm, |
36 dj_thms : thm list}; |
43 cp_inst : thm Symtab.table, |
|
44 dj_thms : thm Symtab.table}; |
37 |
45 |
38 structure NominalData = TheoryDataFun |
46 structure NominalData = TheoryDataFun |
39 ( |
47 ( |
40 type T = atom_info Symtab.table; |
48 type T = atom_info Symtab.table; |
41 val empty = Symtab.empty; |
49 val empty = Symtab.empty; |
42 val copy = I; |
50 val copy = I; |
43 val extend = I; |
51 val extend = I; |
44 fun merge _ x = Symtab.merge (K true) x; |
52 fun merge _ x = Symtab.merge (K true) x; |
45 ); |
53 ); |
46 |
54 |
47 fun make_atom_info (((((pt_class, fs_class), cp_classes), at_inst), pt_inst), dj_thms) = |
55 fun make_atom_info ((((((pt_class, fs_class), cp_classes), at_inst), pt_inst), cp_inst), dj_thms) = |
48 {pt_class = pt_class, |
56 {pt_class = pt_class, |
49 fs_class = fs_class, |
57 fs_class = fs_class, |
50 cp_classes = cp_classes, |
58 cp_classes = cp_classes, |
51 at_inst = at_inst, |
59 at_inst = at_inst, |
52 pt_inst = pt_inst, |
60 pt_inst = pt_inst, |
|
61 cp_inst = cp_inst, |
53 dj_thms = dj_thms}; |
62 dj_thms = dj_thms}; |
54 |
63 |
55 val get_atom_infos = NominalData.get; |
64 val get_atom_infos = NominalData.get; |
56 val get_atom_info = Symtab.lookup o NominalData.get; |
65 val get_atom_info = Symtab.lookup o NominalData.get; |
57 |
66 |
58 fun the_atom_info thy name = (case get_atom_info thy name of |
67 fun gen_lookup lookup name = case lookup name of |
59 SOME info => info |
68 SOME info => info |
60 | NONE => error ("Unknown atom type " ^ quote name)); |
69 | NONE => error ("Unknown atom type " ^ quote name); |
|
70 |
|
71 fun the_atom_info thy = gen_lookup (get_atom_info thy); |
|
72 |
|
73 fun gen_lookup' f thy = the_atom_info thy #> f; |
|
74 fun gen_lookup'' f thy = |
|
75 gen_lookup' (f #> Symtab.lookup #> gen_lookup) thy; |
|
76 |
|
77 val fs_class_of = gen_lookup' #fs_class; |
|
78 val pt_class_of = gen_lookup' #pt_class; |
|
79 val at_inst_of = gen_lookup' #at_inst; |
|
80 val pt_inst_of = gen_lookup' #pt_inst; |
|
81 val cp_class_of = gen_lookup'' #cp_classes; |
|
82 val cp_inst_of = gen_lookup'' #cp_inst; |
|
83 val dj_thm_of = gen_lookup'' #dj_thms; |
61 |
84 |
62 fun atoms_of thy = map fst (Symtab.dest (NominalData.get thy)); |
85 fun atoms_of thy = map fst (Symtab.dest (NominalData.get thy)); |
63 |
86 |
64 fun mk_permT T = HOLogic.listT (HOLogic.mk_prodT (T, T)); |
87 fun mk_permT T = HOLogic.listT (HOLogic.mk_prodT (T, T)); |
65 |
88 |
403 |
426 |
404 val proof = fn _ => EVERY [simp_tac simp_s 1, |
427 val proof = fn _ => EVERY [simp_tac simp_s 1, |
405 rtac allI 1, rtac allI 1, rtac allI 1, |
428 rtac allI 1, rtac allI 1, rtac allI 1, |
406 rtac cp1 1]; |
429 rtac cp1 1]; |
407 in |
430 in |
408 PureThy.add_thms [((name, Goal.prove_global thy' [] [] statement proof), [])] thy' |
431 yield_singleton PureThy.add_thms ((name, |
|
432 Goal.prove_global thy' [] [] statement proof), []) thy' |
409 end) |
433 end) |
410 ak_names_types thy) ak_names_types thy12b; |
434 ak_names_types thy) ak_names_types thy12b; |
411 |
435 |
412 (* proves for every non-trivial <ak>-combination a disjointness *) |
436 (* proves for every non-trivial <ak>-combination a disjointness *) |
413 (* theorem; i.e. <ak1> != <ak2> *) |
437 (* theorem; i.e. <ak1> != <ak2> *) |
958 |
982 |
959 in |
983 in |
960 NominalData.map (fold Symtab.update (full_ak_names ~~ map make_atom_info |
984 NominalData.map (fold Symtab.update (full_ak_names ~~ map make_atom_info |
961 (pt_ax_classes ~~ |
985 (pt_ax_classes ~~ |
962 fs_ax_classes ~~ |
986 fs_ax_classes ~~ |
963 map (fn cls => full_ak_names ~~ cls) cp_ax_classes ~~ |
987 map (fn cls => Symtab.make (full_ak_names ~~ cls)) cp_ax_classes ~~ |
964 prm_cons_thms ~~ prm_inst_thms ~~ |
988 prm_cons_thms ~~ prm_inst_thms ~~ |
965 map flat dj_thms))) thy33 |
989 map (fn ths => Symtab.make (full_ak_names ~~ ths)) cp_thms ~~ |
|
990 map (fn thss => Symtab.make |
|
991 (List.mapPartial (fn (s, [th]) => SOME (s, th) | _ => NONE) |
|
992 (full_ak_names ~~ thss))) dj_thms))) thy33 |
966 end; |
993 end; |
967 |
994 |
968 |
995 |
969 (* syntax und parsing *) |
996 (* syntax und parsing *) |
970 structure P = OuterParse and K = OuterKeyword; |
997 structure P = OuterParse and K = OuterKeyword; |