author | kuncar |
Mon, 23 Apr 2012 17:18:18 +0200 | |
changeset 47698 | 18202d3d5832 |
parent 47566 | c201a1fe0a81 |
child 47937 | 70375fa2679d |
permissions | -rw-r--r-- |
45680 | 1 |
(* Title: HOL/Tools/Quotient/quotient_type.ML |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
2 |
Author: Cezary Kaliszyk and Christian Urban |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
3 |
|
35806
a814cccce0b8
rollback of local typedef until problem with type-variables can be sorted out; fixed header
Christian Urban <urbanc@in.tum.de>
parents:
35790
diff
changeset
|
4 |
Definition of a quotient type. |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
5 |
*) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
6 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
7 |
signature QUOTIENT_TYPE = |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
8 |
sig |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
9 |
val can_generate_code_cert: thm -> bool |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
10 |
|
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
11 |
val add_quotient_type: ((string list * binding * mixfix) * (typ * term * bool) * |
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
12 |
((binding * binding) option)) * thm -> local_theory -> Quotient_Info.quotients * local_theory |
35415
1810b1ade437
export add_quotient_type.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
35351
diff
changeset
|
13 |
|
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
14 |
val quotient_type: ((string list * binding * mixfix) * (typ * term * bool) * |
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
15 |
((binding * binding) option)) list -> Proof.context -> Proof.state |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
16 |
|
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
17 |
val quotient_type_cmd: (((((string list * binding) * mixfix) * string) * (bool * string)) * |
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
18 |
(binding * binding) option) list -> Proof.context -> Proof.state |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
19 |
end; |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
20 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
21 |
structure Quotient_Type: QUOTIENT_TYPE = |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
22 |
struct |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
23 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
24 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
25 |
(*** definition of quotient types ***) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
26 |
|
44204
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
27 |
val mem_def1 = @{lemma "y : Collect S ==> S y" by simp} |
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
28 |
val mem_def2 = @{lemma "S y ==> y : Collect S" by simp} |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
29 |
|
47100 | 30 |
(* constructs the term {c. EX (x::rty). rel x x \<and> c = Collect (rel x)} *) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
31 |
fun typedef_term rel rty lthy = |
41444 | 32 |
let |
33 |
val [x, c] = |
|
34 |
[("x", rty), ("c", HOLogic.mk_setT rty)] |
|
35 |
|> Variable.variant_frees lthy [rel] |
|
36 |
|> map Free |
|
37 |
in |
|
45312 | 38 |
HOLogic.Collect_const (HOLogic.mk_setT rty) $ (lambda c (HOLogic.exists_const rty $ |
44204
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
39 |
lambda x (HOLogic.mk_conj (rel $ x $ x, |
45312 | 40 |
HOLogic.mk_eq (c, HOLogic.Collect_const rty $ (rel $ x)))))) |
41444 | 41 |
end |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
42 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
43 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
44 |
(* makes the new type definitions and proves non-emptyness *) |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
45 |
fun typedef_make (vs, qty_name, mx, rel, rty) equiv_thm lthy = |
41444 | 46 |
let |
47 |
val typedef_tac = |
|
48 |
EVERY1 (map rtac [@{thm part_equivp_typedef}, equiv_thm]) |
|
49 |
in |
|
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
50 |
Typedef.add_typedef false NONE (qty_name, map (rpair dummyS) vs, mx) |
41444 | 51 |
(typedef_term rel rty lthy) NONE typedef_tac lthy |
52 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
53 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
54 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
55 |
(* tactic to prove the quot_type theorem for the new type *) |
35994
9cc3df9a606e
Typedef.info: separate global and local part, only the latter is transformed by morphisms;
wenzelm
parents:
35842
diff
changeset
|
56 |
fun typedef_quot_type_tac equiv_thm ((_, typedef_info): Typedef.info) = |
41444 | 57 |
let |
58 |
val rep_thm = #Rep typedef_info RS mem_def1 |
|
59 |
val rep_inv = #Rep_inverse typedef_info |
|
60 |
val abs_inv = #Abs_inverse typedef_info |
|
61 |
val rep_inj = #Rep_inject typedef_info |
|
62 |
in |
|
63 |
(rtac @{thm quot_type.intro} THEN' RANGE [ |
|
64 |
rtac equiv_thm, |
|
65 |
rtac rep_thm, |
|
66 |
rtac rep_inv, |
|
67 |
rtac abs_inv THEN' rtac mem_def2 THEN' atac, |
|
68 |
rtac rep_inj]) 1 |
|
69 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
70 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
71 |
(* proves the quot_type theorem for the new type *) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
72 |
fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy = |
41444 | 73 |
let |
45317
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
74 |
val quot_type_const = Const (@{const_name "quot_type"}, |
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
75 |
fastype_of rel --> fastype_of abs --> fastype_of rep --> @{typ bool}) |
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
76 |
val goal = HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep) |
41444 | 77 |
in |
78 |
Goal.prove lthy [] [] goal |
|
79 |
(K (typedef_quot_type_tac equiv_thm typedef_info)) |
|
80 |
end |
|
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
81 |
|
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
82 |
fun can_generate_code_cert quot_thm = |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
83 |
case Quotient_Term.get_rel_from_quot_thm quot_thm of |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
84 |
Const (@{const_name HOL.eq}, _) => true |
47308 | 85 |
| Const (@{const_name Lifting.invariant}, _) $ _ => true |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
86 |
| _ => false |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
87 |
|
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
88 |
fun define_abs_type quot_thm lthy = |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
89 |
if can_generate_code_cert quot_thm then |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
90 |
let |
47308 | 91 |
val abs_type_thm = quot_thm RS @{thm Quotient3_abs_rep} |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
92 |
val add_abstype_attribute = |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
93 |
Thm.declaration_attribute (fn thm => Context.mapping (Code.add_abstype thm) I) |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
94 |
val add_abstype_attrib = Attrib.internal (K add_abstype_attribute); |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
95 |
in |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
96 |
lthy |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
97 |
|> (snd oo Local_Theory.note) ((Binding.empty, [add_abstype_attrib]), [abs_type_thm]) |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
98 |
end |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
99 |
else |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
100 |
lthy |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
101 |
|
47698 | 102 |
open Lifting_Util |
47362
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
103 |
|
47698 | 104 |
infix 0 MRSL |
47362
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
105 |
|
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
106 |
fun define_cr_rel equiv_thm abs_fun lthy = |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
107 |
let |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
108 |
fun force_type_of_rel rel forced_ty = |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
109 |
let |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
110 |
val thy = Proof_Context.theory_of lthy |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
111 |
val rel_ty = (domain_type o fastype_of) rel |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
112 |
val ty_inst = Sign.typ_match thy (rel_ty, forced_ty) Vartab.empty |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
113 |
in |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
114 |
Envir.subst_term_types ty_inst rel |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
115 |
end |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
116 |
|
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
117 |
val (rty, qty) = (dest_funT o fastype_of) abs_fun |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
118 |
val abs_fun_graph = HOLogic.mk_eq(abs_fun $ Bound 1, Bound 0) |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
119 |
val Abs_body = (case (HOLogic.dest_Trueprop o prop_of) equiv_thm of |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
120 |
Const (@{const_name equivp}, _) $ _ => abs_fun_graph |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
121 |
| Const (@{const_name part_equivp}, _) $ rel => |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
122 |
HOLogic.mk_conj (force_type_of_rel rel rty $ Bound 1 $ Bound 1, abs_fun_graph) |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
123 |
| _ => error "unsupported equivalence theorem" |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
124 |
) |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
125 |
val def_term = Abs ("x", rty, Abs ("y", qty, Abs_body)); |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
126 |
val qty_name = (fst o dest_Type) qty |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
127 |
val cr_rel_name = Binding.prefix_name "cr_" (Binding.qualified_name qty_name) |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
128 |
val (fixed_def_term, lthy') = yield_singleton (Variable.importT_terms) def_term lthy |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
129 |
val ((_, (_ , def_thm)), lthy'') = |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
130 |
Local_Theory.define ((cr_rel_name, NoSyn), ((Thm.def_binding cr_rel_name, []), fixed_def_term)) lthy' |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
131 |
in |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
132 |
(def_thm, lthy'') |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
133 |
end; |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
134 |
|
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
135 |
fun setup_lifting_package quot3_thm equiv_thm lthy = |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
136 |
let |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
137 |
val (_ $ _ $ abs_fun $ _) = (HOLogic.dest_Trueprop o prop_of) quot3_thm |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
138 |
val (T_def, lthy') = define_cr_rel equiv_thm abs_fun lthy |
47502 | 139 |
val (rty, qty) = (dest_funT o fastype_of) abs_fun |
140 |
val qty_name = (fst o dest_Type) qty |
|
141 |
val quotient_thm_name = Binding.prefix_name "Quotient_" (Binding.qualified_name qty_name) |
|
47521
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
142 |
val (reflp_thm, quot_thm) = (case (HOLogic.dest_Trueprop o prop_of) equiv_thm of |
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
143 |
Const (@{const_name equivp}, _) $ _ => |
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
144 |
(SOME (equiv_thm RS @{thm equivp_reflp2}), |
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
145 |
[quot3_thm, T_def, equiv_thm] MRSL @{thm Quotient3_to_Quotient_equivp}) |
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
146 |
| Const (@{const_name part_equivp}, _) $ _ => |
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
147 |
(NONE, |
69f95ac85c3d
tuned the setup of lifting; generate transfer rules for typedef and Quotient thms
kuncar
parents:
47502
diff
changeset
|
148 |
[quot3_thm, T_def] MRSL @{thm Quotient3_to_Quotient}) |
47362
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
149 |
| _ => error "unsupported equivalence theorem" |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
150 |
) |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
151 |
in |
47502 | 152 |
lthy' |
47566
c201a1fe0a81
setup_lifting: no_code switch and supoport for quotient theorems
kuncar
parents:
47521
diff
changeset
|
153 |
|> Lifting_Setup.setup_by_quotient false quot_thm reflp_thm |
47502 | 154 |
|> (snd oo Local_Theory.note) ((quotient_thm_name, []), [quot_thm]) |
47362
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
155 |
end |
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
156 |
|
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
157 |
fun init_quotient_infr quot_thm equiv_thm lthy = |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
158 |
let |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
159 |
val (_ $ rel $ abs $ rep) = (HOLogic.dest_Trueprop o prop_of) quot_thm |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
160 |
val (qtyp, rtyp) = (dest_funT o fastype_of) rep |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
161 |
val qty_full_name = (fst o dest_Type) qtyp |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
162 |
val quotients = {qtyp = qtyp, rtyp = rtyp, equiv_rel = rel, equiv_thm = equiv_thm, |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
163 |
quot_thm = quot_thm } |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
164 |
fun quot_info phi = Quotient_Info.transform_quotients phi quotients |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
165 |
val abs_rep = {abs = abs, rep = rep} |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
166 |
fun abs_rep_info phi = Quotient_Info.transform_abs_rep phi abs_rep |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
167 |
in |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
168 |
lthy |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
169 |
|> Local_Theory.declaration {syntax = false, pervasive = true} |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
170 |
(fn phi => Quotient_Info.update_quotients qty_full_name (quot_info phi) |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
171 |
#> Quotient_Info.update_abs_rep qty_full_name (abs_rep_info phi)) |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
172 |
|> define_abs_type quot_thm |
47362
b1f099bdfbba
connect the Quotient package to the Lifting package
kuncar
parents:
47308
diff
changeset
|
173 |
|> setup_lifting_package quot_thm equiv_thm |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
174 |
end |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
175 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
176 |
(* main function for constructing a quotient type *) |
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
177 |
fun add_quotient_type (((vs, qty_name, mx), (rty, rel, partial), opt_morphs), equiv_thm) lthy = |
41444 | 178 |
let |
179 |
val part_equiv = |
|
180 |
if partial |
|
181 |
then equiv_thm |
|
182 |
else equiv_thm RS @{thm equivp_implies_part_equivp} |
|
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
183 |
|
41444 | 184 |
(* generates the typedef *) |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
185 |
val ((_, typedef_info), lthy1) = |
41444 | 186 |
typedef_make (vs, qty_name, mx, rel, rty) part_equiv lthy |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
187 |
|
41444 | 188 |
(* abs and rep functions from the typedef *) |
189 |
val Abs_ty = #abs_type (#1 typedef_info) |
|
190 |
val Rep_ty = #rep_type (#1 typedef_info) |
|
191 |
val Abs_name = #Abs_name (#1 typedef_info) |
|
192 |
val Rep_name = #Rep_name (#1 typedef_info) |
|
193 |
val Abs_const = Const (Abs_name, Rep_ty --> Abs_ty) |
|
194 |
val Rep_const = Const (Rep_name, Abs_ty --> Rep_ty) |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
195 |
|
41444 | 196 |
(* more useful abs and rep definitions *) |
45317
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
197 |
val abs_const = Const (@{const_name quot_type.abs}, |
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
198 |
(rty --> rty --> @{typ bool}) --> (Rep_ty --> Abs_ty) --> rty --> Abs_ty) |
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
199 |
val rep_const = Const (@{const_name quot_type.rep}, (Abs_ty --> Rep_ty) --> Abs_ty --> rty) |
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
200 |
val abs_trm = abs_const $ rel $ Abs_const |
bf8b9ac6000c
more robust, declarative and unsurprising computation of types in the quotient type definition
bulwahn
parents:
45314
diff
changeset
|
201 |
val rep_trm = rep_const $ Rep_const |
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
202 |
val (rep_name, abs_name) = |
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
203 |
(case opt_morphs of |
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
204 |
NONE => (Binding.prefix_name "rep_" qty_name, Binding.prefix_name "abs_" qty_name) |
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
205 |
| SOME morphs => morphs) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
206 |
|
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
207 |
val ((_, (_, abs_def)), lthy2) = lthy1 |
46909 | 208 |
|> Local_Theory.define ((abs_name, NoSyn), ((Thm.def_binding abs_name, []), abs_trm)) |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
209 |
val ((_, (_, rep_def)), lthy3) = lthy2 |
46909 | 210 |
|> Local_Theory.define ((rep_name, NoSyn), ((Thm.def_binding rep_name, []), rep_trm)) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
211 |
|
41444 | 212 |
(* quot_type theorem *) |
213 |
val quot_thm = typedef_quot_type_thm (rel, Abs_const, Rep_const, part_equiv, typedef_info) lthy3 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
214 |
|
41444 | 215 |
(* quotient theorem *) |
47308 | 216 |
val quotient_thm_name = Binding.prefix_name "Quotient3_" qty_name |
41444 | 217 |
val quotient_thm = |
218 |
(quot_thm RS @{thm quot_type.Quotient}) |
|
219 |
|> fold_rule [abs_def, rep_def] |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
220 |
|
41444 | 221 |
(* name equivalence theorem *) |
222 |
val equiv_thm_name = Binding.suffix_name "_equivp" qty_name |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
223 |
|
45279 | 224 |
(* storing the quotients *) |
47093 | 225 |
val quotients = {qtyp = Abs_ty, rtyp = rty, equiv_rel = rel, equiv_thm = equiv_thm, |
226 |
quot_thm = quotient_thm} |
|
37530
70d03844b2f9
export of proper information in the ML-interface of the quotient package
Christian Urban <urbanc@in.tum.de>
parents:
37493
diff
changeset
|
227 |
|
41444 | 228 |
val lthy4 = lthy3 |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
229 |
|> init_quotient_infr quotient_thm equiv_thm |
45282 | 230 |
|> (snd oo Local_Theory.note) |
231 |
((equiv_thm_name, |
|
232 |
if partial then [] else [Attrib.internal (K Quotient_Info.equiv_rules_add)]), |
|
233 |
[equiv_thm]) |
|
234 |
|> (snd oo Local_Theory.note) |
|
235 |
((quotient_thm_name, [Attrib.internal (K Quotient_Info.quotient_rules_add)]), |
|
236 |
[quotient_thm]) |
|
41444 | 237 |
in |
45279 | 238 |
(quotients, lthy4) |
41444 | 239 |
end |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
240 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
241 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
242 |
(* sanity checks for the quotient type specifications *) |
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
243 |
fun sanity_check ((vs, qty_name, _), (rty, rel, _), _) = |
41444 | 244 |
let |
245 |
val rty_tfreesT = map fst (Term.add_tfreesT rty []) |
|
246 |
val rel_tfrees = map fst (Term.add_tfrees rel []) |
|
247 |
val rel_frees = map fst (Term.add_frees rel []) |
|
248 |
val rel_vars = Term.add_vars rel [] |
|
249 |
val rel_tvars = Term.add_tvars rel [] |
|
43547
f3a8476285c6
clarified Binding.pretty/print: no quotes, only markup -- Binding.str_of is rendered obsolete;
wenzelm
parents:
42361
diff
changeset
|
250 |
val qty_str = Binding.print qty_name ^ ": " |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
251 |
|
41444 | 252 |
val illegal_rel_vars = |
253 |
if null rel_vars andalso null rel_tvars then [] |
|
254 |
else [qty_str ^ "illegal schematic variable(s) in the relation."] |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
255 |
|
41444 | 256 |
val dup_vs = |
257 |
(case duplicates (op =) vs of |
|
258 |
[] => [] |
|
259 |
| dups => [qty_str ^ "duplicate type variable(s) on the lhs: " ^ commas_quote dups]) |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
260 |
|
41444 | 261 |
val extra_rty_tfrees = |
262 |
(case subtract (op =) vs rty_tfreesT of |
|
263 |
[] => [] |
|
264 |
| extras => [qty_str ^ "extra type variable(s) on the lhs: " ^ commas_quote extras]) |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
265 |
|
41444 | 266 |
val extra_rel_tfrees = |
267 |
(case subtract (op =) vs rel_tfrees of |
|
268 |
[] => [] |
|
269 |
| extras => [qty_str ^ "extra type variable(s) in the relation: " ^ commas_quote extras]) |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
270 |
|
41444 | 271 |
val illegal_rel_frees = |
272 |
(case rel_frees of |
|
273 |
[] => [] |
|
274 |
| xs => [qty_str ^ "illegal variable(s) in the relation: " ^ commas_quote xs]) |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
275 |
|
41444 | 276 |
val errs = illegal_rel_vars @ dup_vs @ extra_rty_tfrees @ extra_rel_tfrees @ illegal_rel_frees |
277 |
in |
|
278 |
if null errs then () else error (cat_lines errs) |
|
279 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
280 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
281 |
(* check for existence of map functions *) |
45795
2d8949268303
maps are taken from enriched type infrastracture, rewritten lifting of constants, now we can lift even contravariant and co/contravariant types
kuncar
parents:
45698
diff
changeset
|
282 |
fun map_check ctxt (_, (rty, _, _), _) = |
41444 | 283 |
let |
284 |
fun map_check_aux rty warns = |
|
45280 | 285 |
(case rty of |
41444 | 286 |
Type (_, []) => warns |
45340
98ec8b51af9c
prefer global Quotient_Info lookup to accomodate Quotient_Term, which is not quite localized yet (cf. 9fd6fce8a230);
wenzelm
parents:
45317
diff
changeset
|
287 |
| Type (s, _) => |
45795
2d8949268303
maps are taken from enriched type infrastracture, rewritten lifting of constants, now we can lift even contravariant and co/contravariant types
kuncar
parents:
45698
diff
changeset
|
288 |
if Symtab.defined (Enriched_Type.entries ctxt) s then warns else s :: warns |
45280 | 289 |
| _ => warns) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
290 |
|
41444 | 291 |
val warns = map_check_aux rty [] |
292 |
in |
|
293 |
if null warns then () |
|
294 |
else warning ("No map function defined for " ^ commas warns ^ |
|
295 |
". This will cause problems later on.") |
|
296 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
297 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
298 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
299 |
(*** interface and syntax setup ***) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
300 |
|
45698
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
301 |
(* the ML-interface takes a list of tuples consisting of: |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
302 |
|
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
303 |
- the name of the quotient type |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
304 |
- its free type variables (first argument) |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
305 |
- its mixfix annotation |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
306 |
- the type to be quotient |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
307 |
- the partial flag (a boolean) |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
308 |
- the relation according to which the type is quotient |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
309 |
- optional names of morphisms (rep/abs) |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
310 |
|
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
311 |
it opens a proof-state in which one has to show that the |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
312 |
relations are equivalence relations |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
313 |
*) |
fd8e140ae879
removed outdated comment moved back and updated (at the direct request of Christian Urban)
kuncar
parents:
45690
diff
changeset
|
314 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
315 |
fun quotient_type quot_list lthy = |
41444 | 316 |
let |
317 |
(* sanity check *) |
|
318 |
val _ = List.app sanity_check quot_list |
|
45795
2d8949268303
maps are taken from enriched type infrastracture, rewritten lifting of constants, now we can lift even contravariant and co/contravariant types
kuncar
parents:
45698
diff
changeset
|
319 |
val _ = List.app (map_check lthy) quot_list |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
320 |
|
41444 | 321 |
fun mk_goal (rty, rel, partial) = |
322 |
let |
|
323 |
val equivp_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool} |
|
324 |
val const = |
|
325 |
if partial then @{const_name part_equivp} else @{const_name equivp} |
|
326 |
in |
|
327 |
HOLogic.mk_Trueprop (Const (const, equivp_ty) $ rel) |
|
328 |
end |
|
329 |
||
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
330 |
val goals = map (mk_goal o #2) quot_list |
41444 | 331 |
|
45282 | 332 |
fun after_qed [thms] = fold (snd oo add_quotient_type) (quot_list ~~ thms) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
333 |
in |
45282 | 334 |
Proof.theorem NONE after_qed [map (rpair []) goals] lthy |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
335 |
end |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
336 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
337 |
fun quotient_type_cmd specs lthy = |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
338 |
let |
45676
fa46fef06590
alternative names of morphisms in the definition of a quotient type can be specified
kuncar
parents:
45534
diff
changeset
|
339 |
fun parse_spec (((((vs, qty_name), mx), rty_str), (partial, rel_str)), opt_morphs) lthy = |
41444 | 340 |
let |
341 |
val rty = Syntax.read_typ lthy rty_str |
|
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
342 |
val tmp_lthy1 = Variable.declare_typ rty lthy |
41444 | 343 |
val rel = |
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
344 |
Syntax.parse_term tmp_lthy1 rel_str |
41444 | 345 |
|> Type.constraint (rty --> rty --> @{typ bool}) |
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
346 |
|> Syntax.check_term tmp_lthy1 |
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
347 |
val tmp_lthy2 = Variable.declare_term rel tmp_lthy1 |
41444 | 348 |
in |
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
349 |
(((vs, qty_name, mx), (rty, rel, partial), opt_morphs), tmp_lthy2) |
41444 | 350 |
end |
351 |
||
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
352 |
val (spec', _) = fold_map parse_spec specs lthy |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
353 |
in |
46727
0162a0d284ac
Finish localizing the quotient package.
Cezary Kaliszyk <cezarykaliszyk@gmail.com>
parents:
45835
diff
changeset
|
354 |
quotient_type spec' lthy |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
355 |
end |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
356 |
|
46949 | 357 |
val partial = Scan.optional (Parse.reserved "partial" -- @{keyword ":"} >> K true) false |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
358 |
|
47091
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
359 |
val quotspec_parser = |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
360 |
Parse.and_list1 |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
361 |
((Parse.type_args -- Parse.binding) -- |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
362 |
(* FIXME Parse.type_args_constrained and standard treatment of sort constraints *) |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
363 |
Parse.opt_mixfix -- (@{keyword "="} |-- Parse.typ) -- |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
364 |
(@{keyword "/"} |-- (partial -- Parse.term)) -- |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
365 |
Scan.option (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding))) |
d5cd13aca90b
respectfulness theorem has to be proved if a new constant is lifted by quotient_definition
kuncar
parents:
46961
diff
changeset
|
366 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
367 |
val _ = |
46961
5c6955f487e5
outer syntax command definitions based on formal command_spec derived from theory header declarations;
wenzelm
parents:
46949
diff
changeset
|
368 |
Outer_Syntax.local_theory_to_proof @{command_spec "quotient_type"} |
41444 | 369 |
"quotient type definitions (require equivalence proofs)" |
47096
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
370 |
(quotspec_parser >> quotient_type_cmd) |
3ea48c19673e
generation of a code certificate from a respectfulness theorem for constants lifted by the quotient_definition command & setup_lifting command: setups Quotient infrastructure from a typedef theorem
kuncar
parents:
47093
diff
changeset
|
371 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
372 |
|
45280 | 373 |
end; |