--- a/src/HOLCF/Ssum.thy Thu Nov 05 11:36:30 2009 -0800
+++ b/src/HOLCF/Ssum.thy Thu Nov 05 11:47:00 2009 -0800
@@ -210,6 +210,72 @@
apply (case_tac y, simp_all add: flat_below_iff)
done
+subsection {* Map function for strict sums *}
+
+definition
+ ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
+where
+ "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"
+
+lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
+unfolding ssum_map_def by simp
+
+lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
+unfolding ssum_map_def by simp
+
+lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
+unfolding ssum_map_def by simp
+
+lemma ep_pair_ssum_map:
+ assumes "ep_pair e1 p1" and "ep_pair e2 p2"
+ shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
+proof
+ interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
+ interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
+ fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
+ by (induct x) simp_all
+ fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
+ apply (induct y, simp)
+ apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
+ apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
+ done
+qed
+
+lemma deflation_ssum_map:
+ assumes "deflation d1" and "deflation d2"
+ shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
+proof
+ interpret d1: deflation d1 by fact
+ interpret d2: deflation d2 by fact
+ fix x
+ show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
+ apply (induct x, simp)
+ apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
+ apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
+ done
+ show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
+ apply (induct x, simp)
+ apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
+ apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
+ done
+qed
+
+lemma finite_deflation_ssum_map:
+ assumes "finite_deflation d1" and "finite_deflation d2"
+ shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
+proof (intro finite_deflation.intro finite_deflation_axioms.intro)
+ interpret d1: finite_deflation d1 by fact
+ interpret d2: finite_deflation d2 by fact
+ have "deflation d1" and "deflation d2" by fact+
+ thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
+ have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
+ (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
+ (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
+ by (rule subsetI, case_tac x, simp_all)
+ thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
+ by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
+qed
+
subsection {* Strict sum is a bifinite domain *}
instantiation "++" :: (bifinite, bifinite) bifinite
@@ -217,7 +283,7 @@
definition
approx_ssum_def:
- "approx = (\<lambda>n. sscase\<cdot>(\<Lambda> x. sinl\<cdot>(approx n\<cdot>x))\<cdot>(\<Lambda> y. sinr\<cdot>(approx n\<cdot>y)))"
+ "approx = (\<lambda>n. ssum_map\<cdot>(approx n)\<cdot>(approx n))"
lemma approx_sinl [simp]: "approx i\<cdot>(sinl\<cdot>x) = sinl\<cdot>(approx i\<cdot>x)"
unfolding approx_ssum_def by (cases "x = \<bottom>") simp_all
@@ -231,16 +297,14 @@
unfolding approx_ssum_def by simp
show "(\<Squnion>i. approx i\<cdot>x) = x"
unfolding approx_ssum_def
- by (simp add: lub_distribs eta_cfun)
+ by (cases x, simp_all add: lub_distribs)
show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
by (cases x, simp add: approx_ssum_def, simp, simp)
- have "{x::'a \<oplus> 'b. approx i\<cdot>x = x} \<subseteq>
- (\<lambda>x. sinl\<cdot>x) ` {x. approx i\<cdot>x = x} \<union>
- (\<lambda>x. sinr\<cdot>x) ` {x. approx i\<cdot>x = x}"
- by (rule subsetI, case_tac x rule: ssumE2, simp, simp)
- thus "finite {x::'a \<oplus> 'b. approx i\<cdot>x = x}"
- by (rule finite_subset,
- intro finite_UnI finite_imageI finite_fixes_approx)
+ show "finite {x::'a \<oplus> 'b. approx i\<cdot>x = x}"
+ unfolding approx_ssum_def
+ by (intro finite_deflation.finite_fixes
+ finite_deflation_ssum_map
+ finite_deflation_approx)
qed
end