|
1 (* Title: HOL/Lifting.thy |
|
2 Author: Brian Huffman and Ondrej Kuncar |
|
3 Author: Cezary Kaliszyk and Christian Urban |
|
4 *) |
|
5 |
|
6 header {* Lifting package *} |
|
7 |
|
8 theory Lifting |
|
9 imports Plain Equiv_Relations |
|
10 keywords |
|
11 "print_quotmaps" "print_quotients" :: diag and |
|
12 "lift_definition" :: thy_goal and |
|
13 "setup_lifting" :: thy_decl |
|
14 uses |
|
15 ("Tools/Lifting/lifting_info.ML") |
|
16 ("Tools/Lifting/lifting_term.ML") |
|
17 ("Tools/Lifting/lifting_def.ML") |
|
18 ("Tools/Lifting/lifting_setup.ML") |
|
19 begin |
|
20 |
|
21 subsection {* Function map and function relation *} |
|
22 |
|
23 notation map_fun (infixr "--->" 55) |
|
24 |
|
25 lemma map_fun_id: |
|
26 "(id ---> id) = id" |
|
27 by (simp add: fun_eq_iff) |
|
28 |
|
29 definition |
|
30 fun_rel :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> bool" (infixr "===>" 55) |
|
31 where |
|
32 "fun_rel R1 R2 = (\<lambda>f g. \<forall>x y. R1 x y \<longrightarrow> R2 (f x) (g y))" |
|
33 |
|
34 lemma fun_relI [intro]: |
|
35 assumes "\<And>x y. R1 x y \<Longrightarrow> R2 (f x) (g y)" |
|
36 shows "(R1 ===> R2) f g" |
|
37 using assms by (simp add: fun_rel_def) |
|
38 |
|
39 lemma fun_relE: |
|
40 assumes "(R1 ===> R2) f g" and "R1 x y" |
|
41 obtains "R2 (f x) (g y)" |
|
42 using assms by (simp add: fun_rel_def) |
|
43 |
|
44 lemma fun_rel_eq: |
|
45 shows "((op =) ===> (op =)) = (op =)" |
|
46 by (auto simp add: fun_eq_iff elim: fun_relE) |
|
47 |
|
48 lemma fun_rel_eq_rel: |
|
49 shows "((op =) ===> R) = (\<lambda>f g. \<forall>x. R (f x) (g x))" |
|
50 by (simp add: fun_rel_def) |
|
51 |
|
52 subsection {* Quotient Predicate *} |
|
53 |
|
54 definition |
|
55 "Quotient R Abs Rep T \<longleftrightarrow> |
|
56 (\<forall>a. Abs (Rep a) = a) \<and> |
|
57 (\<forall>a. R (Rep a) (Rep a)) \<and> |
|
58 (\<forall>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s) \<and> |
|
59 T = (\<lambda>x y. R x x \<and> Abs x = y)" |
|
60 |
|
61 lemma QuotientI: |
|
62 assumes "\<And>a. Abs (Rep a) = a" |
|
63 and "\<And>a. R (Rep a) (Rep a)" |
|
64 and "\<And>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s" |
|
65 and "T = (\<lambda>x y. R x x \<and> Abs x = y)" |
|
66 shows "Quotient R Abs Rep T" |
|
67 using assms unfolding Quotient_def by blast |
|
68 |
|
69 lemma Quotient_abs_rep: |
|
70 assumes a: "Quotient R Abs Rep T" |
|
71 shows "Abs (Rep a) = a" |
|
72 using a |
|
73 unfolding Quotient_def |
|
74 by simp |
|
75 |
|
76 lemma Quotient_rep_reflp: |
|
77 assumes a: "Quotient R Abs Rep T" |
|
78 shows "R (Rep a) (Rep a)" |
|
79 using a |
|
80 unfolding Quotient_def |
|
81 by blast |
|
82 |
|
83 lemma Quotient_rel: |
|
84 assumes a: "Quotient R Abs Rep T" |
|
85 shows "R r r \<and> R s s \<and> Abs r = Abs s \<longleftrightarrow> R r s" -- {* orientation does not loop on rewriting *} |
|
86 using a |
|
87 unfolding Quotient_def |
|
88 by blast |
|
89 |
|
90 lemma Quotient_cr_rel: |
|
91 assumes a: "Quotient R Abs Rep T" |
|
92 shows "T = (\<lambda>x y. R x x \<and> Abs x = y)" |
|
93 using a |
|
94 unfolding Quotient_def |
|
95 by blast |
|
96 |
|
97 lemma Quotient_refl1: |
|
98 assumes a: "Quotient R Abs Rep T" |
|
99 shows "R r s \<Longrightarrow> R r r" |
|
100 using a unfolding Quotient_def |
|
101 by fast |
|
102 |
|
103 lemma Quotient_refl2: |
|
104 assumes a: "Quotient R Abs Rep T" |
|
105 shows "R r s \<Longrightarrow> R s s" |
|
106 using a unfolding Quotient_def |
|
107 by fast |
|
108 |
|
109 lemma Quotient_rel_rep: |
|
110 assumes a: "Quotient R Abs Rep T" |
|
111 shows "R (Rep a) (Rep b) \<longleftrightarrow> a = b" |
|
112 using a |
|
113 unfolding Quotient_def |
|
114 by metis |
|
115 |
|
116 lemma Quotient_rep_abs: |
|
117 assumes a: "Quotient R Abs Rep T" |
|
118 shows "R r r \<Longrightarrow> R (Rep (Abs r)) r" |
|
119 using a unfolding Quotient_def |
|
120 by blast |
|
121 |
|
122 lemma Quotient_rel_abs: |
|
123 assumes a: "Quotient R Abs Rep T" |
|
124 shows "R r s \<Longrightarrow> Abs r = Abs s" |
|
125 using a unfolding Quotient_def |
|
126 by blast |
|
127 |
|
128 lemma Quotient_symp: |
|
129 assumes a: "Quotient R Abs Rep T" |
|
130 shows "symp R" |
|
131 using a unfolding Quotient_def using sympI by (metis (full_types)) |
|
132 |
|
133 lemma Quotient_transp: |
|
134 assumes a: "Quotient R Abs Rep T" |
|
135 shows "transp R" |
|
136 using a unfolding Quotient_def using transpI by (metis (full_types)) |
|
137 |
|
138 lemma Quotient_part_equivp: |
|
139 assumes a: "Quotient R Abs Rep T" |
|
140 shows "part_equivp R" |
|
141 by (metis Quotient_rep_reflp Quotient_symp Quotient_transp a part_equivpI) |
|
142 |
|
143 lemma identity_quotient: "Quotient (op =) id id (op =)" |
|
144 unfolding Quotient_def by simp |
|
145 |
|
146 lemma Quotient_alt_def: |
|
147 "Quotient R Abs Rep T \<longleftrightarrow> |
|
148 (\<forall>a b. T a b \<longrightarrow> Abs a = b) \<and> |
|
149 (\<forall>b. T (Rep b) b) \<and> |
|
150 (\<forall>x y. R x y \<longleftrightarrow> T x (Abs x) \<and> T y (Abs y) \<and> Abs x = Abs y)" |
|
151 apply safe |
|
152 apply (simp (no_asm_use) only: Quotient_def, fast) |
|
153 apply (simp (no_asm_use) only: Quotient_def, fast) |
|
154 apply (simp (no_asm_use) only: Quotient_def, fast) |
|
155 apply (simp (no_asm_use) only: Quotient_def, fast) |
|
156 apply (simp (no_asm_use) only: Quotient_def, fast) |
|
157 apply (simp (no_asm_use) only: Quotient_def, fast) |
|
158 apply (rule QuotientI) |
|
159 apply simp |
|
160 apply metis |
|
161 apply simp |
|
162 apply (rule ext, rule ext, metis) |
|
163 done |
|
164 |
|
165 lemma Quotient_alt_def2: |
|
166 "Quotient R Abs Rep T \<longleftrightarrow> |
|
167 (\<forall>a b. T a b \<longrightarrow> Abs a = b) \<and> |
|
168 (\<forall>b. T (Rep b) b) \<and> |
|
169 (\<forall>x y. R x y \<longleftrightarrow> T x (Abs y) \<and> T y (Abs x))" |
|
170 unfolding Quotient_alt_def by (safe, metis+) |
|
171 |
|
172 lemma fun_quotient: |
|
173 assumes 1: "Quotient R1 abs1 rep1 T1" |
|
174 assumes 2: "Quotient R2 abs2 rep2 T2" |
|
175 shows "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2) (T1 ===> T2)" |
|
176 using assms unfolding Quotient_alt_def2 |
|
177 unfolding fun_rel_def fun_eq_iff map_fun_apply |
|
178 by (safe, metis+) |
|
179 |
|
180 lemma apply_rsp: |
|
181 fixes f g::"'a \<Rightarrow> 'c" |
|
182 assumes q: "Quotient R1 Abs1 Rep1 T1" |
|
183 and a: "(R1 ===> R2) f g" "R1 x y" |
|
184 shows "R2 (f x) (g y)" |
|
185 using a by (auto elim: fun_relE) |
|
186 |
|
187 lemma apply_rsp': |
|
188 assumes a: "(R1 ===> R2) f g" "R1 x y" |
|
189 shows "R2 (f x) (g y)" |
|
190 using a by (auto elim: fun_relE) |
|
191 |
|
192 lemma apply_rsp'': |
|
193 assumes "Quotient R Abs Rep T" |
|
194 and "(R ===> S) f f" |
|
195 shows "S (f (Rep x)) (f (Rep x))" |
|
196 proof - |
|
197 from assms(1) have "R (Rep x) (Rep x)" by (rule Quotient_rep_reflp) |
|
198 then show ?thesis using assms(2) by (auto intro: apply_rsp') |
|
199 qed |
|
200 |
|
201 subsection {* Quotient composition *} |
|
202 |
|
203 lemma Quotient_compose: |
|
204 assumes 1: "Quotient R1 Abs1 Rep1 T1" |
|
205 assumes 2: "Quotient R2 Abs2 Rep2 T2" |
|
206 shows "Quotient (T1 OO R2 OO conversep T1) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2) (T1 OO T2)" |
|
207 proof - |
|
208 from 1 have Abs1: "\<And>a b. T1 a b \<Longrightarrow> Abs1 a = b" |
|
209 unfolding Quotient_alt_def by simp |
|
210 from 1 have Rep1: "\<And>b. T1 (Rep1 b) b" |
|
211 unfolding Quotient_alt_def by simp |
|
212 from 2 have Abs2: "\<And>a b. T2 a b \<Longrightarrow> Abs2 a = b" |
|
213 unfolding Quotient_alt_def by simp |
|
214 from 2 have Rep2: "\<And>b. T2 (Rep2 b) b" |
|
215 unfolding Quotient_alt_def by simp |
|
216 from 2 have R2: |
|
217 "\<And>x y. R2 x y \<longleftrightarrow> T2 x (Abs2 x) \<and> T2 y (Abs2 y) \<and> Abs2 x = Abs2 y" |
|
218 unfolding Quotient_alt_def by simp |
|
219 show ?thesis |
|
220 unfolding Quotient_alt_def |
|
221 apply simp |
|
222 apply safe |
|
223 apply (drule Abs1, simp) |
|
224 apply (erule Abs2) |
|
225 apply (rule pred_compI) |
|
226 apply (rule Rep1) |
|
227 apply (rule Rep2) |
|
228 apply (rule pred_compI, assumption) |
|
229 apply (drule Abs1, simp) |
|
230 apply (clarsimp simp add: R2) |
|
231 apply (rule pred_compI, assumption) |
|
232 apply (drule Abs1, simp)+ |
|
233 apply (clarsimp simp add: R2) |
|
234 apply (drule Abs1, simp)+ |
|
235 apply (clarsimp simp add: R2) |
|
236 apply (rule pred_compI, assumption) |
|
237 apply (rule pred_compI [rotated]) |
|
238 apply (erule conversepI) |
|
239 apply (drule Abs1, simp)+ |
|
240 apply (simp add: R2) |
|
241 done |
|
242 qed |
|
243 |
|
244 subsection {* Invariant *} |
|
245 |
|
246 definition invariant :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" |
|
247 where "invariant R = (\<lambda>x y. R x \<and> x = y)" |
|
248 |
|
249 lemma invariant_to_eq: |
|
250 assumes "invariant P x y" |
|
251 shows "x = y" |
|
252 using assms by (simp add: invariant_def) |
|
253 |
|
254 lemma fun_rel_eq_invariant: |
|
255 shows "((invariant R) ===> S) = (\<lambda>f g. \<forall>x. R x \<longrightarrow> S (f x) (g x))" |
|
256 by (auto simp add: invariant_def fun_rel_def) |
|
257 |
|
258 lemma invariant_same_args: |
|
259 shows "invariant P x x \<equiv> P x" |
|
260 using assms by (auto simp add: invariant_def) |
|
261 |
|
262 lemma copy_type_to_Quotient: |
|
263 assumes "type_definition Rep Abs UNIV" |
|
264 and T_def: "T \<equiv> (\<lambda>x y. Abs x = y)" |
|
265 shows "Quotient (op =) Abs Rep T" |
|
266 proof - |
|
267 interpret type_definition Rep Abs UNIV by fact |
|
268 from Abs_inject Rep_inverse T_def show ?thesis by (auto intro!: QuotientI) |
|
269 qed |
|
270 |
|
271 lemma copy_type_to_equivp: |
|
272 fixes Abs :: "'a \<Rightarrow> 'b" |
|
273 and Rep :: "'b \<Rightarrow> 'a" |
|
274 assumes "type_definition Rep Abs (UNIV::'a set)" |
|
275 shows "equivp (op=::'a\<Rightarrow>'a\<Rightarrow>bool)" |
|
276 by (rule identity_equivp) |
|
277 |
|
278 lemma invariant_type_to_Quotient: |
|
279 assumes "type_definition Rep Abs {x. P x}" |
|
280 and T_def: "T \<equiv> (\<lambda>x y. (invariant P) x x \<and> Abs x = y)" |
|
281 shows "Quotient (invariant P) Abs Rep T" |
|
282 proof - |
|
283 interpret type_definition Rep Abs "{x. P x}" by fact |
|
284 from Rep Abs_inject Rep_inverse T_def show ?thesis by (auto intro!: QuotientI simp: invariant_def) |
|
285 qed |
|
286 |
|
287 lemma invariant_type_to_part_equivp: |
|
288 assumes "type_definition Rep Abs {x. P x}" |
|
289 shows "part_equivp (invariant P)" |
|
290 proof (intro part_equivpI) |
|
291 interpret type_definition Rep Abs "{x. P x}" by fact |
|
292 show "\<exists>x. invariant P x x" using Rep by (auto simp: invariant_def) |
|
293 next |
|
294 show "symp (invariant P)" by (auto intro: sympI simp: invariant_def) |
|
295 next |
|
296 show "transp (invariant P)" by (auto intro: transpI simp: invariant_def) |
|
297 qed |
|
298 |
|
299 subsection {* ML setup *} |
|
300 |
|
301 text {* Auxiliary data for the lifting package *} |
|
302 |
|
303 use "Tools/Lifting/lifting_info.ML" |
|
304 setup Lifting_Info.setup |
|
305 |
|
306 declare [[map "fun" = (fun_rel, fun_quotient)]] |
|
307 |
|
308 use "Tools/Lifting/lifting_term.ML" |
|
309 |
|
310 use "Tools/Lifting/lifting_def.ML" |
|
311 |
|
312 use "Tools/Lifting/lifting_setup.ML" |
|
313 |
|
314 hide_const (open) invariant |
|
315 |
|
316 end |