author | wenzelm |
Thu, 27 Oct 2011 20:26:38 +0200 | |
changeset 45279 | 89a17197cb98 |
parent 45278 | 7c6c8e950636 |
child 45280 | 9fd6fce8a230 |
permissions | -rw-r--r-- |
37744 | 1 |
(* Title: HOL/Tools/Quotient/quotient_typ.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 |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
9 |
val add_quotient_type: ((string list * binding * mixfix) * (typ * term * bool)) * thm |
45279 | 10 |
-> Proof.context -> Quotient_Info.quotients * local_theory |
35415
1810b1ade437
export add_quotient_type.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
35351
diff
changeset
|
11 |
|
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
12 |
val quotient_type: ((string list * binding * mixfix) * (typ * term * bool)) list |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
13 |
-> Proof.context -> Proof.state |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
14 |
|
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
15 |
val quotient_type_cmd: ((((string list * binding) * mixfix) * string) * (bool * string)) list |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
16 |
-> Proof.context -> Proof.state |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
17 |
end; |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
18 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
19 |
structure Quotient_Type: QUOTIENT_TYPE = |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
20 |
struct |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
21 |
|
41451 | 22 |
(* wrappers for define, note, Attrib.internal and theorem_i *) (* FIXME !? *) |
35222
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 |
fun define (name, mx, rhs) lthy = |
41444 | 25 |
let |
26 |
val ((rhs, (_ , thm)), lthy') = |
|
27 |
Local_Theory.define ((name, mx), (Attrib.empty_binding, rhs)) lthy |
|
28 |
in |
|
29 |
((rhs, thm), lthy') |
|
30 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
31 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
32 |
fun note (name, thm, attrs) lthy = |
37530
70d03844b2f9
export of proper information in the ML-interface of the quotient package
Christian Urban <urbanc@in.tum.de>
parents:
37493
diff
changeset
|
33 |
Local_Theory.note ((name, attrs), [thm]) lthy |> snd |
70d03844b2f9
export of proper information in the ML-interface of the quotient package
Christian Urban <urbanc@in.tum.de>
parents:
37493
diff
changeset
|
34 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
35 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
36 |
fun intern_attr at = Attrib.internal (K at) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
37 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
38 |
fun theorem after_qed goals ctxt = |
41444 | 39 |
let |
40 |
val goals' = map (rpair []) goals |
|
41 |
fun after_qed' thms = after_qed (the_single thms) |
|
42 |
in |
|
43 |
Proof.theorem NONE after_qed' [goals'] ctxt |
|
44 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
45 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
46 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
47 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
48 |
(*** definition of quotient types ***) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
49 |
|
44204
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
50 |
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
|
51 |
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
|
52 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
53 |
(* constructs the term lambda (c::rty => bool). EX (x::rty). c = rel x *) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
54 |
fun typedef_term rel rty lthy = |
41444 | 55 |
let |
56 |
val [x, c] = |
|
57 |
[("x", rty), ("c", HOLogic.mk_setT rty)] |
|
58 |
|> Variable.variant_frees lthy [rel] |
|
59 |
|> map Free |
|
44204
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
60 |
fun mk_collect T = |
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
61 |
Const (@{const_name Collect}, (T --> @{typ bool}) --> HOLogic.mk_setT T) |
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
62 |
val collect_in = mk_collect rty |
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
63 |
val collect_out = mk_collect (HOLogic.mk_setT rty) |
41444 | 64 |
in |
44204
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
65 |
collect_out $ (lambda c (HOLogic.exists_const rty $ |
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
66 |
lambda x (HOLogic.mk_conj (rel $ x $ x, |
3cdc4176638c
Quotient Package: make quotient_type work with separate set type
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
43547
diff
changeset
|
67 |
HOLogic.mk_eq (c, collect_in $ (rel $ x)))))) |
41444 | 68 |
end |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
69 |
|
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 |
(* 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
|
72 |
fun typedef_make (vs, qty_name, mx, rel, rty) equiv_thm lthy = |
41444 | 73 |
let |
74 |
val typedef_tac = |
|
75 |
EVERY1 (map rtac [@{thm part_equivp_typedef}, equiv_thm]) |
|
76 |
in |
|
77 |
(* FIXME: purely local typedef causes at the moment |
|
78 |
problems with type variables |
|
79 |
||
80 |
Typedef.add_typedef false NONE (qty_name, vs, mx) |
|
81 |
(typedef_term rel rty lthy) NONE typedef_tac lthy |
|
82 |
*) |
|
83 |
(* FIXME should really use local typedef here *) |
|
84 |
Local_Theory.background_theory_result |
|
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
|
85 |
(Typedef.add_typedef_global false NONE |
35842 | 86 |
(qty_name, map (rpair dummyS) vs, mx) |
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
|
87 |
(typedef_term rel rty lthy) |
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
|
88 |
NONE typedef_tac) lthy |
41444 | 89 |
end |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
90 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
91 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
92 |
(* 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
|
93 |
fun typedef_quot_type_tac equiv_thm ((_, typedef_info): Typedef.info) = |
41444 | 94 |
let |
95 |
val rep_thm = #Rep typedef_info RS mem_def1 |
|
96 |
val rep_inv = #Rep_inverse typedef_info |
|
97 |
val abs_inv = #Abs_inverse typedef_info |
|
98 |
val rep_inj = #Rep_inject typedef_info |
|
99 |
in |
|
100 |
(rtac @{thm quot_type.intro} THEN' RANGE [ |
|
101 |
rtac equiv_thm, |
|
102 |
rtac rep_thm, |
|
103 |
rtac rep_inv, |
|
104 |
rtac abs_inv THEN' rtac mem_def2 THEN' atac, |
|
105 |
rtac rep_inj]) 1 |
|
106 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
107 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
108 |
(* 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
|
109 |
fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy = |
41444 | 110 |
let |
111 |
val quot_type_const = Const (@{const_name "quot_type"}, dummyT) |
|
112 |
val goal = |
|
113 |
HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep) |
|
114 |
|> Syntax.check_term lthy |
|
115 |
in |
|
116 |
Goal.prove lthy [] [] goal |
|
117 |
(K (typedef_quot_type_tac equiv_thm typedef_info)) |
|
118 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
119 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
120 |
(* main function for constructing a quotient type *) |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
121 |
fun add_quotient_type (((vs, qty_name, mx), (rty, rel, partial)), equiv_thm) lthy = |
41444 | 122 |
let |
123 |
val part_equiv = |
|
124 |
if partial |
|
125 |
then equiv_thm |
|
126 |
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
|
127 |
|
41444 | 128 |
(* generates the typedef *) |
129 |
val ((qty_full_name, typedef_info), lthy1) = |
|
130 |
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
|
131 |
|
41444 | 132 |
(* abs and rep functions from the typedef *) |
133 |
val Abs_ty = #abs_type (#1 typedef_info) |
|
134 |
val Rep_ty = #rep_type (#1 typedef_info) |
|
135 |
val Abs_name = #Abs_name (#1 typedef_info) |
|
136 |
val Rep_name = #Rep_name (#1 typedef_info) |
|
137 |
val Abs_const = Const (Abs_name, Rep_ty --> Abs_ty) |
|
138 |
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
|
139 |
|
41444 | 140 |
(* more useful abs and rep definitions *) |
141 |
val abs_const = Const (@{const_name "quot_type.abs"}, dummyT ) |
|
142 |
val rep_const = Const (@{const_name "quot_type.rep"}, dummyT ) |
|
143 |
val abs_trm = Syntax.check_term lthy1 (abs_const $ rel $ Abs_const) |
|
144 |
val rep_trm = Syntax.check_term lthy1 (rep_const $ Rep_const) |
|
145 |
val abs_name = Binding.prefix_name "abs_" qty_name |
|
146 |
val rep_name = Binding.prefix_name "rep_" qty_name |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
147 |
|
41444 | 148 |
val ((_, abs_def), lthy2) = define (abs_name, NoSyn, abs_trm) lthy1 |
149 |
val ((_, rep_def), lthy3) = define (rep_name, NoSyn, rep_trm) lthy2 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
150 |
|
41444 | 151 |
(* quot_type theorem *) |
152 |
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
|
153 |
|
41444 | 154 |
(* quotient theorem *) |
155 |
val quotient_thm_name = Binding.prefix_name "Quotient_" qty_name |
|
156 |
val quotient_thm = |
|
157 |
(quot_thm RS @{thm quot_type.Quotient}) |
|
158 |
|> fold_rule [abs_def, rep_def] |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
159 |
|
41444 | 160 |
(* name equivalence theorem *) |
161 |
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
|
162 |
|
45279 | 163 |
(* storing the quotients *) |
164 |
val quotients = {qtyp = Abs_ty, rtyp = rty, equiv_rel = rel, equiv_thm = equiv_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
|
165 |
|
45279 | 166 |
fun qinfo phi = Quotient_Info.transform_quotients phi quotients |
37530
70d03844b2f9
export of proper information in the ML-interface of the quotient package
Christian Urban <urbanc@in.tum.de>
parents:
37493
diff
changeset
|
167 |
|
41444 | 168 |
val lthy4 = lthy3 |
41451 | 169 |
|> Local_Theory.declaration true |
45279 | 170 |
(fn phi => Quotient_Info.update_quotients qty_full_name (qinfo phi)) |
41451 | 171 |
|> note |
172 |
(equiv_thm_name, equiv_thm, |
|
173 |
if partial then [] else [intern_attr Quotient_Info.equiv_rules_add]) |
|
174 |
|> note (quotient_thm_name, quotient_thm, [intern_attr Quotient_Info.quotient_rules_add]) |
|
41444 | 175 |
in |
45279 | 176 |
(quotients, lthy4) |
41444 | 177 |
end |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
178 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
179 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
180 |
(* sanity checks for the quotient type specifications *) |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
181 |
fun sanity_check ((vs, qty_name, _), (rty, rel, _)) = |
41444 | 182 |
let |
183 |
val rty_tfreesT = map fst (Term.add_tfreesT rty []) |
|
184 |
val rel_tfrees = map fst (Term.add_tfrees rel []) |
|
185 |
val rel_frees = map fst (Term.add_frees rel []) |
|
186 |
val rel_vars = Term.add_vars rel [] |
|
187 |
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
|
188 |
val qty_str = Binding.print qty_name ^ ": " |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
189 |
|
41444 | 190 |
val illegal_rel_vars = |
191 |
if null rel_vars andalso null rel_tvars then [] |
|
192 |
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
|
193 |
|
41444 | 194 |
val dup_vs = |
195 |
(case duplicates (op =) vs of |
|
196 |
[] => [] |
|
197 |
| 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
|
198 |
|
41444 | 199 |
val extra_rty_tfrees = |
200 |
(case subtract (op =) vs rty_tfreesT of |
|
201 |
[] => [] |
|
202 |
| 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
|
203 |
|
41444 | 204 |
val extra_rel_tfrees = |
205 |
(case subtract (op =) vs rel_tfrees of |
|
206 |
[] => [] |
|
207 |
| 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
|
208 |
|
41444 | 209 |
val illegal_rel_frees = |
210 |
(case rel_frees of |
|
211 |
[] => [] |
|
212 |
| 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
|
213 |
|
41444 | 214 |
val errs = illegal_rel_vars @ dup_vs @ extra_rty_tfrees @ extra_rel_tfrees @ illegal_rel_frees |
215 |
in |
|
216 |
if null errs then () else error (cat_lines errs) |
|
217 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
218 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
219 |
(* check for existence of map functions *) |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
220 |
fun map_check ctxt (_, (rty, _, _)) = |
41444 | 221 |
let |
42361 | 222 |
val thy = Proof_Context.theory_of ctxt |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
223 |
|
41444 | 224 |
fun map_check_aux rty warns = |
225 |
case rty of |
|
226 |
Type (_, []) => warns |
|
45279 | 227 |
| Type (s, _) => if is_some (Quotient_Info.lookup_quotmaps thy s) then warns else s :: warns |
41444 | 228 |
| _ => warns |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
229 |
|
41444 | 230 |
val warns = map_check_aux rty [] |
231 |
in |
|
232 |
if null warns then () |
|
233 |
else warning ("No map function defined for " ^ commas warns ^ |
|
234 |
". This will cause problems later on.") |
|
235 |
end |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
236 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
237 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
238 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
239 |
(*** interface and syntax setup ***) |
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 |
(* the ML-interface takes a list of 5-tuples consisting of: |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
243 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
244 |
- the name of the quotient type |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
245 |
- its free type variables (first argument) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
246 |
- its mixfix annotation |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
247 |
- the type to be quotient |
37530
70d03844b2f9
export of proper information in the ML-interface of the quotient package
Christian Urban <urbanc@in.tum.de>
parents:
37493
diff
changeset
|
248 |
- the partial flag (a boolean) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
249 |
- the relation according to which the type is quotient |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
250 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
251 |
it opens a proof-state in which one has to show that the |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
252 |
relations are equivalence relations |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
253 |
*) |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
254 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
255 |
fun quotient_type quot_list lthy = |
41444 | 256 |
let |
257 |
(* sanity check *) |
|
258 |
val _ = List.app sanity_check quot_list |
|
259 |
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
|
260 |
|
41444 | 261 |
fun mk_goal (rty, rel, partial) = |
262 |
let |
|
263 |
val equivp_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool} |
|
264 |
val const = |
|
265 |
if partial then @{const_name part_equivp} else @{const_name equivp} |
|
266 |
in |
|
267 |
HOLogic.mk_Trueprop (Const (const, equivp_ty) $ rel) |
|
268 |
end |
|
269 |
||
270 |
val goals = map (mk_goal o snd) quot_list |
|
271 |
||
272 |
fun after_qed thms lthy = |
|
273 |
fold_map add_quotient_type (quot_list ~~ thms) lthy |> snd |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
274 |
in |
41444 | 275 |
theorem after_qed goals lthy |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
276 |
end |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
277 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
278 |
fun quotient_type_cmd specs lthy = |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
279 |
let |
41444 | 280 |
fun parse_spec ((((vs, qty_name), mx), rty_str), (partial, rel_str)) lthy = |
281 |
let |
|
282 |
val rty = Syntax.read_typ lthy rty_str |
|
283 |
val lthy1 = Variable.declare_typ rty lthy |
|
284 |
val rel = |
|
285 |
Syntax.parse_term lthy1 rel_str |
|
286 |
|> Type.constraint (rty --> rty --> @{typ bool}) |
|
287 |
|> Syntax.check_term lthy1 |
|
288 |
val lthy2 = Variable.declare_term rel lthy1 |
|
289 |
in |
|
290 |
(((vs, qty_name, mx), (rty, rel, partial)), lthy2) |
|
291 |
end |
|
292 |
||
293 |
val (spec', lthy') = fold_map parse_spec specs lthy |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
294 |
in |
41444 | 295 |
quotient_type spec' lthy' |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
296 |
end |
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
297 |
|
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
298 |
val partial = Scan.optional (Parse.reserved "partial" -- Parse.$$$ ":" >> K true) false |
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
299 |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
300 |
val quotspec_parser = |
37493
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
301 |
Parse.and_list1 |
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
302 |
((Parse.type_args -- Parse.binding) -- |
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
303 |
Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.typ) -- |
2377d246a631
Quotient package now uses Partial Equivalence instead place of equivalence
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
36960
diff
changeset
|
304 |
(Parse.$$$ "/" |-- (partial -- Parse.term))) |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
305 |
|
36960
01594f816e3a
prefer structure Keyword, Parse, Parse_Spec, Outer_Syntax;
wenzelm
parents:
36323
diff
changeset
|
306 |
val _ = Keyword.keyword "/" |
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
307 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
308 |
val _ = |
41444 | 309 |
Outer_Syntax.local_theory_to_proof "quotient_type" |
310 |
"quotient type definitions (require equivalence proofs)" |
|
311 |
Keyword.thy_goal (quotspec_parser >> quotient_type_cmd) |
|
35222
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
312 |
|
4f1fba00f66d
Initial version of HOL quotient package.
Cezary Kaliszyk <kaliszyk@in.tum.de>
parents:
diff
changeset
|
313 |
end; (* structure *) |