author | huffman |
Fri, 13 Nov 2009 15:31:20 -0800 | |
changeset 33679 | 331712879666 |
parent 33589 | e7ba88cdf3a2 |
child 33779 | b8efeea2cebd |
permissions | -rw-r--r-- |
33589 | 1 |
(* Title: HOLCF/Representable.thy |
2 |
Author: Brian Huffman |
|
3 |
*) |
|
4 |
||
33588 | 5 |
header {* Representable Types *} |
6 |
||
7 |
theory Representable |
|
8 |
imports Algebraic Universal Ssum Sprod One ConvexPD |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
9 |
uses ("Tools/repdef.ML") |
33588 | 10 |
begin |
11 |
||
12 |
subsection {* Class of representable types *} |
|
13 |
||
14 |
text "Overloaded embedding and projection functions between |
|
15 |
a representable type and the universal domain." |
|
16 |
||
17 |
class rep = bifinite + |
|
18 |
fixes emb :: "'a::pcpo \<rightarrow> udom" |
|
19 |
fixes prj :: "udom \<rightarrow> 'a::pcpo" |
|
20 |
assumes ep_pair_emb_prj: "ep_pair emb prj" |
|
21 |
||
22 |
interpretation rep!: |
|
23 |
pcpo_ep_pair |
|
24 |
"emb :: 'a::rep \<rightarrow> udom" |
|
25 |
"prj :: udom \<rightarrow> 'a::rep" |
|
26 |
unfolding pcpo_ep_pair_def |
|
27 |
by (rule ep_pair_emb_prj) |
|
28 |
||
29 |
lemmas emb_inverse = rep.e_inverse |
|
30 |
lemmas emb_prj_below = rep.e_p_below |
|
31 |
lemmas emb_eq_iff = rep.e_eq_iff |
|
32 |
lemmas emb_strict = rep.e_strict |
|
33 |
lemmas prj_strict = rep.p_strict |
|
34 |
||
35 |
||
36 |
subsection {* Making @{term rep} the default class *} |
|
37 |
||
38 |
text {* |
|
39 |
From now on, free type variables are assumed to be in class |
|
40 |
@{term rep}, unless specified otherwise. |
|
41 |
*} |
|
42 |
||
43 |
defaultsort rep |
|
44 |
||
45 |
subsection {* Representations of types *} |
|
46 |
||
47 |
text "A TypeRep is an algebraic deflation over the universe of values." |
|
48 |
||
49 |
types TypeRep = "udom alg_defl" |
|
50 |
translations "TypeRep" \<leftharpoondown> (type) "udom alg_defl" |
|
51 |
||
52 |
definition |
|
53 |
Rep_of :: "'a::rep itself \<Rightarrow> TypeRep" |
|
54 |
where |
|
55 |
"Rep_of TYPE('a::rep) = |
|
56 |
(\<Squnion>i. alg_defl_principal (Abs_fin_defl |
|
57 |
(emb oo (approx i :: 'a \<rightarrow> 'a) oo prj)))" |
|
58 |
||
59 |
syntax "_REP" :: "type \<Rightarrow> TypeRep" ("(1REP/(1'(_')))") |
|
60 |
translations "REP(t)" \<rightleftharpoons> "CONST Rep_of TYPE(t)" |
|
61 |
||
62 |
lemma cast_REP: |
|
63 |
"cast\<cdot>REP('a::rep) = (emb::'a \<rightarrow> udom) oo (prj::udom \<rightarrow> 'a)" |
|
64 |
proof - |
|
65 |
let ?a = "\<lambda>i. emb oo approx i oo (prj::udom \<rightarrow> 'a)" |
|
66 |
have a: "\<And>i. finite_deflation (?a i)" |
|
67 |
apply (rule rep.finite_deflation_e_d_p) |
|
68 |
apply (rule finite_deflation_approx) |
|
69 |
done |
|
70 |
show ?thesis |
|
71 |
unfolding Rep_of_def |
|
72 |
apply (subst contlub_cfun_arg) |
|
73 |
apply (rule chainI) |
|
74 |
apply (rule alg_defl.principal_mono) |
|
75 |
apply (rule Abs_fin_defl_mono [OF a a]) |
|
76 |
apply (rule chainE, simp) |
|
77 |
apply (subst cast_alg_defl_principal) |
|
78 |
apply (simp add: Abs_fin_defl_inverse a) |
|
79 |
apply (simp add: expand_cfun_eq lub_distribs) |
|
80 |
done |
|
81 |
qed |
|
82 |
||
83 |
lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a::rep) = cast\<cdot>REP('a)\<cdot>x" |
|
84 |
by (simp add: cast_REP) |
|
85 |
||
86 |
lemma in_REP_iff: |
|
87 |
"x ::: REP('a::rep) \<longleftrightarrow> emb\<cdot>((prj\<cdot>x)::'a) = x" |
|
88 |
by (simp add: in_deflation_def cast_REP) |
|
89 |
||
90 |
lemma prj_inverse: |
|
91 |
"x ::: REP('a::rep) \<Longrightarrow> emb\<cdot>((prj\<cdot>x)::'a) = x" |
|
92 |
by (simp only: in_REP_iff) |
|
93 |
||
94 |
lemma emb_in_REP [simp]: |
|
95 |
"emb\<cdot>(x::'a::rep) ::: REP('a)" |
|
96 |
by (simp add: in_REP_iff) |
|
97 |
||
98 |
subsection {* Coerce operator *} |
|
99 |
||
100 |
definition coerce :: "'a \<rightarrow> 'b" |
|
101 |
where "coerce = prj oo emb" |
|
102 |
||
103 |
lemma beta_coerce: "coerce\<cdot>x = prj\<cdot>(emb\<cdot>x)" |
|
104 |
by (simp add: coerce_def) |
|
105 |
||
106 |
lemma prj_emb: "prj\<cdot>(emb\<cdot>x) = coerce\<cdot>x" |
|
107 |
by (simp add: coerce_def) |
|
108 |
||
109 |
lemma coerce_strict [simp]: "coerce\<cdot>\<bottom> = \<bottom>" |
|
110 |
by (simp add: coerce_def) |
|
111 |
||
112 |
lemma coerce_eq_ID [simp]: "(coerce :: 'a \<rightarrow> 'a) = ID" |
|
113 |
by (rule ext_cfun, simp add: beta_coerce) |
|
114 |
||
115 |
lemma emb_coerce: |
|
116 |
"REP('a) \<sqsubseteq> REP('b) |
|
117 |
\<Longrightarrow> emb\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) = emb\<cdot>x" |
|
118 |
apply (simp add: beta_coerce) |
|
119 |
apply (rule prj_inverse) |
|
120 |
apply (erule subdeflationD) |
|
121 |
apply (rule emb_in_REP) |
|
122 |
done |
|
123 |
||
124 |
lemma coerce_prj: |
|
125 |
"REP('a) \<sqsubseteq> REP('b) |
|
126 |
\<Longrightarrow> (coerce::'b \<rightarrow> 'a)\<cdot>(prj\<cdot>x) = prj\<cdot>x" |
|
127 |
apply (simp add: coerce_def) |
|
128 |
apply (rule emb_eq_iff [THEN iffD1]) |
|
129 |
apply (simp only: emb_prj) |
|
130 |
apply (rule deflation_below_comp1) |
|
131 |
apply (rule deflation_cast) |
|
132 |
apply (rule deflation_cast) |
|
133 |
apply (erule monofun_cfun_arg) |
|
134 |
done |
|
135 |
||
136 |
lemma coerce_coerce [simp]: |
|
137 |
"REP('a) \<sqsubseteq> REP('b) |
|
138 |
\<Longrightarrow> coerce\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) = coerce\<cdot>x" |
|
139 |
by (simp add: beta_coerce prj_inverse subdeflationD) |
|
140 |
||
141 |
lemma coerce_inverse: |
|
142 |
"emb\<cdot>(x::'a) ::: REP('b) \<Longrightarrow> coerce\<cdot>(coerce\<cdot>x :: 'b) = x" |
|
143 |
by (simp only: beta_coerce prj_inverse emb_inverse) |
|
144 |
||
145 |
lemma coerce_type: |
|
146 |
"REP('a) \<sqsubseteq> REP('b) |
|
147 |
\<Longrightarrow> emb\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) ::: REP('a)" |
|
148 |
by (simp add: beta_coerce prj_inverse subdeflationD) |
|
149 |
||
150 |
lemma ep_pair_coerce: |
|
151 |
"REP('a) \<sqsubseteq> REP('b) |
|
152 |
\<Longrightarrow> ep_pair (coerce::'a \<rightarrow> 'b) (coerce::'b \<rightarrow> 'a)" |
|
153 |
apply (rule ep_pair.intro) |
|
154 |
apply simp |
|
155 |
apply (simp only: beta_coerce) |
|
156 |
apply (rule below_trans) |
|
157 |
apply (rule monofun_cfun_arg) |
|
158 |
apply (rule emb_prj_below) |
|
159 |
apply simp |
|
160 |
done |
|
161 |
||
162 |
subsection {* Proving a subtype is representable *} |
|
163 |
||
164 |
text {* |
|
165 |
Temporarily relax type constraints for @{term "approx"}, |
|
166 |
@{term emb}, and @{term prj}. |
|
167 |
*} |
|
168 |
||
169 |
setup {* Sign.add_const_constraint |
|
170 |
(@{const_name "approx"}, SOME @{typ "nat \<Rightarrow> 'a::cpo \<rightarrow> 'a"}) *} |
|
171 |
||
172 |
setup {* Sign.add_const_constraint |
|
173 |
(@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"}) *} |
|
174 |
||
175 |
setup {* Sign.add_const_constraint |
|
176 |
(@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"}) *} |
|
177 |
||
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
178 |
definition |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
179 |
repdef_approx :: |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
180 |
"('a::pcpo \<Rightarrow> udom) \<Rightarrow> (udom \<Rightarrow> 'a) \<Rightarrow> udom alg_defl \<Rightarrow> nat \<Rightarrow> 'a \<rightarrow> 'a" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
181 |
where |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
182 |
"repdef_approx Rep Abs t = (\<lambda>i. \<Lambda> x. Abs (cast\<cdot>(approx i\<cdot>t)\<cdot>(Rep x)))" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
183 |
|
33588 | 184 |
lemma typedef_rep_class: |
185 |
fixes Rep :: "'a::pcpo \<Rightarrow> udom" |
|
186 |
fixes Abs :: "udom \<Rightarrow> 'a::pcpo" |
|
187 |
fixes t :: TypeRep |
|
188 |
assumes type: "type_definition Rep Abs {x. x ::: t}" |
|
189 |
assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y" |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
190 |
assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
191 |
assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
192 |
assumes approx: "(approx :: nat \<Rightarrow> 'a \<rightarrow> 'a) \<equiv> repdef_approx Rep Abs t" |
33588 | 193 |
shows "OFCLASS('a, rep_class)" |
194 |
proof |
|
195 |
have adm: "adm (\<lambda>x. x \<in> {x. x ::: t})" |
|
196 |
by (simp add: adm_in_deflation) |
|
197 |
have emb_beta: "\<And>x. emb\<cdot>x = Rep x" |
|
198 |
unfolding emb |
|
199 |
apply (rule beta_cfun) |
|
200 |
apply (rule typedef_cont_Rep [OF type below adm]) |
|
201 |
done |
|
202 |
have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)" |
|
203 |
unfolding prj |
|
204 |
apply (rule beta_cfun) |
|
205 |
apply (rule typedef_cont_Abs [OF type below adm]) |
|
206 |
apply simp_all |
|
207 |
done |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
208 |
have cast_cast_approx: |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
209 |
"\<And>i x. cast\<cdot>t\<cdot>(cast\<cdot>(approx i\<cdot>t)\<cdot>x) = cast\<cdot>(approx i\<cdot>t)\<cdot>x" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
210 |
apply (rule cast_fixed) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
211 |
apply (rule subdeflationD) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
212 |
apply (rule approx.below) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
213 |
apply (rule cast_in_deflation) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
214 |
done |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
215 |
have approx': |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
216 |
"approx = (\<lambda>i. \<Lambda>(x::'a). prj\<cdot>(cast\<cdot>(approx i\<cdot>t)\<cdot>(emb\<cdot>x)))" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
217 |
unfolding approx repdef_approx_def |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
218 |
apply (subst cast_cast_approx [symmetric]) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
219 |
apply (simp add: prj_beta [symmetric] emb_beta [symmetric]) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
220 |
done |
33588 | 221 |
have emb_in_deflation: "\<And>x::'a. emb\<cdot>x ::: t" |
222 |
using type_definition.Rep [OF type] |
|
223 |
by (simp add: emb_beta) |
|
224 |
have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x" |
|
225 |
unfolding prj_beta |
|
226 |
apply (simp add: cast_fixed [OF emb_in_deflation]) |
|
227 |
apply (simp add: emb_beta type_definition.Rep_inverse [OF type]) |
|
228 |
done |
|
229 |
have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y" |
|
230 |
unfolding prj_beta emb_beta |
|
231 |
by (simp add: type_definition.Abs_inverse [OF type]) |
|
232 |
show "ep_pair (emb :: 'a \<rightarrow> udom) prj" |
|
233 |
apply default |
|
234 |
apply (simp add: prj_emb) |
|
235 |
apply (simp add: emb_prj cast.below) |
|
236 |
done |
|
237 |
show "chain (approx :: nat \<Rightarrow> 'a \<rightarrow> 'a)" |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
238 |
unfolding approx' by simp |
33588 | 239 |
show "\<And>x::'a. (\<Squnion>i. approx i\<cdot>x) = x" |
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
240 |
unfolding approx' |
33588 | 241 |
apply (simp add: lub_distribs) |
242 |
apply (subst cast_fixed [OF emb_in_deflation]) |
|
243 |
apply (rule prj_emb) |
|
244 |
done |
|
245 |
show "\<And>(i::nat) (x::'a). approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x" |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
246 |
unfolding approx' |
33588 | 247 |
apply simp |
248 |
apply (simp add: emb_prj) |
|
249 |
apply (simp add: cast_cast_approx) |
|
250 |
done |
|
251 |
show "\<And>i::nat. finite {x::'a. approx i\<cdot>x = x}" |
|
252 |
apply (rule_tac B="(\<lambda>x. prj\<cdot>x) ` {x. cast\<cdot>(approx i\<cdot>t)\<cdot>x = x}" |
|
253 |
in finite_subset) |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
254 |
apply (clarsimp simp add: approx') |
33588 | 255 |
apply (drule_tac f="\<lambda>x. emb\<cdot>x" in arg_cong) |
256 |
apply (rule image_eqI) |
|
257 |
apply (rule prj_emb [symmetric]) |
|
258 |
apply (simp add: emb_prj) |
|
259 |
apply (simp add: cast_cast_approx) |
|
260 |
apply (rule finite_imageI) |
|
261 |
apply (simp add: cast_approx_fixed_iff) |
|
262 |
apply (simp add: Collect_conj_eq) |
|
263 |
apply (simp add: finite_fixes_approx) |
|
264 |
done |
|
265 |
qed |
|
266 |
||
267 |
text {* Restore original typing constraints *} |
|
268 |
||
269 |
setup {* Sign.add_const_constraint |
|
270 |
(@{const_name "approx"}, SOME @{typ "nat \<Rightarrow> 'a::profinite \<rightarrow> 'a"}) *} |
|
271 |
||
272 |
setup {* Sign.add_const_constraint |
|
273 |
(@{const_name emb}, SOME @{typ "'a::rep \<rightarrow> udom"}) *} |
|
274 |
||
275 |
setup {* Sign.add_const_constraint |
|
276 |
(@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::rep"}) *} |
|
277 |
||
278 |
lemma typedef_REP: |
|
279 |
fixes Rep :: "'a::rep \<Rightarrow> udom" |
|
280 |
fixes Abs :: "udom \<Rightarrow> 'a::rep" |
|
281 |
fixes t :: TypeRep |
|
282 |
assumes type: "type_definition Rep Abs {x. x ::: t}" |
|
283 |
assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y" |
|
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
284 |
assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
285 |
assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))" |
33588 | 286 |
shows "REP('a) = t" |
287 |
proof - |
|
288 |
have adm: "adm (\<lambda>x. x \<in> {x. x ::: t})" |
|
289 |
by (simp add: adm_in_deflation) |
|
290 |
have emb_beta: "\<And>x. emb\<cdot>x = Rep x" |
|
291 |
unfolding emb |
|
292 |
apply (rule beta_cfun) |
|
293 |
apply (rule typedef_cont_Rep [OF type below adm]) |
|
294 |
done |
|
295 |
have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)" |
|
296 |
unfolding prj |
|
297 |
apply (rule beta_cfun) |
|
298 |
apply (rule typedef_cont_Abs [OF type below adm]) |
|
299 |
apply simp_all |
|
300 |
done |
|
301 |
have emb_in_deflation: "\<And>x::'a. emb\<cdot>x ::: t" |
|
302 |
using type_definition.Rep [OF type] |
|
303 |
by (simp add: emb_beta) |
|
304 |
have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x" |
|
305 |
unfolding prj_beta |
|
306 |
apply (simp add: cast_fixed [OF emb_in_deflation]) |
|
307 |
apply (simp add: emb_beta type_definition.Rep_inverse [OF type]) |
|
308 |
done |
|
309 |
have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y" |
|
310 |
unfolding prj_beta emb_beta |
|
311 |
by (simp add: type_definition.Abs_inverse [OF type]) |
|
312 |
show "REP('a) = t" |
|
313 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
314 |
apply (simp add: cast_REP emb_prj) |
|
315 |
done |
|
316 |
qed |
|
317 |
||
33679
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
318 |
lemma adm_mem_Collect_in_deflation: "adm (\<lambda>x. x \<in> {x. x ::: A})" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
319 |
unfolding mem_Collect_eq by (rule adm_in_deflation) |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
320 |
|
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
321 |
use "Tools/repdef.ML" |
331712879666
automate definition of representable domains from algebraic deflations
huffman
parents:
33589
diff
changeset
|
322 |
|
33588 | 323 |
|
324 |
subsection {* Instances of class @{text rep} *} |
|
325 |
||
326 |
subsubsection {* Universal Domain *} |
|
327 |
||
328 |
text "The Universal Domain itself is trivially representable." |
|
329 |
||
330 |
instantiation udom :: rep |
|
331 |
begin |
|
332 |
||
333 |
definition emb_udom_def [simp]: "emb = (ID :: udom \<rightarrow> udom)" |
|
334 |
definition prj_udom_def [simp]: "prj = (ID :: udom \<rightarrow> udom)" |
|
335 |
||
336 |
instance |
|
337 |
apply (intro_classes) |
|
338 |
apply (simp_all add: ep_pair.intro) |
|
339 |
done |
|
340 |
||
341 |
end |
|
342 |
||
343 |
subsubsection {* Lifted types *} |
|
344 |
||
345 |
instantiation lift :: (countable) rep |
|
346 |
begin |
|
347 |
||
348 |
definition emb_lift_def: |
|
349 |
"emb = udom_emb oo (FLIFT x. Def (to_nat x))" |
|
350 |
||
351 |
definition prj_lift_def: |
|
352 |
"prj = (FLIFT n. if (\<exists>x::'a::countable. n = to_nat x) |
|
353 |
then Def (THE x::'a. n = to_nat x) else \<bottom>) oo udom_prj" |
|
354 |
||
355 |
instance |
|
356 |
apply (intro_classes, unfold emb_lift_def prj_lift_def) |
|
357 |
apply (rule ep_pair_comp [OF _ ep_pair_udom]) |
|
358 |
apply (rule ep_pair.intro) |
|
359 |
apply (case_tac x, simp, simp) |
|
360 |
apply (case_tac y, simp, clarsimp) |
|
361 |
done |
|
362 |
||
363 |
end |
|
364 |
||
365 |
subsubsection {* Representable type constructors *} |
|
366 |
||
367 |
text "Functions between representable types are representable." |
|
368 |
||
369 |
instantiation "->" :: (rep, rep) rep |
|
370 |
begin |
|
371 |
||
372 |
definition emb_cfun_def: "emb = udom_emb oo cfun_map\<cdot>prj\<cdot>emb" |
|
373 |
definition prj_cfun_def: "prj = cfun_map\<cdot>emb\<cdot>prj oo udom_prj" |
|
374 |
||
375 |
instance |
|
376 |
apply (intro_classes, unfold emb_cfun_def prj_cfun_def) |
|
377 |
apply (intro ep_pair_comp ep_pair_cfun_map ep_pair_emb_prj ep_pair_udom) |
|
378 |
done |
|
379 |
||
380 |
end |
|
381 |
||
382 |
text "Strict products of representable types are representable." |
|
383 |
||
384 |
instantiation "**" :: (rep, rep) rep |
|
385 |
begin |
|
386 |
||
387 |
definition emb_sprod_def: "emb = udom_emb oo sprod_map\<cdot>emb\<cdot>emb" |
|
388 |
definition prj_sprod_def: "prj = sprod_map\<cdot>prj\<cdot>prj oo udom_prj" |
|
389 |
||
390 |
instance |
|
391 |
apply (intro_classes, unfold emb_sprod_def prj_sprod_def) |
|
392 |
apply (intro ep_pair_comp ep_pair_sprod_map ep_pair_emb_prj ep_pair_udom) |
|
393 |
done |
|
394 |
||
395 |
end |
|
396 |
||
397 |
text "Strict sums of representable types are representable." |
|
398 |
||
399 |
instantiation "++" :: (rep, rep) rep |
|
400 |
begin |
|
401 |
||
402 |
definition emb_ssum_def: "emb = udom_emb oo ssum_map\<cdot>emb\<cdot>emb" |
|
403 |
definition prj_ssum_def: "prj = ssum_map\<cdot>prj\<cdot>prj oo udom_prj" |
|
404 |
||
405 |
instance |
|
406 |
apply (intro_classes, unfold emb_ssum_def prj_ssum_def) |
|
407 |
apply (intro ep_pair_comp ep_pair_ssum_map ep_pair_emb_prj ep_pair_udom) |
|
408 |
done |
|
409 |
||
410 |
end |
|
411 |
||
412 |
text "Up of a representable type is representable." |
|
413 |
||
414 |
instantiation "u" :: (rep) rep |
|
415 |
begin |
|
416 |
||
417 |
definition emb_u_def: "emb = udom_emb oo u_map\<cdot>emb" |
|
418 |
definition prj_u_def: "prj = u_map\<cdot>prj oo udom_prj" |
|
419 |
||
420 |
instance |
|
421 |
apply (intro_classes, unfold emb_u_def prj_u_def) |
|
422 |
apply (intro ep_pair_comp ep_pair_u_map ep_pair_emb_prj ep_pair_udom) |
|
423 |
done |
|
424 |
||
425 |
end |
|
426 |
||
427 |
text "Cartesian products of representable types are representable." |
|
428 |
||
429 |
instantiation "*" :: (rep, rep) rep |
|
430 |
begin |
|
431 |
||
432 |
definition emb_cprod_def: "emb = udom_emb oo cprod_map\<cdot>emb\<cdot>emb" |
|
433 |
definition prj_cprod_def: "prj = cprod_map\<cdot>prj\<cdot>prj oo udom_prj" |
|
434 |
||
435 |
instance |
|
436 |
apply (intro_classes, unfold emb_cprod_def prj_cprod_def) |
|
437 |
apply (intro ep_pair_comp ep_pair_cprod_map ep_pair_emb_prj ep_pair_udom) |
|
438 |
done |
|
439 |
||
440 |
end |
|
441 |
||
442 |
text "Upper powerdomain of a representable type is representable." |
|
443 |
||
444 |
instantiation upper_pd :: (rep) rep |
|
445 |
begin |
|
446 |
||
447 |
definition emb_upper_pd_def: "emb = udom_emb oo upper_map\<cdot>emb" |
|
448 |
definition prj_upper_pd_def: "prj = upper_map\<cdot>prj oo udom_prj" |
|
449 |
||
450 |
instance |
|
451 |
apply (intro_classes, unfold emb_upper_pd_def prj_upper_pd_def) |
|
452 |
apply (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj ep_pair_udom) |
|
453 |
done |
|
454 |
||
455 |
end |
|
456 |
||
457 |
text "Lower powerdomain of a representable type is representable." |
|
458 |
||
459 |
instantiation lower_pd :: (rep) rep |
|
460 |
begin |
|
461 |
||
462 |
definition emb_lower_pd_def: "emb = udom_emb oo lower_map\<cdot>emb" |
|
463 |
definition prj_lower_pd_def: "prj = lower_map\<cdot>prj oo udom_prj" |
|
464 |
||
465 |
instance |
|
466 |
apply (intro_classes, unfold emb_lower_pd_def prj_lower_pd_def) |
|
467 |
apply (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj ep_pair_udom) |
|
468 |
done |
|
469 |
||
470 |
end |
|
471 |
||
472 |
text "Convex powerdomain of a representable type is representable." |
|
473 |
||
474 |
instantiation convex_pd :: (rep) rep |
|
475 |
begin |
|
476 |
||
477 |
definition emb_convex_pd_def: "emb = udom_emb oo convex_map\<cdot>emb" |
|
478 |
definition prj_convex_pd_def: "prj = convex_map\<cdot>prj oo udom_prj" |
|
479 |
||
480 |
instance |
|
481 |
apply (intro_classes, unfold emb_convex_pd_def prj_convex_pd_def) |
|
482 |
apply (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj ep_pair_udom) |
|
483 |
done |
|
484 |
||
485 |
end |
|
486 |
||
487 |
subsection {* Finite deflation lemmas *} |
|
488 |
||
489 |
text "TODO: move these lemmas somewhere else" |
|
490 |
||
491 |
lemma finite_compact_range_imp_finite_range: |
|
492 |
fixes d :: "'a::profinite \<rightarrow> 'b::cpo" |
|
493 |
assumes "finite ((\<lambda>x. d\<cdot>x) ` {x. compact x})" |
|
494 |
shows "finite (range (\<lambda>x. d\<cdot>x))" |
|
495 |
proof (rule finite_subset [OF _ prems]) |
|
496 |
{ |
|
497 |
fix x :: 'a |
|
498 |
have "range (\<lambda>i. d\<cdot>(approx i\<cdot>x)) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}" |
|
499 |
by auto |
|
500 |
hence "finite (range (\<lambda>i. d\<cdot>(approx i\<cdot>x)))" |
|
501 |
using prems by (rule finite_subset) |
|
502 |
hence "finite_chain (\<lambda>i. d\<cdot>(approx i\<cdot>x))" |
|
503 |
by (simp add: finite_range_imp_finch) |
|
504 |
hence "\<exists>i. (\<Squnion>i. d\<cdot>(approx i\<cdot>x)) = d\<cdot>(approx i\<cdot>x)" |
|
505 |
by (simp add: finite_chain_def maxinch_is_thelub) |
|
506 |
hence "\<exists>i. d\<cdot>x = d\<cdot>(approx i\<cdot>x)" |
|
507 |
by (simp add: lub_distribs) |
|
508 |
hence "d\<cdot>x \<in> (\<lambda>x. d\<cdot>x) ` {x. compact x}" |
|
509 |
by auto |
|
510 |
} |
|
511 |
thus "range (\<lambda>x. d\<cdot>x) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}" |
|
512 |
by clarsimp |
|
513 |
qed |
|
514 |
||
515 |
lemma finite_deflation_upper_map: |
|
516 |
assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)" |
|
517 |
proof (intro finite_deflation.intro finite_deflation_axioms.intro) |
|
518 |
interpret d: finite_deflation d by fact |
|
519 |
have "deflation d" by fact |
|
520 |
thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map) |
|
521 |
have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range) |
|
522 |
hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))" |
|
523 |
by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject) |
|
524 |
hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp |
|
525 |
hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" |
|
526 |
by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject) |
|
527 |
hence "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp |
|
528 |
hence "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` range upper_principal)" |
|
529 |
apply (rule finite_subset [COMP swap_prems_rl]) |
|
530 |
apply (clarsimp, rename_tac t) |
|
531 |
apply (induct_tac t rule: pd_basis_induct) |
|
532 |
apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit) |
|
533 |
apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b") |
|
534 |
apply clarsimp |
|
535 |
apply (rule imageI) |
|
536 |
apply (rule vimageI2) |
|
537 |
apply (simp add: Rep_PDUnit) |
|
538 |
apply (rule image_eqI) |
|
539 |
apply (erule sym) |
|
540 |
apply simp |
|
541 |
apply (rule exI) |
|
542 |
apply (rule Abs_compact_basis_inverse [symmetric]) |
|
543 |
apply (simp add: d.compact) |
|
544 |
apply (simp only: upper_plus_principal [symmetric] upper_map_plus) |
|
545 |
apply clarsimp |
|
546 |
apply (rule imageI) |
|
547 |
apply (rule vimageI2) |
|
548 |
apply (simp add: Rep_PDPlus) |
|
549 |
done |
|
550 |
moreover have "{xs::'a upper_pd. compact xs} = range upper_principal" |
|
551 |
by (auto dest: upper_pd.compact_imp_principal) |
|
552 |
ultimately have "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` {xs::'a upper_pd. compact xs})" |
|
553 |
by simp |
|
554 |
hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))" |
|
555 |
by (rule finite_compact_range_imp_finite_range) |
|
556 |
thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}" |
|
557 |
by (rule finite_range_imp_finite_fixes) |
|
558 |
qed |
|
559 |
||
560 |
lemma finite_deflation_lower_map: |
|
561 |
assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)" |
|
562 |
proof (intro finite_deflation.intro finite_deflation_axioms.intro) |
|
563 |
interpret d: finite_deflation d by fact |
|
564 |
have "deflation d" by fact |
|
565 |
thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map) |
|
566 |
have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range) |
|
567 |
hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))" |
|
568 |
by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject) |
|
569 |
hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp |
|
570 |
hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" |
|
571 |
by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject) |
|
572 |
hence "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp |
|
573 |
hence "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` range lower_principal)" |
|
574 |
apply (rule finite_subset [COMP swap_prems_rl]) |
|
575 |
apply (clarsimp, rename_tac t) |
|
576 |
apply (induct_tac t rule: pd_basis_induct) |
|
577 |
apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit) |
|
578 |
apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b") |
|
579 |
apply clarsimp |
|
580 |
apply (rule imageI) |
|
581 |
apply (rule vimageI2) |
|
582 |
apply (simp add: Rep_PDUnit) |
|
583 |
apply (rule image_eqI) |
|
584 |
apply (erule sym) |
|
585 |
apply simp |
|
586 |
apply (rule exI) |
|
587 |
apply (rule Abs_compact_basis_inverse [symmetric]) |
|
588 |
apply (simp add: d.compact) |
|
589 |
apply (simp only: lower_plus_principal [symmetric] lower_map_plus) |
|
590 |
apply clarsimp |
|
591 |
apply (rule imageI) |
|
592 |
apply (rule vimageI2) |
|
593 |
apply (simp add: Rep_PDPlus) |
|
594 |
done |
|
595 |
moreover have "{xs::'a lower_pd. compact xs} = range lower_principal" |
|
596 |
by (auto dest: lower_pd.compact_imp_principal) |
|
597 |
ultimately have "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` {xs::'a lower_pd. compact xs})" |
|
598 |
by simp |
|
599 |
hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))" |
|
600 |
by (rule finite_compact_range_imp_finite_range) |
|
601 |
thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}" |
|
602 |
by (rule finite_range_imp_finite_fixes) |
|
603 |
qed |
|
604 |
||
605 |
lemma finite_deflation_convex_map: |
|
606 |
assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)" |
|
607 |
proof (intro finite_deflation.intro finite_deflation_axioms.intro) |
|
608 |
interpret d: finite_deflation d by fact |
|
609 |
have "deflation d" by fact |
|
610 |
thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map) |
|
611 |
have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range) |
|
612 |
hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))" |
|
613 |
by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject) |
|
614 |
hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp |
|
615 |
hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" |
|
616 |
by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject) |
|
617 |
hence "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp |
|
618 |
hence "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` range convex_principal)" |
|
619 |
apply (rule finite_subset [COMP swap_prems_rl]) |
|
620 |
apply (clarsimp, rename_tac t) |
|
621 |
apply (induct_tac t rule: pd_basis_induct) |
|
622 |
apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit) |
|
623 |
apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b") |
|
624 |
apply clarsimp |
|
625 |
apply (rule imageI) |
|
626 |
apply (rule vimageI2) |
|
627 |
apply (simp add: Rep_PDUnit) |
|
628 |
apply (rule image_eqI) |
|
629 |
apply (erule sym) |
|
630 |
apply simp |
|
631 |
apply (rule exI) |
|
632 |
apply (rule Abs_compact_basis_inverse [symmetric]) |
|
633 |
apply (simp add: d.compact) |
|
634 |
apply (simp only: convex_plus_principal [symmetric] convex_map_plus) |
|
635 |
apply clarsimp |
|
636 |
apply (rule imageI) |
|
637 |
apply (rule vimageI2) |
|
638 |
apply (simp add: Rep_PDPlus) |
|
639 |
done |
|
640 |
moreover have "{xs::'a convex_pd. compact xs} = range convex_principal" |
|
641 |
by (auto dest: convex_pd.compact_imp_principal) |
|
642 |
ultimately have "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` {xs::'a convex_pd. compact xs})" |
|
643 |
by simp |
|
644 |
hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))" |
|
645 |
by (rule finite_compact_range_imp_finite_range) |
|
646 |
thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}" |
|
647 |
by (rule finite_range_imp_finite_fixes) |
|
648 |
qed |
|
649 |
||
650 |
subsection {* Type combinators *} |
|
651 |
||
652 |
definition |
|
653 |
TypeRep_fun1 :: |
|
654 |
"((udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a)) |
|
655 |
\<Rightarrow> (TypeRep \<rightarrow> TypeRep)" |
|
656 |
where |
|
657 |
"TypeRep_fun1 f = |
|
658 |
alg_defl.basis_fun (\<lambda>a. |
|
659 |
alg_defl_principal ( |
|
660 |
Abs_fin_defl (udom_emb oo f\<cdot>(Rep_fin_defl a) oo udom_prj)))" |
|
661 |
||
662 |
definition |
|
663 |
TypeRep_fun2 :: |
|
664 |
"((udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a)) |
|
665 |
\<Rightarrow> (TypeRep \<rightarrow> TypeRep \<rightarrow> TypeRep)" |
|
666 |
where |
|
667 |
"TypeRep_fun2 f = |
|
668 |
alg_defl.basis_fun (\<lambda>a. |
|
669 |
alg_defl.basis_fun (\<lambda>b. |
|
670 |
alg_defl_principal ( |
|
671 |
Abs_fin_defl (udom_emb oo |
|
672 |
f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj))))" |
|
673 |
||
674 |
definition "one_typ = REP(one)" |
|
675 |
definition "tr_typ = REP(tr)" |
|
676 |
definition "cfun_typ = TypeRep_fun2 cfun_map" |
|
677 |
definition "ssum_typ = TypeRep_fun2 ssum_map" |
|
678 |
definition "sprod_typ = TypeRep_fun2 sprod_map" |
|
679 |
definition "cprod_typ = TypeRep_fun2 cprod_map" |
|
680 |
definition "u_typ = TypeRep_fun1 u_map" |
|
681 |
definition "upper_typ = TypeRep_fun1 upper_map" |
|
682 |
definition "lower_typ = TypeRep_fun1 lower_map" |
|
683 |
definition "convex_typ = TypeRep_fun1 convex_map" |
|
684 |
||
685 |
lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b" |
|
686 |
unfolding below_fin_defl_def . |
|
687 |
||
688 |
lemma cast_TypeRep_fun1: |
|
689 |
assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)" |
|
690 |
shows "cast\<cdot>(TypeRep_fun1 f\<cdot>A) = udom_emb oo f\<cdot>(cast\<cdot>A) oo udom_prj" |
|
691 |
proof - |
|
692 |
have 1: "\<And>a. finite_deflation (udom_emb oo f\<cdot>(Rep_fin_defl a) oo udom_prj)" |
|
693 |
apply (rule ep_pair.finite_deflation_e_d_p [OF ep_pair_udom]) |
|
694 |
apply (rule f, rule finite_deflation_Rep_fin_defl) |
|
695 |
done |
|
696 |
show ?thesis |
|
697 |
by (induct A rule: alg_defl.principal_induct, simp) |
|
698 |
(simp only: TypeRep_fun1_def |
|
699 |
alg_defl.basis_fun_principal |
|
700 |
alg_defl.basis_fun_mono |
|
701 |
alg_defl.principal_mono |
|
702 |
Abs_fin_defl_mono [OF 1 1] |
|
703 |
monofun_cfun below_refl |
|
704 |
Rep_fin_defl_mono |
|
705 |
cast_alg_defl_principal |
|
706 |
Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1]) |
|
707 |
qed |
|
708 |
||
709 |
lemma cast_TypeRep_fun2: |
|
710 |
assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow> |
|
711 |
finite_deflation (f\<cdot>a\<cdot>b)" |
|
712 |
shows "cast\<cdot>(TypeRep_fun2 f\<cdot>A\<cdot>B) = udom_emb oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj" |
|
713 |
proof - |
|
714 |
have 1: "\<And>a b. finite_deflation |
|
715 |
(udom_emb oo f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj)" |
|
716 |
apply (rule ep_pair.finite_deflation_e_d_p [OF ep_pair_udom]) |
|
717 |
apply (rule f, (rule finite_deflation_Rep_fin_defl)+) |
|
718 |
done |
|
719 |
show ?thesis |
|
720 |
by (induct A B rule: alg_defl.principal_induct2, simp, simp) |
|
721 |
(simp only: TypeRep_fun2_def |
|
722 |
alg_defl.basis_fun_principal |
|
723 |
alg_defl.basis_fun_mono |
|
724 |
alg_defl.principal_mono |
|
725 |
Abs_fin_defl_mono [OF 1 1] |
|
726 |
monofun_cfun below_refl |
|
727 |
Rep_fin_defl_mono |
|
728 |
cast_alg_defl_principal |
|
729 |
Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1]) |
|
730 |
qed |
|
731 |
||
732 |
lemma cast_cfun_typ: |
|
733 |
"cast\<cdot>(cfun_typ\<cdot>A\<cdot>B) = udom_emb oo cfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj" |
|
734 |
unfolding cfun_typ_def |
|
735 |
apply (rule cast_TypeRep_fun2) |
|
736 |
apply (erule (1) finite_deflation_cfun_map) |
|
737 |
done |
|
738 |
||
739 |
lemma cast_ssum_typ: |
|
740 |
"cast\<cdot>(ssum_typ\<cdot>A\<cdot>B) = udom_emb oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj" |
|
741 |
unfolding ssum_typ_def |
|
742 |
apply (rule cast_TypeRep_fun2) |
|
743 |
apply (erule (1) finite_deflation_ssum_map) |
|
744 |
done |
|
745 |
||
746 |
lemma cast_sprod_typ: |
|
747 |
"cast\<cdot>(sprod_typ\<cdot>A\<cdot>B) = udom_emb oo sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj" |
|
748 |
unfolding sprod_typ_def |
|
749 |
apply (rule cast_TypeRep_fun2) |
|
750 |
apply (erule (1) finite_deflation_sprod_map) |
|
751 |
done |
|
752 |
||
753 |
lemma cast_cprod_typ: |
|
754 |
"cast\<cdot>(cprod_typ\<cdot>A\<cdot>B) = udom_emb oo cprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj" |
|
755 |
unfolding cprod_typ_def |
|
756 |
apply (rule cast_TypeRep_fun2) |
|
757 |
apply (erule (1) finite_deflation_cprod_map) |
|
758 |
done |
|
759 |
||
760 |
lemma cast_u_typ: |
|
761 |
"cast\<cdot>(u_typ\<cdot>A) = udom_emb oo u_map\<cdot>(cast\<cdot>A) oo udom_prj" |
|
762 |
unfolding u_typ_def |
|
763 |
apply (rule cast_TypeRep_fun1) |
|
764 |
apply (erule finite_deflation_u_map) |
|
765 |
done |
|
766 |
||
767 |
lemma cast_upper_typ: |
|
768 |
"cast\<cdot>(upper_typ\<cdot>A) = udom_emb oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj" |
|
769 |
unfolding upper_typ_def |
|
770 |
apply (rule cast_TypeRep_fun1) |
|
771 |
apply (erule finite_deflation_upper_map) |
|
772 |
done |
|
773 |
||
774 |
lemma cast_lower_typ: |
|
775 |
"cast\<cdot>(lower_typ\<cdot>A) = udom_emb oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj" |
|
776 |
unfolding lower_typ_def |
|
777 |
apply (rule cast_TypeRep_fun1) |
|
778 |
apply (erule finite_deflation_lower_map) |
|
779 |
done |
|
780 |
||
781 |
lemma cast_convex_typ: |
|
782 |
"cast\<cdot>(convex_typ\<cdot>A) = udom_emb oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj" |
|
783 |
unfolding convex_typ_def |
|
784 |
apply (rule cast_TypeRep_fun1) |
|
785 |
apply (erule finite_deflation_convex_map) |
|
786 |
done |
|
787 |
||
788 |
text {* REP of type constructor = type combinator *} |
|
789 |
||
790 |
lemma REP_one: "REP(one) = one_typ" |
|
791 |
by (simp only: one_typ_def) |
|
792 |
||
793 |
lemma REP_tr: "REP(tr) = tr_typ" |
|
794 |
by (simp only: tr_typ_def) |
|
795 |
||
796 |
lemma REP_cfun: "REP('a \<rightarrow> 'b) = cfun_typ\<cdot>REP('a)\<cdot>REP('b)" |
|
797 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
798 |
apply (simp add: cast_REP cast_cfun_typ) |
|
799 |
apply (simp add: cfun_map_def) |
|
800 |
apply (simp only: prj_cfun_def emb_cfun_def) |
|
801 |
apply (simp add: expand_cfun_eq ep_pair.e_eq_iff [OF ep_pair_udom]) |
|
802 |
done |
|
803 |
||
804 |
||
805 |
lemma REP_ssum: "REP('a \<oplus> 'b) = ssum_typ\<cdot>REP('a)\<cdot>REP('b)" |
|
806 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
807 |
apply (simp add: cast_REP cast_ssum_typ) |
|
808 |
apply (simp add: prj_ssum_def) |
|
809 |
apply (simp add: emb_ssum_def) |
|
810 |
apply (simp add: ssum_map_map cfcomp1) |
|
811 |
done |
|
812 |
||
813 |
lemma REP_sprod: "REP('a \<otimes> 'b) = sprod_typ\<cdot>REP('a)\<cdot>REP('b)" |
|
814 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
815 |
apply (simp add: cast_REP cast_sprod_typ) |
|
816 |
apply (simp add: prj_sprod_def) |
|
817 |
apply (simp add: emb_sprod_def) |
|
818 |
apply (simp add: sprod_map_map cfcomp1) |
|
819 |
done |
|
820 |
||
821 |
lemma REP_cprod: "REP('a \<times> 'b) = cprod_typ\<cdot>REP('a)\<cdot>REP('b)" |
|
822 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
823 |
apply (simp add: cast_REP cast_cprod_typ) |
|
824 |
apply (simp add: prj_cprod_def) |
|
825 |
apply (simp add: emb_cprod_def) |
|
826 |
apply (simp add: cprod_map_map cfcomp1) |
|
827 |
done |
|
828 |
||
829 |
lemma REP_up: "REP('a u) = u_typ\<cdot>REP('a)" |
|
830 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
831 |
apply (simp add: cast_REP cast_u_typ) |
|
832 |
apply (simp add: prj_u_def) |
|
833 |
apply (simp add: emb_u_def) |
|
834 |
apply (simp add: u_map_map cfcomp1) |
|
835 |
done |
|
836 |
||
837 |
lemma REP_upper: "REP('a upper_pd) = upper_typ\<cdot>REP('a)" |
|
838 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
839 |
apply (simp add: cast_REP cast_upper_typ) |
|
840 |
apply (simp add: prj_upper_pd_def) |
|
841 |
apply (simp add: emb_upper_pd_def) |
|
842 |
apply (simp add: upper_map_map cfcomp1) |
|
843 |
done |
|
844 |
||
845 |
lemma REP_lower: "REP('a lower_pd) = lower_typ\<cdot>REP('a)" |
|
846 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
847 |
apply (simp add: cast_REP cast_lower_typ) |
|
848 |
apply (simp add: prj_lower_pd_def) |
|
849 |
apply (simp add: emb_lower_pd_def) |
|
850 |
apply (simp add: lower_map_map cfcomp1) |
|
851 |
done |
|
852 |
||
853 |
lemma REP_convex: "REP('a convex_pd) = convex_typ\<cdot>REP('a)" |
|
854 |
apply (rule cast_eq_imp_eq, rule ext_cfun) |
|
855 |
apply (simp add: cast_REP cast_convex_typ) |
|
856 |
apply (simp add: prj_convex_pd_def) |
|
857 |
apply (simp add: emb_convex_pd_def) |
|
858 |
apply (simp add: convex_map_map cfcomp1) |
|
859 |
done |
|
860 |
||
861 |
lemmas REP_simps = |
|
862 |
REP_one |
|
863 |
REP_tr |
|
864 |
REP_cfun |
|
865 |
REP_ssum |
|
866 |
REP_sprod |
|
867 |
REP_cprod |
|
868 |
REP_up |
|
869 |
REP_upper |
|
870 |
REP_lower |
|
871 |
REP_convex |
|
872 |
||
873 |
subsection {* Isomorphic deflations *} |
|
874 |
||
875 |
definition |
|
876 |
isodefl :: "('a::rep \<rightarrow> 'a) \<Rightarrow> udom alg_defl \<Rightarrow> bool" |
|
877 |
where |
|
878 |
"isodefl d t \<longleftrightarrow> cast\<cdot>t = emb oo d oo prj" |
|
879 |
||
880 |
lemma isodeflI: "(\<And>x. cast\<cdot>t\<cdot>x = emb\<cdot>(d\<cdot>(prj\<cdot>x))) \<Longrightarrow> isodefl d t" |
|
881 |
unfolding isodefl_def by (simp add: ext_cfun) |
|
882 |
||
883 |
lemma cast_isodefl: "isodefl d t \<Longrightarrow> cast\<cdot>t = (\<Lambda> x. emb\<cdot>(d\<cdot>(prj\<cdot>x)))" |
|
884 |
unfolding isodefl_def by (simp add: ext_cfun) |
|
885 |
||
886 |
lemma isodefl_strict: "isodefl d t \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>" |
|
887 |
unfolding isodefl_def |
|
888 |
by (drule cfun_fun_cong [where x="\<bottom>"], simp) |
|
889 |
||
890 |
lemma isodefl_imp_deflation: |
|
891 |
fixes d :: "'a::rep \<rightarrow> 'a" |
|
892 |
assumes "isodefl d t" shows "deflation d" |
|
893 |
proof |
|
894 |
note prems [unfolded isodefl_def, simp] |
|
895 |
fix x :: 'a |
|
896 |
show "d\<cdot>(d\<cdot>x) = d\<cdot>x" |
|
897 |
using cast.idem [of t "emb\<cdot>x"] by simp |
|
898 |
show "d\<cdot>x \<sqsubseteq> x" |
|
899 |
using cast.below [of t "emb\<cdot>x"] by simp |
|
900 |
qed |
|
901 |
||
902 |
lemma isodefl_ID_REP: "isodefl (ID :: 'a \<rightarrow> 'a) REP('a)" |
|
903 |
unfolding isodefl_def by (simp add: cast_REP) |
|
904 |
||
905 |
lemma isodefl_REP_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) REP('a) \<Longrightarrow> d = ID" |
|
906 |
unfolding isodefl_def |
|
907 |
apply (simp add: cast_REP) |
|
908 |
apply (simp add: expand_cfun_eq) |
|
909 |
apply (rule allI) |
|
910 |
apply (drule_tac x="emb\<cdot>x" in spec) |
|
911 |
apply simp |
|
912 |
done |
|
913 |
||
914 |
lemma isodefl_bottom: "isodefl \<bottom> \<bottom>" |
|
915 |
unfolding isodefl_def by (simp add: expand_cfun_eq) |
|
916 |
||
917 |
lemma adm_isodefl: |
|
918 |
"cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. isodefl (f x) (g x))" |
|
919 |
unfolding isodefl_def by simp |
|
920 |
||
921 |
lemma isodefl_lub: |
|
922 |
assumes "chain d" and "chain t" |
|
923 |
assumes "\<And>i. isodefl (d i) (t i)" |
|
924 |
shows "isodefl (\<Squnion>i. d i) (\<Squnion>i. t i)" |
|
925 |
using prems unfolding isodefl_def |
|
926 |
by (simp add: contlub_cfun_arg contlub_cfun_fun) |
|
927 |
||
928 |
lemma isodefl_fix: |
|
929 |
assumes "\<And>d t. isodefl d t \<Longrightarrow> isodefl (f\<cdot>d) (g\<cdot>t)" |
|
930 |
shows "isodefl (fix\<cdot>f) (fix\<cdot>g)" |
|
931 |
unfolding fix_def2 |
|
932 |
apply (rule isodefl_lub, simp, simp) |
|
933 |
apply (induct_tac i) |
|
934 |
apply (simp add: isodefl_bottom) |
|
935 |
apply (simp add: prems) |
|
936 |
done |
|
937 |
||
938 |
lemma isodefl_coerce: |
|
939 |
fixes d :: "'a \<rightarrow> 'a" |
|
940 |
assumes REP: "REP('b) = REP('a)" |
|
941 |
shows "isodefl d t \<Longrightarrow> isodefl (coerce oo d oo coerce :: 'b \<rightarrow> 'b) t" |
|
942 |
unfolding isodefl_def |
|
943 |
apply (simp add: expand_cfun_eq) |
|
944 |
apply (simp add: emb_coerce coerce_prj REP) |
|
945 |
done |
|
946 |
||
947 |
lemma isodefl_cfun: |
|
948 |
"isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow> |
|
949 |
isodefl (cfun_map\<cdot>d1\<cdot>d2) (cfun_typ\<cdot>t1\<cdot>t2)" |
|
950 |
apply (rule isodeflI) |
|
951 |
apply (simp add: cast_cfun_typ cast_isodefl) |
|
952 |
apply (simp add: emb_cfun_def prj_cfun_def) |
|
953 |
apply (simp add: cfun_map_map cfcomp1) |
|
954 |
done |
|
955 |
||
956 |
lemma isodefl_ssum: |
|
957 |
"isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow> |
|
958 |
isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_typ\<cdot>t1\<cdot>t2)" |
|
959 |
apply (rule isodeflI) |
|
960 |
apply (simp add: cast_ssum_typ cast_isodefl) |
|
961 |
apply (simp add: emb_ssum_def prj_ssum_def) |
|
962 |
apply (simp add: ssum_map_map isodefl_strict) |
|
963 |
done |
|
964 |
||
965 |
lemma isodefl_sprod: |
|
966 |
"isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow> |
|
967 |
isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_typ\<cdot>t1\<cdot>t2)" |
|
968 |
apply (rule isodeflI) |
|
969 |
apply (simp add: cast_sprod_typ cast_isodefl) |
|
970 |
apply (simp add: emb_sprod_def prj_sprod_def) |
|
971 |
apply (simp add: sprod_map_map isodefl_strict) |
|
972 |
done |
|
973 |
||
974 |
lemma isodefl_u: |
|
975 |
"isodefl d t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_typ\<cdot>t)" |
|
976 |
apply (rule isodeflI) |
|
977 |
apply (simp add: cast_u_typ cast_isodefl) |
|
978 |
apply (simp add: emb_u_def prj_u_def) |
|
979 |
apply (simp add: u_map_map) |
|
980 |
done |
|
981 |
||
982 |
lemma isodefl_one: "isodefl (ID :: one \<rightarrow> one) one_typ" |
|
983 |
unfolding one_typ_def by (rule isodefl_ID_REP) |
|
984 |
||
985 |
lemma isodefl_tr: "isodefl (ID :: tr \<rightarrow> tr) tr_typ" |
|
986 |
unfolding tr_typ_def by (rule isodefl_ID_REP) |
|
987 |
||
988 |
lemma isodefl_upper: |
|
989 |
"isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_typ\<cdot>t)" |
|
990 |
apply (rule isodeflI) |
|
991 |
apply (simp add: cast_upper_typ cast_isodefl) |
|
992 |
apply (simp add: emb_upper_pd_def prj_upper_pd_def) |
|
993 |
apply (simp add: upper_map_map) |
|
994 |
done |
|
995 |
||
996 |
lemma isodefl_lower: |
|
997 |
"isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_typ\<cdot>t)" |
|
998 |
apply (rule isodeflI) |
|
999 |
apply (simp add: cast_lower_typ cast_isodefl) |
|
1000 |
apply (simp add: emb_lower_pd_def prj_lower_pd_def) |
|
1001 |
apply (simp add: lower_map_map) |
|
1002 |
done |
|
1003 |
||
1004 |
lemma isodefl_convex: |
|
1005 |
"isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_typ\<cdot>t)" |
|
1006 |
apply (rule isodeflI) |
|
1007 |
apply (simp add: cast_convex_typ cast_isodefl) |
|
1008 |
apply (simp add: emb_convex_pd_def prj_convex_pd_def) |
|
1009 |
apply (simp add: convex_map_map) |
|
1010 |
done |
|
1011 |
||
1012 |
end |