major reorganization/simplification of HOLCF type classes:
authorhuffman
Wed Oct 06 10:49:27 2010 -0700 (2010-10-06)
changeset 39974b525988432e9
parent 39973 c62b4ff97bfc
child 39975 7c50d5ca5c04
child 39981 fdff0444fa7d
major reorganization/simplification of HOLCF type classes:
removed profinite/bifinite classes and approx function;
universal domain uses approx_chain locale instead of bifinite class;
ideal_completion locale does not use 'take' functions, requires countable basis instead;
replaced type 'udom alg_defl' with type 'sfp';
replaced class 'rep' with class 'sfp';
renamed REP('a) to SFP('a);
src/HOLCF/Algebraic.thy
src/HOLCF/Bifinite.thy
src/HOLCF/CompactBasis.thy
src/HOLCF/Completion.thy
src/HOLCF/ConvexPD.thy
src/HOLCF/Cprod.thy
src/HOLCF/Eventual.thy
src/HOLCF/HOLCF.thy
src/HOLCF/IsaMakefile
src/HOLCF/Library/Strict_Fun.thy
src/HOLCF/Library/Sum_Cpo.thy
src/HOLCF/Lift.thy
src/HOLCF/LowerPD.thy
src/HOLCF/Powerdomains.thy
src/HOLCF/Representable.thy
src/HOLCF/Sprod.thy
src/HOLCF/Ssum.thy
src/HOLCF/Tools/Domain/domain_extender.ML
src/HOLCF/Tools/Domain/domain_isomorphism.ML
src/HOLCF/Tools/repdef.ML
src/HOLCF/Tutorial/New_Domain.thy
src/HOLCF/Universal.thy
src/HOLCF/Up.thy
src/HOLCF/UpperPD.thy
src/HOLCF/ex/Domain_Proofs.thy
src/HOLCF/ex/Powerdomain_ex.thy
     1.1 --- a/src/HOLCF/Algebraic.thy	Tue Oct 05 17:53:00 2010 -0700
     1.2 +++ b/src/HOLCF/Algebraic.thy	Wed Oct 06 10:49:27 2010 -0700
     1.3 @@ -2,303 +2,18 @@
     1.4      Author:     Brian Huffman
     1.5  *)
     1.6  
     1.7 -header {* Algebraic deflations *}
     1.8 +header {* Algebraic deflations and SFP domains *}
     1.9  
    1.10  theory Algebraic
    1.11 -imports Completion Fix Eventual Bifinite
    1.12 -begin
    1.13 -
    1.14 -subsection {* Constructing finite deflations by iteration *}
    1.15 -
    1.16 -lemma le_Suc_induct:
    1.17 -  assumes le: "i \<le> j"
    1.18 -  assumes step: "\<And>i. P i (Suc i)"
    1.19 -  assumes refl: "\<And>i. P i i"
    1.20 -  assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
    1.21 -  shows "P i j"
    1.22 -proof (cases "i = j")
    1.23 -  assume "i = j"
    1.24 -  thus "P i j" by (simp add: refl)
    1.25 -next
    1.26 -  assume "i \<noteq> j"
    1.27 -  with le have "i < j" by simp
    1.28 -  thus "P i j" using step trans by (rule less_Suc_induct)
    1.29 -qed
    1.30 -
    1.31 -definition
    1.32 -  eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
    1.33 -where
    1.34 -  "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"
    1.35 -
    1.36 -text {* A pre-deflation is like a deflation, but not idempotent. *}
    1.37 -
    1.38 -locale pre_deflation =
    1.39 -  fixes f :: "'a \<rightarrow> 'a::cpo"
    1.40 -  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
    1.41 -  assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
    1.42 +imports Universal Bifinite
    1.43  begin
    1.44  
    1.45 -lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
    1.46 -by (induct i, simp_all add: below_trans [OF below])
    1.47 -
    1.48 -lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
    1.49 -by (induct i, simp_all)
    1.50 -
    1.51 -lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
    1.52 -apply (erule le_Suc_induct)
    1.53 -apply (simp add: below)
    1.54 -apply (rule below_refl)
    1.55 -apply (erule (1) below_trans)
    1.56 -done
    1.57 -
    1.58 -lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
    1.59 -proof (rule finite_subset)
    1.60 -  show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
    1.61 -    by (clarify, case_tac i, simp_all)
    1.62 -  show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
    1.63 -    by (simp add: finite_range)
    1.64 -qed
    1.65 -
    1.66 -lemma eventually_constant_iterate_app:
    1.67 -  "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
    1.68 -unfolding eventually_constant_def MOST_nat_le
    1.69 -proof -
    1.70 -  let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
    1.71 -  have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
    1.72 -    apply (rule finite_range_has_max)
    1.73 -    apply (erule antichain_iterate_app)
    1.74 -    apply (rule finite_range_iterate_app)
    1.75 -    done
    1.76 -  then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
    1.77 -  show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
    1.78 -  proof (intro exI allI impI)
    1.79 -    fix k
    1.80 -    assume "j \<le> k"
    1.81 -    hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
    1.82 -    also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
    1.83 -    finally show "?Y k = ?Y j" .
    1.84 -  qed
    1.85 -qed
    1.86 -
    1.87 -lemma eventually_constant_iterate:
    1.88 -  "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
    1.89 -proof -
    1.90 -  have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
    1.91 -    by (simp add: eventually_constant_iterate_app)
    1.92 -  hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    1.93 -    unfolding eventually_constant_MOST_MOST .
    1.94 -  hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    1.95 -    by (simp only: MOST_finite_Ball_distrib [OF finite_range])
    1.96 -  hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
    1.97 -    by simp
    1.98 -  hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
    1.99 -    by (simp only: iterate_Suc2)
   1.100 -  hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
   1.101 -    by (simp only: expand_cfun_eq)
   1.102 -  hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
   1.103 -    unfolding eventually_constant_MOST_MOST .
   1.104 -  thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
   1.105 -    by (rule eventually_constant_SucD)
   1.106 -qed
   1.107 -
   1.108 -abbreviation
   1.109 -  d :: "'a \<rightarrow> 'a"
   1.110 -where
   1.111 -  "d \<equiv> eventual_iterate f"
   1.112 -
   1.113 -lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
   1.114 -unfolding eventual_iterate_def
   1.115 -using eventually_constant_iterate by (rule MOST_eventual)
   1.116 -
   1.117 -lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
   1.118 -apply (rule MOST_d)
   1.119 -apply (subst iterate_Suc [symmetric])
   1.120 -apply (rule eventually_constant_MOST_Suc_eq)
   1.121 -apply (rule eventually_constant_iterate_app)
   1.122 -done
   1.123 -
   1.124 -lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
   1.125 -proof
   1.126 -  assume "d\<cdot>x = x"
   1.127 -  with f_d [where x=x]
   1.128 -  show "f\<cdot>x = x" by simp
   1.129 -next
   1.130 -  assume f: "f\<cdot>x = x"
   1.131 -  have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
   1.132 -    by (rule allI, rule nat.induct, simp, simp add: f)
   1.133 -  hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
   1.134 -    by (rule ALL_MOST)
   1.135 -  thus "d\<cdot>x = x"
   1.136 -    by (rule MOST_d)
   1.137 -qed
   1.138 -
   1.139 -lemma finite_deflation_d: "finite_deflation d"
   1.140 -proof
   1.141 -  fix x :: 'a
   1.142 -  have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
   1.143 -    unfolding eventual_iterate_def
   1.144 -    using eventually_constant_iterate
   1.145 -    by (rule eventual_mem_range)
   1.146 -  then obtain n where n: "d = iterate n\<cdot>f" ..
   1.147 -  have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
   1.148 -    using f_d by (rule iterate_fixed)
   1.149 -  thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
   1.150 -    by (simp add: n)
   1.151 -next
   1.152 -  fix x :: 'a
   1.153 -  show "d\<cdot>x \<sqsubseteq> x"
   1.154 -    by (rule MOST_d, simp add: iterate_below)
   1.155 -next
   1.156 -  from finite_range
   1.157 -  have "finite {x. f\<cdot>x = x}"
   1.158 -    by (rule finite_range_imp_finite_fixes)
   1.159 -  thus "finite {x. d\<cdot>x = x}"
   1.160 -    by (simp add: d_fixed_iff)
   1.161 -qed
   1.162 -
   1.163 -lemma deflation_d: "deflation d"
   1.164 -using finite_deflation_d
   1.165 -by (rule finite_deflation_imp_deflation)
   1.166 -
   1.167 -end
   1.168 -
   1.169 -lemma finite_deflation_eventual_iterate:
   1.170 -  "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
   1.171 -by (rule pre_deflation.finite_deflation_d)
   1.172 -
   1.173 -lemma pre_deflation_oo:
   1.174 -  assumes "finite_deflation d"
   1.175 -  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
   1.176 -  shows "pre_deflation (d oo f)"
   1.177 -proof
   1.178 -  interpret d: finite_deflation d by fact
   1.179 -  fix x
   1.180 -  show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
   1.181 -    by (simp, rule below_trans [OF d.below f])
   1.182 -  show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
   1.183 -    by (rule finite_subset [OF _ d.finite_range], auto)
   1.184 -qed
   1.185 -
   1.186 -lemma eventual_iterate_oo_fixed_iff:
   1.187 -  assumes "finite_deflation d"
   1.188 -  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
   1.189 -  shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
   1.190 -proof -
   1.191 -  interpret d: finite_deflation d by fact
   1.192 -  let ?e = "d oo f"
   1.193 -  interpret e: pre_deflation "d oo f"
   1.194 -    using `finite_deflation d` f
   1.195 -    by (rule pre_deflation_oo)
   1.196 -  let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
   1.197 -  show ?thesis
   1.198 -    apply (subst e.d_fixed_iff)
   1.199 -    apply simp
   1.200 -    apply safe
   1.201 -    apply (erule subst)
   1.202 -    apply (rule d.idem)
   1.203 -    apply (rule below_antisym)
   1.204 -    apply (rule f)
   1.205 -    apply (erule subst, rule d.below)
   1.206 -    apply simp
   1.207 -    done
   1.208 -qed
   1.209 -
   1.210 -lemma eventual_mono:
   1.211 -  assumes A: "eventually_constant A"
   1.212 -  assumes B: "eventually_constant B"
   1.213 -  assumes below: "\<And>n. A n \<sqsubseteq> B n"
   1.214 -  shows "eventual A \<sqsubseteq> eventual B"
   1.215 -proof -
   1.216 -  from A have "MOST n. A n = eventual A"
   1.217 -    by (rule MOST_eq_eventual)
   1.218 -  then have "MOST n. eventual A \<sqsubseteq> B n"
   1.219 -    by (rule MOST_mono) (erule subst, rule below)
   1.220 -  with B show "eventual A \<sqsubseteq> eventual B"
   1.221 -    by (rule MOST_eventual)
   1.222 -qed
   1.223 -
   1.224 -lemma eventual_iterate_mono:
   1.225 -  assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
   1.226 -  shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
   1.227 -unfolding eventual_iterate_def
   1.228 -apply (rule eventual_mono)
   1.229 -apply (rule pre_deflation.eventually_constant_iterate [OF f])
   1.230 -apply (rule pre_deflation.eventually_constant_iterate [OF g])
   1.231 -apply (rule monofun_cfun_arg [OF `f \<sqsubseteq> g`])
   1.232 -done
   1.233 -
   1.234 -lemma cont2cont_eventual_iterate_oo:
   1.235 -  assumes d: "finite_deflation d"
   1.236 -  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
   1.237 -  shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
   1.238 -    (is "cont ?e")
   1.239 -proof (rule contI2)
   1.240 -  show "monofun ?e"
   1.241 -    apply (rule monofunI)
   1.242 -    apply (rule eventual_iterate_mono)
   1.243 -    apply (rule pre_deflation_oo [OF d below])
   1.244 -    apply (rule pre_deflation_oo [OF d below])
   1.245 -    apply (rule monofun_cfun_arg)
   1.246 -    apply (erule cont2monofunE [OF cont])
   1.247 -    done
   1.248 -next
   1.249 -  fix Y :: "nat \<Rightarrow> 'b"
   1.250 -  assume Y: "chain Y"
   1.251 -  with cont have fY: "chain (\<lambda>i. f (Y i))"
   1.252 -    by (rule ch2ch_cont)
   1.253 -  assume eY: "chain (\<lambda>i. ?e (Y i))"
   1.254 -  have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
   1.255 -    by (rule admD [OF _ Y], simp add: cont, rule below)
   1.256 -  have "deflation (?e (\<Squnion>i. Y i))"
   1.257 -    apply (rule pre_deflation.deflation_d)
   1.258 -    apply (rule pre_deflation_oo [OF d lub_below])
   1.259 -    done
   1.260 -  then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
   1.261 -  proof (rule deflation.belowI)
   1.262 -    fix x :: 'a
   1.263 -    assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
   1.264 -    hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
   1.265 -      by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
   1.266 -    hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
   1.267 -      apply (simp only: cont2contlubE [OF cont Y])
   1.268 -      apply (simp only: contlub_cfun_fun [OF fY])
   1.269 -      done
   1.270 -    have "compact (d\<cdot>x)"
   1.271 -      using d by (rule finite_deflation.compact)
   1.272 -    then have "compact x"
   1.273 -      using `d\<cdot>x = x` by simp
   1.274 -    then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
   1.275 -      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` by simp
   1.276 -    then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
   1.277 -      by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
   1.278 -    then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
   1.279 -    then have "f (Y n)\<cdot>x = x"
   1.280 -      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` fY by (simp add: maxinch_is_thelub)
   1.281 -    with `d\<cdot>x = x` have "?e (Y n)\<cdot>x = x"
   1.282 -      by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
   1.283 -    moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
   1.284 -      by (rule is_ub_thelub, simp add: eY)
   1.285 -    ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
   1.286 -      by (simp add: contlub_cfun_fun eY)
   1.287 -    also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
   1.288 -      apply (rule deflation.below)
   1.289 -      apply (rule admD [OF adm_deflation eY])
   1.290 -      apply (rule pre_deflation.deflation_d)
   1.291 -      apply (rule pre_deflation_oo [OF d below])
   1.292 -      done
   1.293 -    finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
   1.294 -  qed
   1.295 -qed
   1.296 -
   1.297 -
   1.298  subsection {* Type constructor for finite deflations *}
   1.299  
   1.300 -default_sort profinite
   1.301 +typedef (open) fin_defl = "{d::udom \<rightarrow> udom. finite_deflation d}"
   1.302 +by (fast intro: finite_deflation_UU)
   1.303  
   1.304 -typedef (open) 'a fin_defl = "{d::'a \<rightarrow> 'a. finite_deflation d}"
   1.305 -by (fast intro: finite_deflation_approx)
   1.306 -
   1.307 -instantiation fin_defl :: (profinite) below
   1.308 +instantiation fin_defl :: below
   1.309  begin
   1.310  
   1.311  definition below_fin_defl_def:
   1.312 @@ -307,8 +22,9 @@
   1.313  instance ..
   1.314  end
   1.315  
   1.316 -instance fin_defl :: (profinite) po
   1.317 -by (rule typedef_po [OF type_definition_fin_defl below_fin_defl_def])
   1.318 +instance fin_defl :: po
   1.319 +using type_definition_fin_defl below_fin_defl_def
   1.320 +by (rule typedef_po)
   1.321  
   1.322  lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
   1.323  using Rep_fin_defl by simp
   1.324 @@ -337,269 +53,146 @@
   1.325  apply (rule fin_defl_belowI, simp)
   1.326  done
   1.327  
   1.328 +lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
   1.329 +unfolding below_fin_defl_def .
   1.330 +
   1.331  lemma Abs_fin_defl_mono:
   1.332    "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
   1.333      \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
   1.334  unfolding below_fin_defl_def
   1.335  by (simp add: Abs_fin_defl_inverse)
   1.336  
   1.337 -
   1.338 -subsection {* Take function for finite deflations *}
   1.339 -
   1.340 -definition
   1.341 -  defl_approx :: "nat \<Rightarrow> ('a \<rightarrow> 'a) \<Rightarrow> ('a \<rightarrow> 'a)"
   1.342 -where
   1.343 -  "defl_approx i d = eventual_iterate (approx i oo d)"
   1.344 -
   1.345 -lemma finite_deflation_defl_approx:
   1.346 -  "deflation d \<Longrightarrow> finite_deflation (defl_approx i d)"
   1.347 -unfolding defl_approx_def
   1.348 -apply (rule pre_deflation.finite_deflation_d)
   1.349 -apply (rule pre_deflation_oo)
   1.350 -apply (rule finite_deflation_approx)
   1.351 -apply (erule deflation.below)
   1.352 -done
   1.353 -
   1.354 -lemma deflation_defl_approx:
   1.355 -  "deflation d \<Longrightarrow> deflation (defl_approx i d)"
   1.356 -apply (rule finite_deflation_imp_deflation)
   1.357 -apply (erule finite_deflation_defl_approx)
   1.358 -done
   1.359 -
   1.360 -lemma defl_approx_fixed_iff:
   1.361 -  "deflation d \<Longrightarrow> defl_approx i d\<cdot>x = x \<longleftrightarrow> approx i\<cdot>x = x \<and> d\<cdot>x = x"
   1.362 -unfolding defl_approx_def
   1.363 -apply (rule eventual_iterate_oo_fixed_iff)
   1.364 -apply (rule finite_deflation_approx)
   1.365 -apply (erule deflation.below)
   1.366 -done
   1.367 -
   1.368 -lemma defl_approx_below:
   1.369 -  "\<lbrakk>a \<sqsubseteq> b; deflation a; deflation b\<rbrakk> \<Longrightarrow> defl_approx i a \<sqsubseteq> defl_approx i b"
   1.370 -apply (rule deflation.belowI)
   1.371 -apply (erule deflation_defl_approx)
   1.372 -apply (simp add: defl_approx_fixed_iff)
   1.373 -apply (erule (1) deflation.belowD)
   1.374 -apply (erule conjunct2)
   1.375 -done
   1.376 -
   1.377 -lemma cont2cont_defl_approx:
   1.378 -  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
   1.379 -  shows "cont (\<lambda>x. defl_approx i (f x))"
   1.380 -unfolding defl_approx_def
   1.381 -using finite_deflation_approx assms
   1.382 -by (rule cont2cont_eventual_iterate_oo)
   1.383 -
   1.384 -definition
   1.385 -  fd_take :: "nat \<Rightarrow> 'a fin_defl \<Rightarrow> 'a fin_defl"
   1.386 -where
   1.387 -  "fd_take i d = Abs_fin_defl (defl_approx i (Rep_fin_defl d))"
   1.388 -
   1.389 -lemma Rep_fin_defl_fd_take:
   1.390 -  "Rep_fin_defl (fd_take i d) = defl_approx i (Rep_fin_defl d)"
   1.391 -unfolding fd_take_def
   1.392 -apply (rule Abs_fin_defl_inverse [unfolded mem_Collect_eq])
   1.393 -apply (rule finite_deflation_defl_approx)
   1.394 -apply (rule deflation_Rep_fin_defl)
   1.395 -done
   1.396 +lemma (in finite_deflation) compact_belowI:
   1.397 +  assumes "\<And>x. compact x \<Longrightarrow> d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
   1.398 +by (rule belowI, rule assms, erule subst, rule compact)
   1.399  
   1.400 -lemma fd_take_fixed_iff:
   1.401 -  "Rep_fin_defl (fd_take i d)\<cdot>x = x \<longleftrightarrow>
   1.402 -    approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
   1.403 -unfolding Rep_fin_defl_fd_take
   1.404 -apply (rule defl_approx_fixed_iff)
   1.405 -apply (rule deflation_Rep_fin_defl)
   1.406 -done
   1.407 -
   1.408 -lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
   1.409 -apply (rule fin_defl_belowI)
   1.410 -apply (simp add: fd_take_fixed_iff)
   1.411 -done
   1.412 -
   1.413 -lemma fd_take_idem: "fd_take n (fd_take n d) = fd_take n d"
   1.414 -apply (rule fin_defl_eqI)
   1.415 -apply (simp add: fd_take_fixed_iff)
   1.416 -done
   1.417 -
   1.418 -lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
   1.419 -apply (rule fin_defl_belowI)
   1.420 -apply (simp add: fd_take_fixed_iff)
   1.421 -apply (simp add: fin_defl_belowD)
   1.422 -done
   1.423 -
   1.424 -lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> approx j\<cdot>x = x"
   1.425 -by (erule subst, simp add: min_def)
   1.426 -
   1.427 -lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
   1.428 -apply (rule fin_defl_belowI)
   1.429 -apply (simp add: fd_take_fixed_iff)
   1.430 -apply (simp add: approx_fixed_le_lemma)
   1.431 -done
   1.432 -
   1.433 -lemma finite_range_fd_take: "finite (range (fd_take n))"
   1.434 -apply (rule finite_imageD [where f="\<lambda>a. {x. Rep_fin_defl a\<cdot>x = x}"])
   1.435 -apply (rule finite_subset [where B="Pow {x. approx n\<cdot>x = x}"])
   1.436 -apply (clarify, simp add: fd_take_fixed_iff)
   1.437 -apply (simp add: finite_fixes_approx)
   1.438 -apply (rule inj_onI, clarify)
   1.439 -apply (simp add: set_eq_iff fin_defl_eqI)
   1.440 -done
   1.441 -
   1.442 -lemma fd_take_covers: "\<exists>n. fd_take n a = a"
   1.443 -apply (rule_tac x=
   1.444 -  "Max ((\<lambda>x. LEAST n. approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
   1.445 -apply (rule below_antisym)
   1.446 -apply (rule fd_take_below)
   1.447 -apply (rule fin_defl_belowI)
   1.448 -apply (simp add: fd_take_fixed_iff)
   1.449 -apply (rule approx_fixed_le_lemma)
   1.450 -apply (rule Max_ge)
   1.451 -apply (rule finite_imageI)
   1.452 -apply (rule Rep_fin_defl.finite_fixes)
   1.453 -apply (rule imageI)
   1.454 -apply (erule CollectI)
   1.455 -apply (rule LeastI_ex)
   1.456 -apply (rule profinite_compact_eq_approx)
   1.457 -apply (erule subst)
   1.458 -apply (rule Rep_fin_defl.compact)
   1.459 -done
   1.460 -
   1.461 -interpretation fin_defl: basis_take below fd_take
   1.462 -apply default
   1.463 -apply (rule fd_take_below)
   1.464 -apply (rule fd_take_idem)
   1.465 -apply (erule fd_take_mono)
   1.466 -apply (rule fd_take_chain, simp)
   1.467 -apply (rule finite_range_fd_take)
   1.468 -apply (rule fd_take_covers)
   1.469 -done
   1.470 -
   1.471 +lemma compact_Rep_fin_defl [simp]: "compact (Rep_fin_defl a)"
   1.472 +using finite_deflation_Rep_fin_defl
   1.473 +by (rule finite_deflation_imp_compact)
   1.474  
   1.475  subsection {* Defining algebraic deflations by ideal completion *}
   1.476  
   1.477 -typedef (open) 'a alg_defl =
   1.478 -  "{S::'a fin_defl set. below.ideal S}"
   1.479 +text {*
   1.480 +  An SFP domain is one that can be represented as the limit of a
   1.481 +  sequence of finite posets.  Here we use omega-algebraic deflations
   1.482 +  (i.e. countable ideals of finite deflations) to model sequences of
   1.483 +  finite posets.
   1.484 +*}
   1.485 +
   1.486 +typedef (open) sfp = "{S::fin_defl set. below.ideal S}"
   1.487  by (fast intro: below.ideal_principal)
   1.488  
   1.489 -instantiation alg_defl :: (profinite) below
   1.490 +instantiation sfp :: below
   1.491  begin
   1.492  
   1.493  definition
   1.494 -  "x \<sqsubseteq> y \<longleftrightarrow> Rep_alg_defl x \<subseteq> Rep_alg_defl y"
   1.495 +  "x \<sqsubseteq> y \<longleftrightarrow> Rep_sfp x \<subseteq> Rep_sfp y"
   1.496  
   1.497  instance ..
   1.498  end
   1.499  
   1.500 -instance alg_defl :: (profinite) po
   1.501 -by (rule below.typedef_ideal_po
   1.502 -    [OF type_definition_alg_defl below_alg_defl_def])
   1.503 +instance sfp :: po
   1.504 +using type_definition_sfp below_sfp_def
   1.505 +by (rule below.typedef_ideal_po)
   1.506  
   1.507 -instance alg_defl :: (profinite) cpo
   1.508 -by (rule below.typedef_ideal_cpo
   1.509 -    [OF type_definition_alg_defl below_alg_defl_def])
   1.510 +instance sfp :: cpo
   1.511 +using type_definition_sfp below_sfp_def
   1.512 +by (rule below.typedef_ideal_cpo)
   1.513  
   1.514 -lemma Rep_alg_defl_lub:
   1.515 -  "chain Y \<Longrightarrow> Rep_alg_defl (\<Squnion>i. Y i) = (\<Union>i. Rep_alg_defl (Y i))"
   1.516 -by (rule below.typedef_ideal_rep_contlub
   1.517 -    [OF type_definition_alg_defl below_alg_defl_def])
   1.518 +lemma Rep_sfp_lub:
   1.519 +  "chain Y \<Longrightarrow> Rep_sfp (\<Squnion>i. Y i) = (\<Union>i. Rep_sfp (Y i))"
   1.520 +using type_definition_sfp below_sfp_def
   1.521 +by (rule below.typedef_ideal_rep_contlub)
   1.522  
   1.523 -lemma ideal_Rep_alg_defl: "below.ideal (Rep_alg_defl xs)"
   1.524 -by (rule Rep_alg_defl [unfolded mem_Collect_eq])
   1.525 +lemma ideal_Rep_sfp: "below.ideal (Rep_sfp xs)"
   1.526 +by (rule Rep_sfp [unfolded mem_Collect_eq])
   1.527  
   1.528  definition
   1.529 -  alg_defl_principal :: "'a fin_defl \<Rightarrow> 'a alg_defl" where
   1.530 -  "alg_defl_principal t = Abs_alg_defl {u. u \<sqsubseteq> t}"
   1.531 +  sfp_principal :: "fin_defl \<Rightarrow> sfp" where
   1.532 +  "sfp_principal t = Abs_sfp {u. u \<sqsubseteq> t}"
   1.533  
   1.534 -lemma Rep_alg_defl_principal:
   1.535 -  "Rep_alg_defl (alg_defl_principal t) = {u. u \<sqsubseteq> t}"
   1.536 -unfolding alg_defl_principal_def
   1.537 -by (simp add: Abs_alg_defl_inverse below.ideal_principal)
   1.538 +lemma Rep_sfp_principal:
   1.539 +  "Rep_sfp (sfp_principal t) = {u. u \<sqsubseteq> t}"
   1.540 +unfolding sfp_principal_def
   1.541 +by (simp add: Abs_sfp_inverse below.ideal_principal)
   1.542  
   1.543 -interpretation alg_defl:
   1.544 -  ideal_completion below fd_take alg_defl_principal Rep_alg_defl
   1.545 +lemma fin_defl_countable: "\<exists>f::fin_defl \<Rightarrow> nat. inj f"
   1.546 +proof
   1.547 +  have *: "\<And>d. finite (approx_chain.place udom_approx `
   1.548 +               Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x})"
   1.549 +    apply (rule finite_imageI)
   1.550 +    apply (rule finite_vimageI)
   1.551 +    apply (rule Rep_fin_defl.finite_fixes)
   1.552 +    apply (simp add: inj_on_def Rep_compact_basis_inject)
   1.553 +    done
   1.554 +  have range_eq: "range Rep_compact_basis = {x. compact x}"
   1.555 +    using type_definition_compact_basis by (rule type_definition.Rep_range)
   1.556 +  show "inj (\<lambda>d. set_encode
   1.557 +    (approx_chain.place udom_approx ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x}))"
   1.558 +    apply (rule inj_onI)
   1.559 +    apply (simp only: set_encode_eq *)
   1.560 +    apply (simp only: inj_image_eq_iff approx_chain.inj_place [OF udom_approx])
   1.561 +    apply (drule_tac f="image Rep_compact_basis" in arg_cong)
   1.562 +    apply (simp del: vimage_Collect_eq add: range_eq set_eq_iff)
   1.563 +    apply (rule Rep_fin_defl_inject [THEN iffD1])
   1.564 +    apply (rule below_antisym)
   1.565 +    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
   1.566 +    apply (drule_tac x=z in spec, simp)
   1.567 +    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
   1.568 +    apply (drule_tac x=z in spec, simp)
   1.569 +    done
   1.570 +qed
   1.571 +
   1.572 +interpretation sfp: ideal_completion below sfp_principal Rep_sfp
   1.573  apply default
   1.574 -apply (rule ideal_Rep_alg_defl)
   1.575 -apply (erule Rep_alg_defl_lub)
   1.576 -apply (rule Rep_alg_defl_principal)
   1.577 -apply (simp only: below_alg_defl_def)
   1.578 +apply (rule ideal_Rep_sfp)
   1.579 +apply (erule Rep_sfp_lub)
   1.580 +apply (rule Rep_sfp_principal)
   1.581 +apply (simp only: below_sfp_def)
   1.582 +apply (rule fin_defl_countable)
   1.583  done
   1.584  
   1.585  text {* Algebraic deflations are pointed *}
   1.586  
   1.587 -lemma alg_defl_minimal:
   1.588 -  "alg_defl_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
   1.589 -apply (induct x rule: alg_defl.principal_induct, simp)
   1.590 -apply (rule alg_defl.principal_mono)
   1.591 -apply (induct_tac a)
   1.592 -apply (rule Abs_fin_defl_mono)
   1.593 -apply (rule finite_deflation_UU)
   1.594 -apply simp
   1.595 -apply (rule minimal)
   1.596 +lemma sfp_minimal: "sfp_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
   1.597 +apply (induct x rule: sfp.principal_induct, simp)
   1.598 +apply (rule sfp.principal_mono)
   1.599 +apply (simp add: below_fin_defl_def)
   1.600 +apply (simp add: Abs_fin_defl_inverse finite_deflation_UU)
   1.601  done
   1.602  
   1.603 -instance alg_defl :: (bifinite) pcpo
   1.604 -by intro_classes (fast intro: alg_defl_minimal)
   1.605 -
   1.606 -lemma inst_alg_defl_pcpo: "\<bottom> = alg_defl_principal (Abs_fin_defl \<bottom>)"
   1.607 -by (rule alg_defl_minimal [THEN UU_I, symmetric])
   1.608 -
   1.609 -text {* Algebraic deflations are profinite *}
   1.610 -
   1.611 -instantiation alg_defl :: (profinite) profinite
   1.612 -begin
   1.613 -
   1.614 -definition
   1.615 -  approx_alg_defl_def: "approx = alg_defl.completion_approx"
   1.616 +instance sfp :: pcpo
   1.617 +by intro_classes (fast intro: sfp_minimal)
   1.618  
   1.619 -instance
   1.620 -apply (intro_classes, unfold approx_alg_defl_def)
   1.621 -apply (rule alg_defl.chain_completion_approx)
   1.622 -apply (rule alg_defl.lub_completion_approx)
   1.623 -apply (rule alg_defl.completion_approx_idem)
   1.624 -apply (rule alg_defl.finite_fixes_completion_approx)
   1.625 -done
   1.626 -
   1.627 -end
   1.628 -
   1.629 -instance alg_defl :: (bifinite) bifinite ..
   1.630 -
   1.631 -lemma approx_alg_defl_principal [simp]:
   1.632 -  "approx n\<cdot>(alg_defl_principal t) = alg_defl_principal (fd_take n t)"
   1.633 -unfolding approx_alg_defl_def
   1.634 -by (rule alg_defl.completion_approx_principal)
   1.635 -
   1.636 -lemma approx_eq_alg_defl_principal:
   1.637 -  "\<exists>t\<in>Rep_alg_defl xs. approx n\<cdot>xs = alg_defl_principal (fd_take n t)"
   1.638 -unfolding approx_alg_defl_def
   1.639 -by (rule alg_defl.completion_approx_eq_principal)
   1.640 -
   1.641 +lemma inst_sfp_pcpo: "\<bottom> = sfp_principal (Abs_fin_defl \<bottom>)"
   1.642 +by (rule sfp_minimal [THEN UU_I, symmetric])
   1.643  
   1.644  subsection {* Applying algebraic deflations *}
   1.645  
   1.646  definition
   1.647 -  cast :: "'a alg_defl \<rightarrow> 'a \<rightarrow> 'a"
   1.648 +  cast :: "sfp \<rightarrow> udom \<rightarrow> udom"
   1.649  where
   1.650 -  "cast = alg_defl.basis_fun Rep_fin_defl"
   1.651 +  "cast = sfp.basis_fun Rep_fin_defl"
   1.652  
   1.653 -lemma cast_alg_defl_principal:
   1.654 -  "cast\<cdot>(alg_defl_principal a) = Rep_fin_defl a"
   1.655 +lemma cast_sfp_principal:
   1.656 +  "cast\<cdot>(sfp_principal a) = Rep_fin_defl a"
   1.657  unfolding cast_def
   1.658 -apply (rule alg_defl.basis_fun_principal)
   1.659 +apply (rule sfp.basis_fun_principal)
   1.660  apply (simp only: below_fin_defl_def)
   1.661  done
   1.662  
   1.663  lemma deflation_cast: "deflation (cast\<cdot>d)"
   1.664 -apply (induct d rule: alg_defl.principal_induct)
   1.665 +apply (induct d rule: sfp.principal_induct)
   1.666  apply (rule adm_subst [OF _ adm_deflation], simp)
   1.667 -apply (simp add: cast_alg_defl_principal)
   1.668 +apply (simp add: cast_sfp_principal)
   1.669  apply (rule finite_deflation_imp_deflation)
   1.670  apply (rule finite_deflation_Rep_fin_defl)
   1.671  done
   1.672  
   1.673  lemma finite_deflation_cast:
   1.674    "compact d \<Longrightarrow> finite_deflation (cast\<cdot>d)"
   1.675 -apply (drule alg_defl.compact_imp_principal, clarify)
   1.676 -apply (simp add: cast_alg_defl_principal)
   1.677 +apply (drule sfp.compact_imp_principal, clarify)
   1.678 +apply (simp add: cast_sfp_principal)
   1.679  apply (rule finite_deflation_Rep_fin_defl)
   1.680  done
   1.681  
   1.682 @@ -608,43 +201,33 @@
   1.683  
   1.684  declare cast.idem [simp]
   1.685  
   1.686 -lemma cast_approx: "cast\<cdot>(approx n\<cdot>A) = defl_approx n (cast\<cdot>A)"
   1.687 -apply (rule alg_defl.principal_induct)
   1.688 -apply (rule adm_eq)
   1.689 -apply simp
   1.690 -apply (simp add: cont2cont_defl_approx cast.below)
   1.691 -apply (simp only: approx_alg_defl_principal)
   1.692 -apply (simp only: cast_alg_defl_principal)
   1.693 -apply (simp only: Rep_fin_defl_fd_take)
   1.694 +lemma compact_cast [simp]: "compact d \<Longrightarrow> compact (cast\<cdot>d)"
   1.695 +apply (rule finite_deflation_imp_compact)
   1.696 +apply (erule finite_deflation_cast)
   1.697  done
   1.698  
   1.699 -lemma cast_approx_fixed_iff:
   1.700 -  "cast\<cdot>(approx i\<cdot>A)\<cdot>x = x \<longleftrightarrow> approx i\<cdot>x = x \<and> cast\<cdot>A\<cdot>x = x"
   1.701 -apply (simp only: cast_approx)
   1.702 -apply (rule defl_approx_fixed_iff)
   1.703 -apply (rule deflation_cast)
   1.704 +lemma cast_below_cast: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
   1.705 +apply (induct A rule: sfp.principal_induct, simp)
   1.706 +apply (induct B rule: sfp.principal_induct, simp)
   1.707 +apply (simp add: cast_sfp_principal below_fin_defl_def)
   1.708  done
   1.709  
   1.710 -lemma defl_approx_cast: "defl_approx i (cast\<cdot>A) = cast\<cdot>(approx i\<cdot>A)"
   1.711 -by (rule cast_approx [symmetric])
   1.712 -
   1.713 -lemma cast_below_cast_iff: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
   1.714 -apply (induct A rule: alg_defl.principal_induct, simp)
   1.715 -apply (induct B rule: alg_defl.principal_induct)
   1.716 -apply (simp add: cast_alg_defl_principal)
   1.717 -apply (simp add: finite_deflation_imp_compact finite_deflation_Rep_fin_defl)
   1.718 -apply (simp add: cast_alg_defl_principal below_fin_defl_def)
   1.719 +lemma compact_cast_iff: "compact (cast\<cdot>d) \<longleftrightarrow> compact d"
   1.720 +apply (rule iffI)
   1.721 +apply (simp only: compact_def cast_below_cast [symmetric])
   1.722 +apply (erule adm_subst [OF cont_Rep_CFun2])
   1.723 +apply (erule compact_cast)
   1.724  done
   1.725  
   1.726  lemma cast_below_imp_below: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<Longrightarrow> A \<sqsubseteq> B"
   1.727 -by (simp only: cast_below_cast_iff)
   1.728 +by (simp only: cast_below_cast)
   1.729  
   1.730  lemma cast_eq_imp_eq: "cast\<cdot>A = cast\<cdot>B \<Longrightarrow> A = B"
   1.731  by (simp add: below_antisym cast_below_imp_below)
   1.732  
   1.733  lemma cast_strict1 [simp]: "cast\<cdot>\<bottom> = \<bottom>"
   1.734 -apply (subst inst_alg_defl_pcpo)
   1.735 -apply (subst cast_alg_defl_principal)
   1.736 +apply (subst inst_sfp_pcpo)
   1.737 +apply (subst cast_sfp_principal)
   1.738  apply (rule Abs_fin_defl_inverse)
   1.739  apply (simp add: finite_deflation_UU)
   1.740  done
   1.741 @@ -652,119 +235,271 @@
   1.742  lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
   1.743  by (rule cast.below [THEN UU_I])
   1.744  
   1.745 -
   1.746  subsection {* Deflation membership relation *}
   1.747  
   1.748  definition
   1.749 -  in_deflation :: "'a::profinite \<Rightarrow> 'a alg_defl \<Rightarrow> bool" (infixl ":::" 50)
   1.750 +  in_sfp :: "udom \<Rightarrow> sfp \<Rightarrow> bool" (infixl ":::" 50)
   1.751  where
   1.752    "x ::: A \<longleftrightarrow> cast\<cdot>A\<cdot>x = x"
   1.753  
   1.754 -lemma adm_in_deflation: "adm (\<lambda>x. x ::: A)"
   1.755 -unfolding in_deflation_def by simp
   1.756 +lemma adm_in_sfp: "adm (\<lambda>x. x ::: A)"
   1.757 +unfolding in_sfp_def by simp
   1.758  
   1.759 -lemma in_deflationI: "cast\<cdot>A\<cdot>x = x \<Longrightarrow> x ::: A"
   1.760 -unfolding in_deflation_def .
   1.761 +lemma in_sfpI: "cast\<cdot>A\<cdot>x = x \<Longrightarrow> x ::: A"
   1.762 +unfolding in_sfp_def .
   1.763  
   1.764  lemma cast_fixed: "x ::: A \<Longrightarrow> cast\<cdot>A\<cdot>x = x"
   1.765 -unfolding in_deflation_def .
   1.766 +unfolding in_sfp_def .
   1.767  
   1.768 -lemma cast_in_deflation [simp]: "cast\<cdot>A\<cdot>x ::: A"
   1.769 -unfolding in_deflation_def by (rule cast.idem)
   1.770 +lemma cast_in_sfp [simp]: "cast\<cdot>A\<cdot>x ::: A"
   1.771 +unfolding in_sfp_def by (rule cast.idem)
   1.772  
   1.773 -lemma bottom_in_deflation [simp]: "\<bottom> ::: A"
   1.774 -unfolding in_deflation_def by (rule cast_strict2)
   1.775 +lemma bottom_in_sfp [simp]: "\<bottom> ::: A"
   1.776 +unfolding in_sfp_def by (rule cast_strict2)
   1.777  
   1.778 -lemma subdeflationD: "A \<sqsubseteq> B \<Longrightarrow> x ::: A \<Longrightarrow> x ::: B"
   1.779 -unfolding in_deflation_def
   1.780 +lemma sfp_belowD: "A \<sqsubseteq> B \<Longrightarrow> x ::: A \<Longrightarrow> x ::: B"
   1.781 +unfolding in_sfp_def
   1.782   apply (rule deflation.belowD)
   1.783     apply (rule deflation_cast)
   1.784    apply (erule monofun_cfun_arg)
   1.785   apply assumption
   1.786  done
   1.787  
   1.788 -lemma rev_subdeflationD: "x ::: A \<Longrightarrow> A \<sqsubseteq> B \<Longrightarrow> x ::: B"
   1.789 -by (rule subdeflationD)
   1.790 +lemma rev_sfp_belowD: "x ::: A \<Longrightarrow> A \<sqsubseteq> B \<Longrightarrow> x ::: B"
   1.791 +by (rule sfp_belowD)
   1.792  
   1.793 -lemma subdeflationI: "(\<And>x. x ::: A \<Longrightarrow> x ::: B) \<Longrightarrow> A \<sqsubseteq> B"
   1.794 +lemma sfp_belowI: "(\<And>x. x ::: A \<Longrightarrow> x ::: B) \<Longrightarrow> A \<sqsubseteq> B"
   1.795  apply (rule cast_below_imp_below)
   1.796  apply (rule cast.belowI)
   1.797 -apply (simp add: in_deflation_def)
   1.798 -done
   1.799 -
   1.800 -text "Identity deflation:"
   1.801 -
   1.802 -lemma "cast\<cdot>(\<Squnion>i. alg_defl_principal (Abs_fin_defl (approx i)))\<cdot>x = x"
   1.803 -apply (subst contlub_cfun_arg)
   1.804 -apply (rule chainI)
   1.805 -apply (rule alg_defl.principal_mono)
   1.806 -apply (rule Abs_fin_defl_mono)
   1.807 -apply (rule finite_deflation_approx)
   1.808 -apply (rule finite_deflation_approx)
   1.809 -apply (rule chainE)
   1.810 -apply (rule chain_approx)
   1.811 -apply (simp add: cast_alg_defl_principal
   1.812 -  Abs_fin_defl_inverse finite_deflation_approx)
   1.813 +apply (simp add: in_sfp_def)
   1.814  done
   1.815  
   1.816 -subsection {* Bifinite domains and algebraic deflations *}
   1.817 +subsection {* Class of SFP domains *}
   1.818 +
   1.819 +text {*
   1.820 +  We define a SFP domain as a pcpo that is isomorphic to some
   1.821 +  algebraic deflation over the universal domain.
   1.822 +*}
   1.823 +
   1.824 +class sfp = pcpo +
   1.825 +  fixes emb :: "'a::pcpo \<rightarrow> udom"
   1.826 +  fixes prj :: "udom \<rightarrow> 'a::pcpo"
   1.827 +  fixes sfp :: "'a itself \<Rightarrow> sfp"
   1.828 +  assumes ep_pair_emb_prj: "ep_pair emb prj"
   1.829 +  assumes cast_SFP: "cast\<cdot>(sfp TYPE('a)) = emb oo prj"
   1.830 +
   1.831 +syntax "_SFP" :: "type \<Rightarrow> sfp"  ("(1SFP/(1'(_')))")
   1.832 +translations "SFP('t)" \<rightleftharpoons> "CONST sfp TYPE('t)"
   1.833 +
   1.834 +interpretation sfp:
   1.835 +  pcpo_ep_pair "emb :: 'a::sfp \<rightarrow> udom" "prj :: udom \<rightarrow> 'a::sfp"
   1.836 +  unfolding pcpo_ep_pair_def
   1.837 +  by (rule ep_pair_emb_prj)
   1.838 +
   1.839 +lemmas emb_inverse = sfp.e_inverse
   1.840 +lemmas emb_prj_below = sfp.e_p_below
   1.841 +lemmas emb_eq_iff = sfp.e_eq_iff
   1.842 +lemmas emb_strict = sfp.e_strict
   1.843 +lemmas prj_strict = sfp.p_strict
   1.844 +
   1.845 +subsection {* SFP domains have a countable compact basis *}
   1.846 +
   1.847 +text {*
   1.848 +  Eventually it should be possible to generalize this to an unpointed
   1.849 +  variant of the sfp class.
   1.850 +*}
   1.851  
   1.852 -text {* This lemma says that if we have an ep-pair from
   1.853 -a bifinite domain into a universal domain, then e oo p
   1.854 -is an algebraic deflation. *}
   1.855 +interpretation compact_basis:
   1.856 +  ideal_completion below Rep_compact_basis "approximants::'a::sfp \<Rightarrow> _"
   1.857 +proof -
   1.858 +  obtain Y where Y: "\<forall>i. Y i \<sqsubseteq> Y (Suc i)"
   1.859 +  and SFP: "SFP('a) = (\<Squnion>i. sfp_principal (Y i))"
   1.860 +    by (rule sfp.obtain_principal_chain)
   1.861 +  def approx \<equiv> "\<lambda>i. (prj oo cast\<cdot>(sfp_principal (Y i)) oo emb) :: 'a \<rightarrow> 'a"
   1.862 +  interpret sfp_approx: approx_chain approx
   1.863 +  proof (rule approx_chain.intro)
   1.864 +    show "chain (\<lambda>i. approx i)"
   1.865 +      unfolding approx_def by (simp add: Y)
   1.866 +    show "(\<Squnion>i. approx i) = ID"
   1.867 +      unfolding approx_def
   1.868 +      by (simp add: lub_distribs Y SFP [symmetric] cast_SFP expand_cfun_eq)
   1.869 +    show "\<And>i. finite_deflation (approx i)"
   1.870 +      unfolding approx_def
   1.871 +      apply (rule sfp.finite_deflation_p_d_e)
   1.872 +      apply (rule finite_deflation_cast)
   1.873 +      apply (rule sfp.compact_principal)
   1.874 +      apply (rule below_trans [OF monofun_cfun_fun])
   1.875 +      apply (rule is_ub_thelub, simp add: Y)
   1.876 +      apply (simp add: lub_distribs Y SFP [symmetric] cast_SFP)
   1.877 +      done
   1.878 +  qed
   1.879 +  (* FIXME: why does show ?thesis fail here? *)
   1.880 +  show "ideal_completion below Rep_compact_basis (approximants::'a \<Rightarrow> _)" ..
   1.881 +qed
   1.882 +
   1.883 +subsection {* Type combinators *}
   1.884 +
   1.885 +definition
   1.886 +  sfp_fun1 ::
   1.887 +    "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a)) \<Rightarrow> (sfp \<rightarrow> sfp)"
   1.888 +where
   1.889 +  "sfp_fun1 approx f =
   1.890 +    sfp.basis_fun (\<lambda>a.
   1.891 +      sfp_principal (Abs_fin_defl
   1.892 +        (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)))"
   1.893  
   1.894 -lemma
   1.895 -  assumes "ep_pair e p"
   1.896 -  constrains e :: "'a::profinite \<rightarrow> 'b::profinite"
   1.897 -  shows "\<exists>d. cast\<cdot>d = e oo p"
   1.898 -proof
   1.899 -  interpret ep_pair e p by fact
   1.900 -  let ?a = "\<lambda>i. e oo approx i oo p"
   1.901 -  have a: "\<And>i. finite_deflation (?a i)"
   1.902 -    apply (rule finite_deflation_e_d_p)
   1.903 -    apply (rule finite_deflation_approx)
   1.904 +definition
   1.905 +  sfp_fun2 ::
   1.906 +    "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a))
   1.907 +      \<Rightarrow> (sfp \<rightarrow> sfp \<rightarrow> sfp)"
   1.908 +where
   1.909 +  "sfp_fun2 approx f =
   1.910 +    sfp.basis_fun (\<lambda>a.
   1.911 +      sfp.basis_fun (\<lambda>b.
   1.912 +        sfp_principal (Abs_fin_defl
   1.913 +          (udom_emb approx oo
   1.914 +            f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx))))"
   1.915 +
   1.916 +lemma cast_sfp_fun1:
   1.917 +  assumes approx: "approx_chain approx"
   1.918 +  assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
   1.919 +  shows "cast\<cdot>(sfp_fun1 approx f\<cdot>A) = udom_emb approx oo f\<cdot>(cast\<cdot>A) oo udom_prj approx"
   1.920 +proof -
   1.921 +  have 1: "\<And>a. finite_deflation
   1.922 +        (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)"
   1.923 +    apply (rule ep_pair.finite_deflation_e_d_p)
   1.924 +    apply (rule approx_chain.ep_pair_udom [OF approx])
   1.925 +    apply (rule f, rule finite_deflation_Rep_fin_defl)
   1.926      done
   1.927 -  let ?d = "\<Squnion>i. alg_defl_principal (Abs_fin_defl (?a i))"
   1.928 -  show "cast\<cdot>?d = e oo p"
   1.929 +  show ?thesis
   1.930 +    by (induct A rule: sfp.principal_induct, simp)
   1.931 +       (simp only: sfp_fun1_def
   1.932 +                   sfp.basis_fun_principal
   1.933 +                   sfp.basis_fun_mono
   1.934 +                   sfp.principal_mono
   1.935 +                   Abs_fin_defl_mono [OF 1 1]
   1.936 +                   monofun_cfun below_refl
   1.937 +                   Rep_fin_defl_mono
   1.938 +                   cast_sfp_principal
   1.939 +                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
   1.940 +qed
   1.941 +
   1.942 +lemma cast_sfp_fun2:
   1.943 +  assumes approx: "approx_chain approx"
   1.944 +  assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
   1.945 +                finite_deflation (f\<cdot>a\<cdot>b)"
   1.946 +  shows "cast\<cdot>(sfp_fun2 approx f\<cdot>A\<cdot>B) =
   1.947 +    udom_emb approx oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj approx"
   1.948 +proof -
   1.949 +  have 1: "\<And>a b. finite_deflation (udom_emb approx oo
   1.950 +      f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx)"
   1.951 +    apply (rule ep_pair.finite_deflation_e_d_p)
   1.952 +    apply (rule ep_pair_udom [OF approx])
   1.953 +    apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
   1.954 +    done
   1.955 +  show ?thesis
   1.956 +    by (induct A B rule: sfp.principal_induct2, simp, simp)
   1.957 +       (simp only: sfp_fun2_def
   1.958 +                   sfp.basis_fun_principal
   1.959 +                   sfp.basis_fun_mono
   1.960 +                   sfp.principal_mono
   1.961 +                   Abs_fin_defl_mono [OF 1 1]
   1.962 +                   monofun_cfun below_refl
   1.963 +                   Rep_fin_defl_mono
   1.964 +                   cast_sfp_principal
   1.965 +                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
   1.966 +qed
   1.967 +
   1.968 +subsection {* Instance for universal domain type *}
   1.969 +
   1.970 +instantiation udom :: sfp
   1.971 +begin
   1.972 +
   1.973 +definition [simp]:
   1.974 +  "emb = (ID :: udom \<rightarrow> udom)"
   1.975 +
   1.976 +definition [simp]:
   1.977 +  "prj = (ID :: udom \<rightarrow> udom)"
   1.978 +
   1.979 +definition
   1.980 +  "sfp (t::udom itself) = (\<Squnion>i. sfp_principal (Abs_fin_defl (udom_approx i)))"
   1.981 +
   1.982 +instance proof
   1.983 +  show "ep_pair emb (prj :: udom \<rightarrow> udom)"
   1.984 +    by (simp add: ep_pair.intro)
   1.985 +next
   1.986 +  show "cast\<cdot>SFP(udom) = emb oo (prj :: udom \<rightarrow> udom)"
   1.987 +    unfolding sfp_udom_def
   1.988      apply (subst contlub_cfun_arg)
   1.989      apply (rule chainI)
   1.990 -    apply (rule alg_defl.principal_mono)
   1.991 -    apply (rule Abs_fin_defl_mono [OF a a])
   1.992 -    apply (rule chainE, simp)
   1.993 -    apply (subst cast_alg_defl_principal)
   1.994 -    apply (simp add: Abs_fin_defl_inverse a)
   1.995 -    apply (simp add: expand_cfun_eq lub_distribs)
   1.996 -    done
   1.997 -qed
   1.998 -
   1.999 -text {* This lemma says that if we have an ep-pair
  1.1000 -from a cpo into a bifinite domain, and e oo p is
  1.1001 -an algebraic deflation, then the cpo is bifinite. *}
  1.1002 -
  1.1003 -lemma
  1.1004 -  assumes "ep_pair e p"
  1.1005 -  constrains e :: "'a::cpo \<rightarrow> 'b::profinite"
  1.1006 -  assumes d: "\<And>x. cast\<cdot>d\<cdot>x = e\<cdot>(p\<cdot>x)"
  1.1007 -  obtains a :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where
  1.1008 -    "\<And>i. finite_deflation (a i)"
  1.1009 -    "(\<Squnion>i. a i) = ID"
  1.1010 -proof
  1.1011 -  interpret ep_pair e p by fact
  1.1012 -  let ?a = "\<lambda>i. p oo cast\<cdot>(approx i\<cdot>d) oo e"
  1.1013 -  show "\<And>i. finite_deflation (?a i)"
  1.1014 -    apply (rule finite_deflation_p_d_e)
  1.1015 -    apply (rule finite_deflation_cast)
  1.1016 -    apply (rule compact_approx)
  1.1017 -    apply (rule below_eq_trans [OF _ d])
  1.1018 -    apply (rule monofun_cfun_fun)
  1.1019 -    apply (rule monofun_cfun_arg)
  1.1020 -    apply (rule approx_below)
  1.1021 -    done
  1.1022 -  show "(\<Squnion>i. ?a i) = ID"
  1.1023 -    apply (rule ext_cfun, simp)
  1.1024 -    apply (simp add: lub_distribs)
  1.1025 -    apply (simp add: d)
  1.1026 +    apply (rule sfp.principal_mono)
  1.1027 +    apply (simp add: below_fin_defl_def)
  1.1028 +    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
  1.1029 +    apply (rule chainE)
  1.1030 +    apply (rule chain_udom_approx)
  1.1031 +    apply (subst cast_sfp_principal)
  1.1032 +    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
  1.1033      done
  1.1034  qed
  1.1035  
  1.1036  end
  1.1037 +
  1.1038 +subsection {* Instance for continuous function space *}
  1.1039 +
  1.1040 +definition
  1.1041 +  cfun_approx :: "nat \<Rightarrow> (udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom)"
  1.1042 +where
  1.1043 +  "cfun_approx = (\<lambda>i. cfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
  1.1044 +
  1.1045 +lemma cfun_approx: "approx_chain cfun_approx"
  1.1046 +proof (rule approx_chain.intro)
  1.1047 +  show "chain (\<lambda>i. cfun_approx i)"
  1.1048 +    unfolding cfun_approx_def by simp
  1.1049 +  show "(\<Squnion>i. cfun_approx i) = ID"
  1.1050 +    unfolding cfun_approx_def
  1.1051 +    by (simp add: lub_distribs cfun_map_ID)
  1.1052 +  show "\<And>i. finite_deflation (cfun_approx i)"
  1.1053 +    unfolding cfun_approx_def
  1.1054 +    by (intro finite_deflation_cfun_map finite_deflation_udom_approx)
  1.1055 +qed
  1.1056 +
  1.1057 +definition cfun_sfp :: "sfp \<rightarrow> sfp \<rightarrow> sfp"
  1.1058 +where "cfun_sfp = sfp_fun2 cfun_approx cfun_map"
  1.1059 +
  1.1060 +lemma cast_cfun_sfp:
  1.1061 +  "cast\<cdot>(cfun_sfp\<cdot>A\<cdot>B) =
  1.1062 +    udom_emb cfun_approx oo cfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj cfun_approx"
  1.1063 +unfolding cfun_sfp_def
  1.1064 +apply (rule cast_sfp_fun2 [OF cfun_approx])
  1.1065 +apply (erule (1) finite_deflation_cfun_map)
  1.1066 +done
  1.1067 +
  1.1068 +instantiation cfun :: (sfp, sfp) sfp
  1.1069 +begin
  1.1070 +
  1.1071 +definition
  1.1072 +  "emb = udom_emb cfun_approx oo cfun_map\<cdot>prj\<cdot>emb"
  1.1073 +
  1.1074 +definition
  1.1075 +  "prj = cfun_map\<cdot>emb\<cdot>prj oo udom_prj cfun_approx"
  1.1076 +
  1.1077 +definition
  1.1078 +  "sfp (t::('a \<rightarrow> 'b) itself) = cfun_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
  1.1079 +
  1.1080 +instance proof
  1.1081 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
  1.1082 +    unfolding emb_cfun_def prj_cfun_def
  1.1083 +    using ep_pair_udom [OF cfun_approx]
  1.1084 +    by (intro ep_pair_comp ep_pair_cfun_map ep_pair_emb_prj)
  1.1085 +next
  1.1086 +  show "cast\<cdot>SFP('a \<rightarrow> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
  1.1087 +    unfolding emb_cfun_def prj_cfun_def sfp_cfun_def cast_cfun_sfp
  1.1088 +    by (simp add: cast_SFP oo_def expand_cfun_eq cfun_map_map)
  1.1089 +qed
  1.1090 +
  1.1091 +end
  1.1092 +
  1.1093 +lemma SFP_cfun: "SFP('a::sfp \<rightarrow> 'b::sfp) = cfun_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
  1.1094 +by (rule sfp_cfun_def)
  1.1095 +
  1.1096 +end
     2.1 --- a/src/HOLCF/Bifinite.thy	Tue Oct 05 17:53:00 2010 -0700
     2.2 +++ b/src/HOLCF/Bifinite.thy	Wed Oct 06 10:49:27 2010 -0700
     2.3 @@ -8,103 +8,7 @@
     2.4  imports Deflation
     2.5  begin
     2.6  
     2.7 -subsection {* Omega-profinite and bifinite domains *}
     2.8 -
     2.9 -class profinite =
    2.10 -  fixes approx :: "nat \<Rightarrow> 'a \<rightarrow> 'a"
    2.11 -  assumes chain_approx [simp]: "chain approx"
    2.12 -  assumes lub_approx_app [simp]: "(\<Squnion>i. approx i\<cdot>x) = x"
    2.13 -  assumes approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
    2.14 -  assumes finite_fixes_approx: "finite {x. approx i\<cdot>x = x}"
    2.15 -
    2.16 -class bifinite = profinite + pcpo
    2.17 -
    2.18 -lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
    2.19 -proof -
    2.20 -  have "chain (\<lambda>i. approx i\<cdot>x)" by simp
    2.21 -  hence "approx i\<cdot>x \<sqsubseteq> (\<Squnion>i. approx i\<cdot>x)" by (rule is_ub_thelub)
    2.22 -  thus "approx i\<cdot>x \<sqsubseteq> x" by simp
    2.23 -qed
    2.24 -
    2.25 -lemma finite_deflation_approx: "finite_deflation (approx i)"
    2.26 -proof
    2.27 -  fix x :: 'a
    2.28 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
    2.29 -    by (rule approx_idem)
    2.30 -  show "approx i\<cdot>x \<sqsubseteq> x"
    2.31 -    by (rule approx_below)
    2.32 -  show "finite {x. approx i\<cdot>x = x}"
    2.33 -    by (rule finite_fixes_approx)
    2.34 -qed
    2.35 -
    2.36 -interpretation approx: finite_deflation "approx i"
    2.37 -by (rule finite_deflation_approx)
    2.38 -
    2.39 -lemma (in deflation) deflation: "deflation d" ..
    2.40 -
    2.41 -lemma deflation_approx: "deflation (approx i)"
    2.42 -by (rule approx.deflation)
    2.43 -
    2.44 -lemma lub_approx [simp]: "(\<Squnion>i. approx i) = (\<Lambda> x. x)"
    2.45 -by (rule ext_cfun, simp add: contlub_cfun_fun)
    2.46 -
    2.47 -lemma approx_strict [simp]: "approx i\<cdot>\<bottom> = \<bottom>"
    2.48 -by (rule UU_I, rule approx_below)
    2.49 -
    2.50 -lemma approx_approx1:
    2.51 -  "i \<le> j \<Longrightarrow> approx i\<cdot>(approx j\<cdot>x) = approx i\<cdot>x"
    2.52 -apply (rule deflation_below_comp1 [OF deflation_approx deflation_approx])
    2.53 -apply (erule chain_mono [OF chain_approx])
    2.54 -done
    2.55 -
    2.56 -lemma approx_approx2:
    2.57 -  "j \<le> i \<Longrightarrow> approx i\<cdot>(approx j\<cdot>x) = approx j\<cdot>x"
    2.58 -apply (rule deflation_below_comp2 [OF deflation_approx deflation_approx])
    2.59 -apply (erule chain_mono [OF chain_approx])
    2.60 -done
    2.61 -
    2.62 -lemma approx_approx [simp]:
    2.63 -  "approx i\<cdot>(approx j\<cdot>x) = approx (min i j)\<cdot>x"
    2.64 -apply (rule_tac x=i and y=j in linorder_le_cases)
    2.65 -apply (simp add: approx_approx1 min_def)
    2.66 -apply (simp add: approx_approx2 min_def)
    2.67 -done
    2.68 -
    2.69 -lemma finite_image_approx: "finite ((\<lambda>x. approx n\<cdot>x) ` A)"
    2.70 -by (rule approx.finite_image)
    2.71 -
    2.72 -lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
    2.73 -by (rule approx.finite_range)
    2.74 -
    2.75 -lemma compact_approx [simp]: "compact (approx n\<cdot>x)"
    2.76 -by (rule approx.compact)
    2.77 -
    2.78 -lemma profinite_compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
    2.79 -by (rule admD2, simp_all)
    2.80 -
    2.81 -lemma profinite_compact_iff: "compact x \<longleftrightarrow> (\<exists>n. approx n\<cdot>x = x)"
    2.82 - apply (rule iffI)
    2.83 -  apply (erule profinite_compact_eq_approx)
    2.84 - apply (erule exE)
    2.85 - apply (erule subst)
    2.86 - apply (rule compact_approx)
    2.87 -done
    2.88 -
    2.89 -lemma approx_induct:
    2.90 -  assumes adm: "adm P" and P: "\<And>n x. P (approx n\<cdot>x)"
    2.91 -  shows "P x"
    2.92 -proof -
    2.93 -  have "P (\<Squnion>n. approx n\<cdot>x)"
    2.94 -    by (rule admD [OF adm], simp, simp add: P)
    2.95 -  thus "P x" by simp
    2.96 -qed
    2.97 -
    2.98 -lemma profinite_below_ext: "(\<And>i. approx i\<cdot>x \<sqsubseteq> approx i\<cdot>y) \<Longrightarrow> x \<sqsubseteq> y"
    2.99 -apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> (\<Squnion>i. approx i\<cdot>y)", simp)
   2.100 -apply (rule lub_mono, simp, simp, simp)
   2.101 -done
   2.102 -
   2.103 -subsection {* Instance for product type *}
   2.104 +subsection {* Map operator for product type *}
   2.105  
   2.106  definition
   2.107    cprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
   2.108 @@ -161,46 +65,7 @@
   2.109      by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
   2.110  qed
   2.111  
   2.112 -instantiation prod :: (profinite, profinite) profinite
   2.113 -begin
   2.114 -
   2.115 -definition
   2.116 -  approx_prod_def:
   2.117 -    "approx = (\<lambda>n. cprod_map\<cdot>(approx n)\<cdot>(approx n))"
   2.118 -
   2.119 -instance proof
   2.120 -  fix i :: nat and x :: "'a \<times> 'b"
   2.121 -  show "chain (approx :: nat \<Rightarrow> 'a \<times> 'b \<rightarrow> 'a \<times> 'b)"
   2.122 -    unfolding approx_prod_def by simp
   2.123 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   2.124 -    unfolding approx_prod_def cprod_map_def
   2.125 -    by (simp add: lub_distribs thelub_Pair)
   2.126 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   2.127 -    unfolding approx_prod_def cprod_map_def by simp
   2.128 -  have "{x::'a \<times> 'b. approx i\<cdot>x = x} \<subseteq>
   2.129 -        {x::'a. approx i\<cdot>x = x} \<times> {x::'b. approx i\<cdot>x = x}"
   2.130 -    unfolding approx_prod_def by clarsimp
   2.131 -  thus "finite {x::'a \<times> 'b. approx i\<cdot>x = x}"
   2.132 -    by (rule finite_subset,
   2.133 -        intro finite_cartesian_product finite_fixes_approx)
   2.134 -qed
   2.135 -
   2.136 -end
   2.137 -
   2.138 -instance prod :: (bifinite, bifinite) bifinite ..
   2.139 -
   2.140 -lemma approx_Pair [simp]:
   2.141 -  "approx i\<cdot>(x, y) = (approx i\<cdot>x, approx i\<cdot>y)"
   2.142 -unfolding approx_prod_def by simp
   2.143 -
   2.144 -lemma fst_approx: "fst (approx i\<cdot>p) = approx i\<cdot>(fst p)"
   2.145 -by (induct p, simp)
   2.146 -
   2.147 -lemma snd_approx: "snd (approx i\<cdot>p) = approx i\<cdot>(snd p)"
   2.148 -by (induct p, simp)
   2.149 -
   2.150 -
   2.151 -subsection {* Instance for continuous function space *}
   2.152 +subsection {* Map operator for continuous function space *}
   2.153  
   2.154  definition
   2.155    cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
   2.156 @@ -305,39 +170,4 @@
   2.157  apply (simp only: finite_deflation_cfun_map)
   2.158  done
   2.159  
   2.160 -instantiation cfun :: (profinite, profinite) profinite
   2.161 -begin
   2.162 -
   2.163 -definition
   2.164 -  approx_cfun_def:
   2.165 -    "approx = (\<lambda>n. cfun_map\<cdot>(approx n)\<cdot>(approx n))"
   2.166 -
   2.167 -instance proof
   2.168 -  show "chain (approx :: nat \<Rightarrow> ('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b))"
   2.169 -    unfolding approx_cfun_def by simp
   2.170 -next
   2.171 -  fix x :: "'a \<rightarrow> 'b"
   2.172 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   2.173 -    unfolding approx_cfun_def cfun_map_def
   2.174 -    by (simp add: lub_distribs eta_cfun)
   2.175 -next
   2.176 -  fix i :: nat and x :: "'a \<rightarrow> 'b"
   2.177 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   2.178 -    unfolding approx_cfun_def cfun_map_def by simp
   2.179 -next
   2.180 -  fix i :: nat
   2.181 -  show "finite {x::'a \<rightarrow> 'b. approx i\<cdot>x = x}"
   2.182 -    unfolding approx_cfun_def
   2.183 -    by (intro finite_deflation.finite_fixes
   2.184 -              finite_deflation_cfun_map
   2.185 -              finite_deflation_approx)
   2.186 -qed
   2.187 -
   2.188  end
   2.189 -
   2.190 -instance cfun :: (profinite, bifinite) bifinite ..
   2.191 -
   2.192 -lemma approx_cfun: "approx n\<cdot>f\<cdot>x = approx n\<cdot>(f\<cdot>(approx n\<cdot>x))"
   2.193 -by (simp add: approx_cfun_def)
   2.194 -
   2.195 -end
     3.1 --- a/src/HOLCF/CompactBasis.thy	Tue Oct 05 17:53:00 2010 -0700
     3.2 +++ b/src/HOLCF/CompactBasis.thy	Wed Oct 06 10:49:27 2010 -0700
     3.3 @@ -2,174 +2,18 @@
     3.4      Author:     Brian Huffman
     3.5  *)
     3.6  
     3.7 -header {* Compact bases of domains *}
     3.8 +header {* A compact basis for powerdomains *}
     3.9  
    3.10  theory CompactBasis
    3.11 -imports Completion Bifinite
    3.12 -begin
    3.13 -
    3.14 -subsection {* Compact bases of bifinite domains *}
    3.15 -
    3.16 -default_sort profinite
    3.17 -
    3.18 -typedef (open) 'a compact_basis = "{x::'a::profinite. compact x}"
    3.19 -by (fast intro: compact_approx)
    3.20 -
    3.21 -lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
    3.22 -by (rule Rep_compact_basis [unfolded mem_Collect_eq])
    3.23 -
    3.24 -instantiation compact_basis :: (profinite) below
    3.25 +imports Algebraic
    3.26  begin
    3.27  
    3.28 -definition
    3.29 -  compact_le_def:
    3.30 -    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. Rep_compact_basis x \<sqsubseteq> Rep_compact_basis y)"
    3.31 -
    3.32 -instance ..
    3.33 -
    3.34 -end
    3.35 -
    3.36 -instance compact_basis :: (profinite) po
    3.37 -by (rule typedef_po
    3.38 -    [OF type_definition_compact_basis compact_le_def])
    3.39 -
    3.40 -text {* Take function for compact basis *}
    3.41 -
    3.42 -definition
    3.43 -  compact_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis" where
    3.44 -  "compact_take = (\<lambda>n a. Abs_compact_basis (approx n\<cdot>(Rep_compact_basis a)))"
    3.45 -
    3.46 -lemma Rep_compact_take:
    3.47 -  "Rep_compact_basis (compact_take n a) = approx n\<cdot>(Rep_compact_basis a)"
    3.48 -unfolding compact_take_def
    3.49 -by (simp add: Abs_compact_basis_inverse)
    3.50 -
    3.51 -lemmas approx_Rep_compact_basis = Rep_compact_take [symmetric]
    3.52 -
    3.53 -interpretation compact_basis:
    3.54 -  basis_take below compact_take
    3.55 -proof
    3.56 -  fix n :: nat and a :: "'a compact_basis"
    3.57 -  show "compact_take n a \<sqsubseteq> a"
    3.58 -    unfolding compact_le_def
    3.59 -    by (simp add: Rep_compact_take approx_below)
    3.60 -next
    3.61 -  fix n :: nat and a :: "'a compact_basis"
    3.62 -  show "compact_take n (compact_take n a) = compact_take n a"
    3.63 -    by (simp add: Rep_compact_basis_inject [symmetric] Rep_compact_take)
    3.64 -next
    3.65 -  fix n :: nat and a b :: "'a compact_basis"
    3.66 -  assume "a \<sqsubseteq> b" thus "compact_take n a \<sqsubseteq> compact_take n b"
    3.67 -    unfolding compact_le_def Rep_compact_take
    3.68 -    by (rule monofun_cfun_arg)
    3.69 -next
    3.70 -  fix n :: nat and a :: "'a compact_basis"
    3.71 -  show "\<And>n a. compact_take n a \<sqsubseteq> compact_take (Suc n) a"
    3.72 -    unfolding compact_le_def Rep_compact_take
    3.73 -    by (rule chainE, simp)
    3.74 -next
    3.75 -  fix n :: nat
    3.76 -  show "finite (range (compact_take n))"
    3.77 -    apply (rule finite_imageD [where f="Rep_compact_basis"])
    3.78 -    apply (rule finite_subset [where B="range (\<lambda>x. approx n\<cdot>x)"])
    3.79 -    apply (clarsimp simp add: Rep_compact_take)
    3.80 -    apply (rule finite_range_approx)
    3.81 -    apply (rule inj_onI, simp add: Rep_compact_basis_inject)
    3.82 -    done
    3.83 -next
    3.84 -  fix a :: "'a compact_basis"
    3.85 -  show "\<exists>n. compact_take n a = a"
    3.86 -    apply (simp add: Rep_compact_basis_inject [symmetric])
    3.87 -    apply (simp add: Rep_compact_take)
    3.88 -    apply (rule profinite_compact_eq_approx)
    3.89 -    apply (rule compact_Rep_compact_basis)
    3.90 -    done
    3.91 -qed
    3.92 -
    3.93 -text {* Ideal completion *}
    3.94 -
    3.95 -definition
    3.96 -  approximants :: "'a \<Rightarrow> 'a compact_basis set" where
    3.97 -  "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
    3.98 -
    3.99 -interpretation compact_basis:
   3.100 -  ideal_completion below compact_take Rep_compact_basis approximants
   3.101 -proof
   3.102 -  fix w :: 'a
   3.103 -  show "preorder.ideal below (approximants w)"
   3.104 -  proof (rule below.idealI)
   3.105 -    show "\<exists>x. x \<in> approximants w"
   3.106 -      unfolding approximants_def
   3.107 -      apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
   3.108 -      apply (simp add: Abs_compact_basis_inverse approx_below)
   3.109 -      done
   3.110 -  next
   3.111 -    fix x y :: "'a compact_basis"
   3.112 -    assume "x \<in> approximants w" "y \<in> approximants w"
   3.113 -    thus "\<exists>z \<in> approximants w. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
   3.114 -      unfolding approximants_def
   3.115 -      apply simp
   3.116 -      apply (cut_tac a=x in compact_Rep_compact_basis)
   3.117 -      apply (cut_tac a=y in compact_Rep_compact_basis)
   3.118 -      apply (drule profinite_compact_eq_approx)
   3.119 -      apply (drule profinite_compact_eq_approx)
   3.120 -      apply (clarify, rename_tac i j)
   3.121 -      apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
   3.122 -      apply (simp add: compact_le_def)
   3.123 -      apply (simp add: Abs_compact_basis_inverse approx_below)
   3.124 -      apply (erule subst, erule subst)
   3.125 -      apply (simp add: monofun_cfun chain_mono [OF chain_approx])
   3.126 -      done
   3.127 -  next
   3.128 -    fix x y :: "'a compact_basis"
   3.129 -    assume "x \<sqsubseteq> y" "y \<in> approximants w" thus "x \<in> approximants w"
   3.130 -      unfolding approximants_def
   3.131 -      apply simp
   3.132 -      apply (simp add: compact_le_def)
   3.133 -      apply (erule (1) below_trans)
   3.134 -      done
   3.135 -  qed
   3.136 -next
   3.137 -  fix Y :: "nat \<Rightarrow> 'a"
   3.138 -  assume Y: "chain Y"
   3.139 -  show "approximants (\<Squnion>i. Y i) = (\<Union>i. approximants (Y i))"
   3.140 -    unfolding approximants_def
   3.141 -    apply safe
   3.142 -    apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
   3.143 -    apply (erule below_trans, rule is_ub_thelub [OF Y])
   3.144 -    done
   3.145 -next
   3.146 -  fix a :: "'a compact_basis"
   3.147 -  show "approximants (Rep_compact_basis a) = {b. b \<sqsubseteq> a}"
   3.148 -    unfolding approximants_def compact_le_def ..
   3.149 -next
   3.150 -  fix x y :: "'a"
   3.151 -  assume "approximants x \<subseteq> approximants y" thus "x \<sqsubseteq> y"
   3.152 -    apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y", simp)
   3.153 -    apply (rule admD, simp, simp)
   3.154 -    apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
   3.155 -    apply (simp add: approximants_def Abs_compact_basis_inverse approx_below)
   3.156 -    apply (simp add: approximants_def Abs_compact_basis_inverse)
   3.157 -    done
   3.158 -qed
   3.159 -
   3.160 -text {* minimal compact element *}
   3.161 -
   3.162 -definition
   3.163 -  compact_bot :: "'a::bifinite compact_basis" where
   3.164 -  "compact_bot = Abs_compact_basis \<bottom>"
   3.165 -
   3.166 -lemma Rep_compact_bot: "Rep_compact_basis compact_bot = \<bottom>"
   3.167 -unfolding compact_bot_def by (simp add: Abs_compact_basis_inverse)
   3.168 -
   3.169 -lemma compact_bot_minimal [simp]: "compact_bot \<sqsubseteq> a"
   3.170 -unfolding compact_le_def Rep_compact_bot by simp
   3.171 -
   3.172 +default_sort sfp
   3.173  
   3.174  subsection {* A compact basis for powerdomains *}
   3.175  
   3.176  typedef 'a pd_basis =
   3.177 -  "{S::'a::profinite compact_basis set. finite S \<and> S \<noteq> {}}"
   3.178 +  "{S::'a compact_basis set. finite S \<and> S \<noteq> {}}"
   3.179  by (rule_tac x="{arbitrary}" in exI, simp)
   3.180  
   3.181  lemma finite_Rep_pd_basis [simp]: "finite (Rep_pd_basis u)"
   3.182 @@ -178,7 +22,21 @@
   3.183  lemma Rep_pd_basis_nonempty [simp]: "Rep_pd_basis u \<noteq> {}"
   3.184  by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
   3.185  
   3.186 -text {* unit and plus *}
   3.187 +text {* The powerdomain basis type is countable. *}
   3.188 +
   3.189 +lemma pd_basis_countable: "\<exists>f::'a::sfp pd_basis \<Rightarrow> nat. inj f"
   3.190 +proof -
   3.191 +  obtain g :: "'a compact_basis \<Rightarrow> nat" where "inj g"
   3.192 +    using compact_basis.countable ..
   3.193 +  hence image_g_eq: "\<And>A B. g ` A = g ` B \<longleftrightarrow> A = B"
   3.194 +    by (rule inj_image_eq_iff)
   3.195 +  have "inj (\<lambda>t. set_encode (g ` Rep_pd_basis t))"
   3.196 +    by (simp add: inj_on_def set_encode_eq image_g_eq Rep_pd_basis_inject)
   3.197 +  thus ?thesis by - (rule exI)
   3.198 +  (* FIXME: why doesn't ".." or "by (rule exI)" work? *)
   3.199 +qed
   3.200 +
   3.201 +subsection {* Unit and plus constructors *}
   3.202  
   3.203  definition
   3.204    PDUnit :: "'a compact_basis \<Rightarrow> 'a pd_basis" where
   3.205 @@ -229,7 +87,7 @@
   3.206  apply (rule PDUnit, erule PDPlus [OF PDUnit])
   3.207  done
   3.208  
   3.209 -text {* fold-pd *}
   3.210 +subsection {* Fold operator *}
   3.211  
   3.212  definition
   3.213    fold_pd ::
   3.214 @@ -250,52 +108,26 @@
   3.215      by (simp add: image_Un fold1_Un2)
   3.216  qed
   3.217  
   3.218 -text {* Take function for powerdomain basis *}
   3.219 -
   3.220 -definition
   3.221 -  pd_take :: "nat \<Rightarrow> 'a pd_basis \<Rightarrow> 'a pd_basis" where
   3.222 -  "pd_take n = (\<lambda>t. Abs_pd_basis (compact_take n ` Rep_pd_basis t))"
   3.223 +subsection {* Lemmas for proving if-and-only-if inequalities *}
   3.224  
   3.225 -lemma Rep_pd_take:
   3.226 -  "Rep_pd_basis (pd_take n t) = compact_take n ` Rep_pd_basis t"
   3.227 -unfolding pd_take_def
   3.228 -apply (rule Abs_pd_basis_inverse)
   3.229 -apply (simp add: pd_basis_def)
   3.230 -done
   3.231 -
   3.232 -lemma pd_take_simps [simp]:
   3.233 -  "pd_take n (PDUnit a) = PDUnit (compact_take n a)"
   3.234 -  "pd_take n (PDPlus t u) = PDPlus (pd_take n t) (pd_take n u)"
   3.235 -apply (simp_all add: Rep_pd_basis_inject [symmetric])
   3.236 -apply (simp_all add: Rep_pd_take Rep_PDUnit Rep_PDPlus image_Un)
   3.237 +lemma chain_max_below_iff:
   3.238 +  assumes Y: "chain Y" shows "Y (max i j) \<sqsubseteq> x \<longleftrightarrow> Y i \<sqsubseteq> x \<and> Y j \<sqsubseteq> x"
   3.239 +apply auto
   3.240 +apply (erule below_trans [OF chain_mono [OF Y le_maxI1]])
   3.241 +apply (erule below_trans [OF chain_mono [OF Y le_maxI2]])
   3.242 +apply (simp add: max_def)
   3.243  done
   3.244  
   3.245 -lemma pd_take_idem: "pd_take n (pd_take n t) = pd_take n t"
   3.246 -apply (induct t rule: pd_basis_induct)
   3.247 -apply (simp add: compact_basis.take_take)
   3.248 -apply simp
   3.249 -done
   3.250 -
   3.251 -lemma finite_range_pd_take: "finite (range (pd_take n))"
   3.252 -apply (rule finite_imageD [where f="Rep_pd_basis"])
   3.253 -apply (rule finite_subset [where B="Pow (range (compact_take n))"])
   3.254 -apply (clarsimp simp add: Rep_pd_take)
   3.255 -apply (simp add: compact_basis.finite_range_take)
   3.256 -apply (rule inj_onI, simp add: Rep_pd_basis_inject)
   3.257 -done
   3.258 +lemma all_ex_below_disj_iff:
   3.259 +  assumes "chain X" and "chain Y"
   3.260 +  shows "(\<forall>i. \<exists>j. X i \<sqsubseteq> Z j \<or> Y i \<sqsubseteq> Z j) \<longleftrightarrow>
   3.261 +         (\<forall>i. \<exists>j. X i \<sqsubseteq> Z j) \<or> (\<forall>i. \<exists>j. Y i \<sqsubseteq> Z j)"
   3.262 +by (metis chain_max_below_iff assms)
   3.263  
   3.264 -lemma pd_take_covers: "\<exists>n. pd_take n t = t"
   3.265 -apply (subgoal_tac "\<exists>n. \<forall>m\<ge>n. pd_take m t = t", fast)
   3.266 -apply (induct t rule: pd_basis_induct)
   3.267 -apply (cut_tac a=a in compact_basis.take_covers)
   3.268 -apply (clarify, rule_tac x=n in exI)
   3.269 -apply (clarify, simp)
   3.270 -apply (rule below_antisym)
   3.271 -apply (rule compact_basis.take_less)
   3.272 -apply (drule_tac a=a in compact_basis.take_chain_le)
   3.273 -apply simp
   3.274 -apply (clarify, rename_tac i j)
   3.275 -apply (rule_tac x="max i j" in exI, simp)
   3.276 -done
   3.277 +lemma all_ex_below_conj_iff:
   3.278 +  assumes "chain X" and "chain Y" and "chain Z"
   3.279 +  shows "(\<forall>i. \<exists>j. X i \<sqsubseteq> Z j \<and> Y i \<sqsubseteq> Z j) \<longleftrightarrow>
   3.280 +         (\<forall>i. \<exists>j. X i \<sqsubseteq> Z j) \<and> (\<forall>i. \<exists>j. Y i \<sqsubseteq> Z j)"
   3.281 +oops
   3.282  
   3.283  end
     4.1 --- a/src/HOLCF/Completion.thy	Tue Oct 05 17:53:00 2010 -0700
     4.2 +++ b/src/HOLCF/Completion.thy	Wed Oct 06 10:49:27 2010 -0700
     4.3 @@ -2,7 +2,7 @@
     4.4      Author:     Brian Huffman
     4.5  *)
     4.6  
     4.7 -header {* Defining bifinite domains by ideal completion *}
     4.8 +header {* Defining algebraic domains by ideal completion *}
     4.9  
    4.10  theory Completion
    4.11  imports Cfun
    4.12 @@ -164,64 +164,27 @@
    4.13  
    4.14  subsection {* Lemmas about least upper bounds *}
    4.15  
    4.16 -lemma finite_directed_contains_lub:
    4.17 -  "\<lbrakk>finite S; directed S\<rbrakk> \<Longrightarrow> \<exists>u\<in>S. S <<| u"
    4.18 -apply (drule (1) directed_finiteD, rule subset_refl)
    4.19 -apply (erule bexE)
    4.20 -apply (rule rev_bexI, assumption)
    4.21 -apply (erule (1) is_lub_maximal)
    4.22 -done
    4.23 -
    4.24 -lemma lub_finite_directed_in_self:
    4.25 -  "\<lbrakk>finite S; directed S\<rbrakk> \<Longrightarrow> lub S \<in> S"
    4.26 -apply (drule (1) finite_directed_contains_lub, clarify)
    4.27 -apply (drule thelubI, simp)
    4.28 -done
    4.29 -
    4.30 -lemma finite_directed_has_lub: "\<lbrakk>finite S; directed S\<rbrakk> \<Longrightarrow> \<exists>u. S <<| u"
    4.31 -by (drule (1) finite_directed_contains_lub, fast)
    4.32 -
    4.33 -lemma is_ub_thelub0: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
    4.34 +lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
    4.35  apply (erule exE, drule lubI)
    4.36  apply (drule is_lubD1)
    4.37  apply (erule (1) is_ubD)
    4.38  done
    4.39  
    4.40 -lemma is_lub_thelub0: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
    4.41 +lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
    4.42  by (erule exE, drule lubI, erule is_lub_lub)
    4.43  
    4.44  subsection {* Locale for ideal completion *}
    4.45  
    4.46 -locale basis_take = preorder +
    4.47 -  fixes take :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'a"
    4.48 -  assumes take_less: "take n a \<preceq> a"
    4.49 -  assumes take_take: "take n (take n a) = take n a"
    4.50 -  assumes take_mono: "a \<preceq> b \<Longrightarrow> take n a \<preceq> take n b"
    4.51 -  assumes take_chain: "take n a \<preceq> take (Suc n) a"
    4.52 -  assumes finite_range_take: "finite (range (take n))"
    4.53 -  assumes take_covers: "\<exists>n. take n a = a"
    4.54 -begin
    4.55 -
    4.56 -lemma take_chain_less: "m < n \<Longrightarrow> take m a \<preceq> take n a"
    4.57 -by (erule less_Suc_induct, rule take_chain, erule (1) r_trans)
    4.58 -
    4.59 -lemma take_chain_le: "m \<le> n \<Longrightarrow> take m a \<preceq> take n a"
    4.60 -by (cases "m = n", simp add: r_refl, simp add: take_chain_less)
    4.61 -
    4.62 -end
    4.63 -
    4.64 -locale ideal_completion = basis_take +
    4.65 +locale ideal_completion = preorder +
    4.66    fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
    4.67    fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
    4.68 -  assumes ideal_rep: "\<And>x. preorder.ideal r (rep x)"
    4.69 +  assumes ideal_rep: "\<And>x. ideal (rep x)"
    4.70    assumes rep_contlub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
    4.71    assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
    4.72    assumes subset_repD: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
    4.73 +  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
    4.74  begin
    4.75  
    4.76 -lemma finite_take_rep: "finite (take n ` rep x)"
    4.77 -by (rule finite_subset [OF image_mono [OF subset_UNIV] finite_range_take])
    4.78 -
    4.79  lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
    4.80  apply (frule bin_chain)
    4.81  apply (drule rep_contlub)
    4.82 @@ -251,12 +214,19 @@
    4.83  lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
    4.84  unfolding po_eq_conv [where 'a='b] principal_below_iff ..
    4.85  
    4.86 +lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
    4.87 +unfolding po_eq_conv below_def by auto
    4.88 +
    4.89  lemma repD: "a \<in> rep x \<Longrightarrow> principal a \<sqsubseteq> x"
    4.90  by (simp add: rep_eq)
    4.91  
    4.92  lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
    4.93  by (simp only: principal_below_iff)
    4.94  
    4.95 +lemma ch2ch_principal [simp]:
    4.96 +  "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
    4.97 +by (simp add: chainI principal_mono)
    4.98 +
    4.99  lemma belowI: "(\<And>a. principal a \<sqsubseteq> x \<Longrightarrow> principal a \<sqsubseteq> u) \<Longrightarrow> x \<sqsubseteq> u"
   4.100  unfolding principal_below_iff_mem_rep
   4.101  by (simp add: below_def subset_eq)
   4.102 @@ -271,68 +241,155 @@
   4.103  apply (simp add: rep_eq)
   4.104  done
   4.105  
   4.106 +subsubsection {* Principal ideals approximate all elements *}
   4.107 +
   4.108 +lemma compact_principal [simp]: "compact (principal a)"
   4.109 +by (rule compactI2, simp add: principal_below_iff_mem_rep rep_contlub)
   4.110 +
   4.111 +text {* Construct a chain whose lub is the same as a given ideal *}
   4.112 +
   4.113 +lemma obtain_principal_chain:
   4.114 +  obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
   4.115 +proof -
   4.116 +  obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
   4.117 +    using countable ..
   4.118 +  def enum \<equiv> "\<lambda>i. THE a. count a = i"
   4.119 +  have enum_count [simp]: "\<And>x. enum (count x) = x"
   4.120 +    unfolding enum_def by (simp add: inj_eq [OF inj])
   4.121 +  def a \<equiv> "LEAST i. enum i \<in> rep x"
   4.122 +  def b \<equiv> "\<lambda>i. LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
   4.123 +  def c \<equiv> "\<lambda>i j. LEAST k. enum k \<in> rep x \<and> enum i \<preceq> enum k \<and> enum j \<preceq> enum k"
   4.124 +  def P \<equiv> "\<lambda>i. \<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
   4.125 +  def X \<equiv> "nat_rec a (\<lambda>n i. if P i then c i (b i) else i)"
   4.126 +  have X_0: "X 0 = a" unfolding X_def by simp
   4.127 +  have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
   4.128 +    unfolding X_def by simp
   4.129 +  have a_mem: "enum a \<in> rep x"
   4.130 +    unfolding a_def
   4.131 +    apply (rule LeastI_ex)
   4.132 +    apply (cut_tac ideal_rep [of x])
   4.133 +    apply (drule idealD1)
   4.134 +    apply (clarify, rename_tac a)
   4.135 +    apply (rule_tac x="count a" in exI, simp)
   4.136 +    done
   4.137 +  have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
   4.138 +    \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
   4.139 +    unfolding P_def b_def by (erule LeastI2_ex, simp)
   4.140 +  have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
   4.141 +    \<Longrightarrow> enum (c i j) \<in> rep x \<and> enum i \<preceq> enum (c i j) \<and> enum j \<preceq> enum (c i j)"
   4.142 +    unfolding c_def
   4.143 +    apply (drule (1) idealD2 [OF ideal_rep], clarify)
   4.144 +    apply (rule_tac a="count z" in LeastI2, simp, simp)
   4.145 +    done
   4.146 +  have X_mem: "\<And>n. enum (X n) \<in> rep x"
   4.147 +    apply (induct_tac n)
   4.148 +    apply (simp add: X_0 a_mem)
   4.149 +    apply (clarsimp simp add: X_Suc, rename_tac n)
   4.150 +    apply (simp add: b c)
   4.151 +    done
   4.152 +  have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
   4.153 +    apply (clarsimp simp add: X_Suc r_refl)
   4.154 +    apply (simp add: b c X_mem)
   4.155 +    done
   4.156 +  have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
   4.157 +    unfolding b_def by (drule not_less_Least, simp)
   4.158 +  have X_covers: "\<And>n. \<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)"
   4.159 +    apply (induct_tac n)
   4.160 +    apply (clarsimp simp add: X_0 a_def)
   4.161 +    apply (drule_tac k=0 in Least_le, simp add: r_refl)
   4.162 +    apply (clarsimp, rename_tac n k)
   4.163 +    apply (erule le_SucE)
   4.164 +    apply (rule r_trans [OF _ X_chain], simp)
   4.165 +    apply (case_tac "P (X n)", simp add: X_Suc)
   4.166 +    apply (rule_tac x="b (X n)" and y="Suc n" in linorder_cases)
   4.167 +    apply (simp only: less_Suc_eq_le)
   4.168 +    apply (drule spec, drule (1) mp, simp add: b X_mem)
   4.169 +    apply (simp add: c X_mem)
   4.170 +    apply (drule (1) less_b)
   4.171 +    apply (erule r_trans)
   4.172 +    apply (simp add: b c X_mem)
   4.173 +    apply (simp add: X_Suc)
   4.174 +    apply (simp add: P_def)
   4.175 +    done
   4.176 +  have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
   4.177 +    by (simp add: X_chain)
   4.178 +  have 2: "x = (\<Squnion>n. principal (enum (X n)))"
   4.179 +    apply (simp add: eq_iff rep_contlub 1 rep_principal)
   4.180 +    apply (auto, rename_tac a)
   4.181 +    apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
   4.182 +    apply (rule_tac x=i in exI, simp add: X_covers)
   4.183 +    apply (rule_tac x="count a" in exI, simp)
   4.184 +    apply (erule idealD3 [OF ideal_rep])
   4.185 +    apply (rule X_mem)
   4.186 +    done
   4.187 +  from 1 2 show ?thesis ..
   4.188 +qed
   4.189 +
   4.190 +lemma principal_induct:
   4.191 +  assumes adm: "adm P"
   4.192 +  assumes P: "\<And>a. P (principal a)"
   4.193 +  shows "P x"
   4.194 +apply (rule obtain_principal_chain [of x])
   4.195 +apply (simp add: admD [OF adm] P)
   4.196 +done
   4.197 +
   4.198 +lemma principal_induct2:
   4.199 +  "\<lbrakk>\<And>y. adm (\<lambda>x. P x y); \<And>x. adm (\<lambda>y. P x y);
   4.200 +    \<And>a b. P (principal a) (principal b)\<rbrakk> \<Longrightarrow> P x y"
   4.201 +apply (rule_tac x=y in spec)
   4.202 +apply (rule_tac x=x in principal_induct, simp)
   4.203 +apply (rule allI, rename_tac y)
   4.204 +apply (rule_tac x=y in principal_induct, simp)
   4.205 +apply simp
   4.206 +done
   4.207 +
   4.208 +lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
   4.209 +apply (rule obtain_principal_chain [of x])
   4.210 +apply (drule adm_compact_neq [OF _ cont_id])
   4.211 +apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
   4.212 +apply (drule (2) admD2, fast, simp)
   4.213 +done
   4.214 +
   4.215 +lemma obtain_compact_chain:
   4.216 +  obtains Y :: "nat \<Rightarrow> 'b"
   4.217 +  where "chain Y" and "\<forall>i. compact (Y i)" and "x = (\<Squnion>i. Y i)"
   4.218 +apply (rule obtain_principal_chain [of x])
   4.219 +apply (rule_tac Y="\<lambda>i. principal (Y i)" in that, simp_all)
   4.220 +done
   4.221 +
   4.222  subsection {* Defining functions in terms of basis elements *}
   4.223  
   4.224  definition
   4.225    basis_fun :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
   4.226    "basis_fun = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"
   4.227  
   4.228 -lemma basis_fun_lemma0:
   4.229 -  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   4.230 -  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   4.231 -  shows "\<exists>u. f ` take i ` rep x <<| u"
   4.232 -apply (rule finite_directed_has_lub)
   4.233 -apply (rule finite_imageI)
   4.234 -apply (rule finite_take_rep)
   4.235 -apply (subst image_image)
   4.236 -apply (rule directed_image_ideal)
   4.237 -apply (rule ideal_rep)
   4.238 -apply (rule f_mono)
   4.239 -apply (erule take_mono)
   4.240 -done
   4.241 -
   4.242 -lemma basis_fun_lemma1:
   4.243 -  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   4.244 -  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   4.245 -  shows "chain (\<lambda>i. lub (f ` take i ` rep x))"
   4.246 - apply (rule chainI)
   4.247 - apply (rule is_lub_thelub0)
   4.248 -  apply (rule basis_fun_lemma0, erule f_mono)
   4.249 - apply (rule is_ubI, clarsimp, rename_tac a)
   4.250 - apply (rule below_trans [OF f_mono [OF take_chain]])
   4.251 - apply (rule is_ub_thelub0)
   4.252 -  apply (rule basis_fun_lemma0, erule f_mono)
   4.253 - apply simp
   4.254 -done
   4.255 -
   4.256 -lemma basis_fun_lemma2:
   4.257 -  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   4.258 -  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   4.259 -  shows "f ` rep x <<| (\<Squnion>i. lub (f ` take i ` rep x))"
   4.260 - apply (rule is_lubI)
   4.261 - apply (rule ub_imageI, rename_tac a)
   4.262 -  apply (cut_tac a=a in take_covers, erule exE, rename_tac i)
   4.263 -  apply (erule subst)
   4.264 -  apply (rule rev_below_trans)
   4.265 -   apply (rule_tac x=i in is_ub_thelub)
   4.266 -   apply (rule basis_fun_lemma1, erule f_mono)
   4.267 -  apply (rule is_ub_thelub0)
   4.268 -   apply (rule basis_fun_lemma0, erule f_mono)
   4.269 -  apply simp
   4.270 - apply (rule is_lub_thelub [OF _ ub_rangeI])
   4.271 -  apply (rule basis_fun_lemma1, erule f_mono)
   4.272 - apply (rule is_lub_thelub0)
   4.273 -  apply (rule basis_fun_lemma0, erule f_mono)
   4.274 - apply (rule is_ubI, clarsimp, rename_tac a)
   4.275 - apply (rule below_trans [OF f_mono [OF take_less]])
   4.276 - apply (erule (1) ub_imageD)
   4.277 -done
   4.278 -
   4.279  lemma basis_fun_lemma:
   4.280    fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   4.281    assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   4.282    shows "\<exists>u. f ` rep x <<| u"
   4.283 -by (rule exI, rule basis_fun_lemma2, erule f_mono)
   4.284 +proof -
   4.285 +  obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
   4.286 +  and x: "x = (\<Squnion>i. principal (Y i))"
   4.287 +    by (rule obtain_principal_chain [of x])
   4.288 +  have chain: "chain (\<lambda>i. f (Y i))"
   4.289 +    by (rule chainI, simp add: f_mono Y)
   4.290 +  have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
   4.291 +    by (simp add: x rep_contlub Y rep_principal)
   4.292 +  have "f ` rep x <<| (\<Squnion>n. f (Y n))"
   4.293 +    apply (rule is_lubI)
   4.294 +    apply (rule ub_imageI, rename_tac a)
   4.295 +    apply (clarsimp simp add: rep_x)
   4.296 +    apply (drule f_mono)
   4.297 +    apply (erule below_trans)
   4.298 +    apply (rule is_ub_thelub [OF chain])
   4.299 +    apply (rule is_lub_thelub [OF chain])
   4.300 +    apply (rule ub_rangeI)
   4.301 +    apply (drule_tac x="Y i" in ub_imageD)
   4.302 +    apply (simp add: rep_x, fast intro: r_refl)
   4.303 +    apply assumption
   4.304 +    done
   4.305 +  thus ?thesis ..
   4.306 +qed
   4.307  
   4.308  lemma basis_fun_beta:
   4.309    fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   4.310 @@ -345,13 +402,13 @@
   4.311    show cont: "cont (\<lambda>x. lub (f ` rep x))"
   4.312      apply (rule contI2)
   4.313       apply (rule monofunI)
   4.314 -     apply (rule is_lub_thelub0 [OF lub ub_imageI])
   4.315 -     apply (rule is_ub_thelub0 [OF lub imageI])
   4.316 +     apply (rule is_lub_thelub_ex [OF lub ub_imageI])
   4.317 +     apply (rule is_ub_thelub_ex [OF lub imageI])
   4.318       apply (erule (1) subsetD [OF rep_mono])
   4.319 -    apply (rule is_lub_thelub0 [OF lub ub_imageI])
   4.320 +    apply (rule is_lub_thelub_ex [OF lub ub_imageI])
   4.321      apply (simp add: rep_contlub, clarify)
   4.322      apply (erule rev_below_trans [OF is_ub_thelub])
   4.323 -    apply (erule is_ub_thelub0 [OF lub imageI])
   4.324 +    apply (erule is_ub_thelub_ex [OF lub imageI])
   4.325      done
   4.326  qed
   4.327  
   4.328 @@ -371,113 +428,15 @@
   4.329    shows "basis_fun f \<sqsubseteq> basis_fun g"
   4.330   apply (rule below_cfun_ext)
   4.331   apply (simp only: basis_fun_beta f_mono g_mono)
   4.332 - apply (rule is_lub_thelub0)
   4.333 + apply (rule is_lub_thelub_ex)
   4.334    apply (rule basis_fun_lemma, erule f_mono)
   4.335   apply (rule ub_imageI, rename_tac a)
   4.336   apply (rule below_trans [OF below])
   4.337 - apply (rule is_ub_thelub0)
   4.338 + apply (rule is_ub_thelub_ex)
   4.339    apply (rule basis_fun_lemma, erule g_mono)
   4.340   apply (erule imageI)
   4.341  done
   4.342  
   4.343 -lemma compact_principal [simp]: "compact (principal a)"
   4.344 -by (rule compactI2, simp add: principal_below_iff_mem_rep rep_contlub)
   4.345 -
   4.346 -subsection {* Bifiniteness of ideal completions *}
   4.347 -
   4.348 -definition
   4.349 -  completion_approx :: "nat \<Rightarrow> 'b \<rightarrow> 'b" where
   4.350 -  "completion_approx = (\<lambda>i. basis_fun (\<lambda>a. principal (take i a)))"
   4.351 -
   4.352 -lemma completion_approx_beta:
   4.353 -  "completion_approx i\<cdot>x = (\<Squnion>a\<in>rep x. principal (take i a))"
   4.354 -unfolding completion_approx_def
   4.355 -by (simp add: basis_fun_beta principal_mono take_mono)
   4.356 -
   4.357 -lemma completion_approx_principal:
   4.358 -  "completion_approx i\<cdot>(principal a) = principal (take i a)"
   4.359 -unfolding completion_approx_def
   4.360 -by (simp add: basis_fun_principal principal_mono take_mono)
   4.361 -
   4.362 -lemma chain_completion_approx: "chain completion_approx"
   4.363 -unfolding completion_approx_def
   4.364 -apply (rule chainI)
   4.365 -apply (rule basis_fun_mono)
   4.366 -apply (erule principal_mono [OF take_mono])
   4.367 -apply (erule principal_mono [OF take_mono])
   4.368 -apply (rule principal_mono [OF take_chain])
   4.369 -done
   4.370 -
   4.371 -lemma lub_completion_approx: "(\<Squnion>i. completion_approx i\<cdot>x) = x"
   4.372 -unfolding completion_approx_beta
   4.373 - apply (subst image_image [where f=principal, symmetric])
   4.374 - apply (rule unique_lub [OF _ lub_principal_rep])
   4.375 - apply (rule basis_fun_lemma2, erule principal_mono)
   4.376 -done
   4.377 -
   4.378 -lemma completion_approx_eq_principal:
   4.379 -  "\<exists>a\<in>rep x. completion_approx i\<cdot>x = principal (take i a)"
   4.380 -unfolding completion_approx_beta
   4.381 - apply (subst image_image [where f=principal, symmetric])
   4.382 - apply (subgoal_tac "finite (principal ` take i ` rep x)")
   4.383 -  apply (subgoal_tac "directed (principal ` take i ` rep x)")
   4.384 -   apply (drule (1) lub_finite_directed_in_self, fast)
   4.385 -  apply (subst image_image)
   4.386 -  apply (rule directed_image_ideal)
   4.387 -   apply (rule ideal_rep)
   4.388 -  apply (erule principal_mono [OF take_mono])
   4.389 - apply (rule finite_imageI)
   4.390 - apply (rule finite_take_rep)
   4.391 -done
   4.392 -
   4.393 -lemma completion_approx_idem:
   4.394 -  "completion_approx i\<cdot>(completion_approx i\<cdot>x) = completion_approx i\<cdot>x"
   4.395 -using completion_approx_eq_principal [where i=i and x=x]
   4.396 -by (auto simp add: completion_approx_principal take_take)
   4.397 -
   4.398 -lemma finite_fixes_completion_approx:
   4.399 -  "finite {x. completion_approx i\<cdot>x = x}" (is "finite ?S")
   4.400 -apply (subgoal_tac "?S \<subseteq> principal ` range (take i)")
   4.401 -apply (erule finite_subset)
   4.402 -apply (rule finite_imageI)
   4.403 -apply (rule finite_range_take)
   4.404 -apply (clarify, erule subst)
   4.405 -apply (cut_tac x=x and i=i in completion_approx_eq_principal)
   4.406 -apply fast
   4.407 -done
   4.408 -
   4.409 -lemma principal_induct:
   4.410 -  assumes adm: "adm P"
   4.411 -  assumes P: "\<And>a. P (principal a)"
   4.412 -  shows "P x"
   4.413 - apply (subgoal_tac "P (\<Squnion>i. completion_approx i\<cdot>x)")
   4.414 - apply (simp add: lub_completion_approx)
   4.415 - apply (rule admD [OF adm])
   4.416 -  apply (simp add: chain_completion_approx)
   4.417 - apply (cut_tac x=x and i=i in completion_approx_eq_principal)
   4.418 - apply (clarify, simp add: P)
   4.419 -done
   4.420 -
   4.421 -lemma principal_induct2:
   4.422 -  "\<lbrakk>\<And>y. adm (\<lambda>x. P x y); \<And>x. adm (\<lambda>y. P x y);
   4.423 -    \<And>a b. P (principal a) (principal b)\<rbrakk> \<Longrightarrow> P x y"
   4.424 -apply (rule_tac x=y in spec)
   4.425 -apply (rule_tac x=x in principal_induct, simp)
   4.426 -apply (rule allI, rename_tac y)
   4.427 -apply (rule_tac x=y in principal_induct, simp)
   4.428 -apply simp
   4.429 -done
   4.430 -
   4.431 -lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
   4.432 -apply (drule adm_compact_neq [OF _ cont_id])
   4.433 -apply (drule admD2 [where Y="\<lambda>n. completion_approx n\<cdot>x"])
   4.434 -apply (simp add: chain_completion_approx)
   4.435 -apply (simp add: lub_completion_approx)
   4.436 -apply (erule exE, erule ssubst)
   4.437 -apply (cut_tac i=i and x=x in completion_approx_eq_principal)
   4.438 -apply (clarify, erule exI)
   4.439 -done
   4.440 -
   4.441  end
   4.442  
   4.443  end
     5.1 --- a/src/HOLCF/ConvexPD.thy	Tue Oct 05 17:53:00 2010 -0700
     5.2 +++ b/src/HOLCF/ConvexPD.thy	Wed Oct 06 10:49:27 2010 -0700
     5.3 @@ -116,27 +116,6 @@
     5.4  apply (simp add: 4)
     5.5  done
     5.6  
     5.7 -lemma pd_take_convex_chain:
     5.8 -  "pd_take n t \<le>\<natural> pd_take (Suc n) t"
     5.9 -apply (induct t rule: pd_basis_induct)
    5.10 -apply (simp add: compact_basis.take_chain)
    5.11 -apply (simp add: PDPlus_convex_mono)
    5.12 -done
    5.13 -
    5.14 -lemma pd_take_convex_le: "pd_take i t \<le>\<natural> t"
    5.15 -apply (induct t rule: pd_basis_induct)
    5.16 -apply (simp add: compact_basis.take_less)
    5.17 -apply (simp add: PDPlus_convex_mono)
    5.18 -done
    5.19 -
    5.20 -lemma pd_take_convex_mono:
    5.21 -  "t \<le>\<natural> u \<Longrightarrow> pd_take n t \<le>\<natural> pd_take n u"
    5.22 -apply (erule convex_le_induct)
    5.23 -apply (erule (1) convex_le_trans)
    5.24 -apply (simp add: compact_basis.take_mono)
    5.25 -apply (simp add: PDPlus_convex_mono)
    5.26 -done
    5.27 -
    5.28  
    5.29  subsection {* Type definition *}
    5.30  
    5.31 @@ -144,7 +123,7 @@
    5.32    "{S::'a pd_basis set. convex_le.ideal S}"
    5.33  by (fast intro: convex_le.ideal_principal)
    5.34  
    5.35 -instantiation convex_pd :: (profinite) below
    5.36 +instantiation convex_pd :: (sfp) below
    5.37  begin
    5.38  
    5.39  definition
    5.40 @@ -153,18 +132,18 @@
    5.41  instance ..
    5.42  end
    5.43  
    5.44 -instance convex_pd :: (profinite) po
    5.45 -by (rule convex_le.typedef_ideal_po
    5.46 -    [OF type_definition_convex_pd below_convex_pd_def])
    5.47 +instance convex_pd :: (sfp) po
    5.48 +using type_definition_convex_pd below_convex_pd_def
    5.49 +by (rule convex_le.typedef_ideal_po)
    5.50  
    5.51 -instance convex_pd :: (profinite) cpo
    5.52 -by (rule convex_le.typedef_ideal_cpo
    5.53 -    [OF type_definition_convex_pd below_convex_pd_def])
    5.54 +instance convex_pd :: (sfp) cpo
    5.55 +using type_definition_convex_pd below_convex_pd_def
    5.56 +by (rule convex_le.typedef_ideal_cpo)
    5.57  
    5.58  lemma Rep_convex_pd_lub:
    5.59    "chain Y \<Longrightarrow> Rep_convex_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_convex_pd (Y i))"
    5.60 -by (rule convex_le.typedef_ideal_rep_contlub
    5.61 -    [OF type_definition_convex_pd below_convex_pd_def])
    5.62 +using type_definition_convex_pd below_convex_pd_def
    5.63 +by (rule convex_le.typedef_ideal_rep_contlub)
    5.64  
    5.65  lemma ideal_Rep_convex_pd: "convex_le.ideal (Rep_convex_pd xs)"
    5.66  by (rule Rep_convex_pd [unfolded mem_Collect_eq])
    5.67 @@ -179,18 +158,13 @@
    5.68  by (simp add: Abs_convex_pd_inverse convex_le.ideal_principal)
    5.69  
    5.70  interpretation convex_pd:
    5.71 -  ideal_completion convex_le pd_take convex_principal Rep_convex_pd
    5.72 +  ideal_completion convex_le convex_principal Rep_convex_pd
    5.73  apply unfold_locales
    5.74 -apply (rule pd_take_convex_le)
    5.75 -apply (rule pd_take_idem)
    5.76 -apply (erule pd_take_convex_mono)
    5.77 -apply (rule pd_take_convex_chain)
    5.78 -apply (rule finite_range_pd_take)
    5.79 -apply (rule pd_take_covers)
    5.80  apply (rule ideal_Rep_convex_pd)
    5.81  apply (erule Rep_convex_pd_lub)
    5.82  apply (rule Rep_convex_principal)
    5.83  apply (simp only: below_convex_pd_def)
    5.84 +apply (rule pd_basis_countable)
    5.85  done
    5.86  
    5.87  text {* Convex powerdomain is pointed *}
    5.88 @@ -198,42 +172,12 @@
    5.89  lemma convex_pd_minimal: "convex_principal (PDUnit compact_bot) \<sqsubseteq> ys"
    5.90  by (induct ys rule: convex_pd.principal_induct, simp, simp)
    5.91  
    5.92 -instance convex_pd :: (bifinite) pcpo
    5.93 +instance convex_pd :: (sfp) pcpo
    5.94  by intro_classes (fast intro: convex_pd_minimal)
    5.95  
    5.96  lemma inst_convex_pd_pcpo: "\<bottom> = convex_principal (PDUnit compact_bot)"
    5.97  by (rule convex_pd_minimal [THEN UU_I, symmetric])
    5.98  
    5.99 -text {* Convex powerdomain is profinite *}
   5.100 -
   5.101 -instantiation convex_pd :: (profinite) profinite
   5.102 -begin
   5.103 -
   5.104 -definition
   5.105 -  approx_convex_pd_def: "approx = convex_pd.completion_approx"
   5.106 -
   5.107 -instance
   5.108 -apply (intro_classes, unfold approx_convex_pd_def)
   5.109 -apply (rule convex_pd.chain_completion_approx)
   5.110 -apply (rule convex_pd.lub_completion_approx)
   5.111 -apply (rule convex_pd.completion_approx_idem)
   5.112 -apply (rule convex_pd.finite_fixes_completion_approx)
   5.113 -done
   5.114 -
   5.115 -end
   5.116 -
   5.117 -instance convex_pd :: (bifinite) bifinite ..
   5.118 -
   5.119 -lemma approx_convex_principal [simp]:
   5.120 -  "approx n\<cdot>(convex_principal t) = convex_principal (pd_take n t)"
   5.121 -unfolding approx_convex_pd_def
   5.122 -by (rule convex_pd.completion_approx_principal)
   5.123 -
   5.124 -lemma approx_eq_convex_principal:
   5.125 -  "\<exists>t\<in>Rep_convex_pd xs. approx n\<cdot>xs = convex_principal (pd_take n t)"
   5.126 -unfolding approx_convex_pd_def
   5.127 -by (rule convex_pd.completion_approx_eq_principal)
   5.128 -
   5.129  
   5.130  subsection {* Monadic unit and plus *}
   5.131  
   5.132 @@ -269,16 +213,6 @@
   5.133  by (simp add: convex_pd.basis_fun_principal
   5.134      convex_pd.basis_fun_mono PDPlus_convex_mono)
   5.135  
   5.136 -lemma approx_convex_unit [simp]:
   5.137 -  "approx n\<cdot>{x}\<natural> = {approx n\<cdot>x}\<natural>"
   5.138 -apply (induct x rule: compact_basis.principal_induct, simp)
   5.139 -apply (simp add: approx_Rep_compact_basis)
   5.140 -done
   5.141 -
   5.142 -lemma approx_convex_plus [simp]:
   5.143 -  "approx n\<cdot>(xs +\<natural> ys) = approx n\<cdot>xs +\<natural> approx n\<cdot>ys"
   5.144 -by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
   5.145 -
   5.146  interpretation convex_add: semilattice convex_add proof
   5.147    fix xs ys zs :: "'a convex_pd"
   5.148    show "(xs +\<natural> ys) +\<natural> zs = xs +\<natural> (ys +\<natural> zs)"
   5.149 @@ -336,14 +270,20 @@
   5.150  unfolding po_eq_conv by simp
   5.151  
   5.152  lemma convex_unit_strict [simp]: "{\<bottom>}\<natural> = \<bottom>"
   5.153 -unfolding inst_convex_pd_pcpo Rep_compact_bot [symmetric] by simp
   5.154 +using convex_unit_Rep_compact_basis [of compact_bot]
   5.155 +by (simp add: inst_convex_pd_pcpo)
   5.156  
   5.157  lemma convex_unit_strict_iff [simp]: "{x}\<natural> = \<bottom> \<longleftrightarrow> x = \<bottom>"
   5.158  unfolding convex_unit_strict [symmetric] by (rule convex_unit_eq_iff)
   5.159  
   5.160 -lemma compact_convex_unit_iff [simp]:
   5.161 -  "compact {x}\<natural> \<longleftrightarrow> compact x"
   5.162 -unfolding profinite_compact_iff by simp
   5.163 +lemma compact_convex_unit: "compact x \<Longrightarrow> compact {x}\<natural>"
   5.164 +by (auto dest!: compact_basis.compact_imp_principal)
   5.165 +
   5.166 +lemma compact_convex_unit_iff [simp]: "compact {x}\<natural> \<longleftrightarrow> compact x"
   5.167 +apply (safe elim!: compact_convex_unit)
   5.168 +apply (simp only: compact_def convex_unit_below_iff [symmetric])
   5.169 +apply (erule adm_subst [OF cont_Rep_CFun2])
   5.170 +done
   5.171  
   5.172  lemma compact_convex_plus [simp]:
   5.173    "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<natural> ys)"
   5.174 @@ -441,32 +381,20 @@
   5.175  unfolding convex_unit_strict [symmetric] by (rule convex_bind_unit)
   5.176  
   5.177  
   5.178 -subsection {* Map and join *}
   5.179 +subsection {* Map *}
   5.180  
   5.181  definition
   5.182    convex_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a convex_pd \<rightarrow> 'b convex_pd" where
   5.183    "convex_map = (\<Lambda> f xs. convex_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<natural>))"
   5.184  
   5.185 -definition
   5.186 -  convex_join :: "'a convex_pd convex_pd \<rightarrow> 'a convex_pd" where
   5.187 -  "convex_join = (\<Lambda> xss. convex_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
   5.188 -
   5.189  lemma convex_map_unit [simp]:
   5.190 -  "convex_map\<cdot>f\<cdot>(convex_unit\<cdot>x) = convex_unit\<cdot>(f\<cdot>x)"
   5.191 +  "convex_map\<cdot>f\<cdot>{x}\<natural> = {f\<cdot>x}\<natural>"
   5.192  unfolding convex_map_def by simp
   5.193  
   5.194  lemma convex_map_plus [simp]:
   5.195    "convex_map\<cdot>f\<cdot>(xs +\<natural> ys) = convex_map\<cdot>f\<cdot>xs +\<natural> convex_map\<cdot>f\<cdot>ys"
   5.196  unfolding convex_map_def by simp
   5.197  
   5.198 -lemma convex_join_unit [simp]:
   5.199 -  "convex_join\<cdot>{xs}\<natural> = xs"
   5.200 -unfolding convex_join_def by simp
   5.201 -
   5.202 -lemma convex_join_plus [simp]:
   5.203 -  "convex_join\<cdot>(xss +\<natural> yss) = convex_join\<cdot>xss +\<natural> convex_join\<cdot>yss"
   5.204 -unfolding convex_join_def by simp
   5.205 -
   5.206  lemma convex_map_ident: "convex_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
   5.207  by (induct xs rule: convex_pd_induct, simp_all)
   5.208  
   5.209 @@ -477,6 +405,137 @@
   5.210    "convex_map\<cdot>f\<cdot>(convex_map\<cdot>g\<cdot>xs) = convex_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
   5.211  by (induct xs rule: convex_pd_induct, simp_all)
   5.212  
   5.213 +lemma ep_pair_convex_map: "ep_pair e p \<Longrightarrow> ep_pair (convex_map\<cdot>e) (convex_map\<cdot>p)"
   5.214 +apply default
   5.215 +apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse)
   5.216 +apply (induct_tac y rule: convex_pd_induct)
   5.217 +apply (simp_all add: ep_pair.e_p_below monofun_cfun)
   5.218 +done
   5.219 +
   5.220 +lemma deflation_convex_map: "deflation d \<Longrightarrow> deflation (convex_map\<cdot>d)"
   5.221 +apply default
   5.222 +apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem)
   5.223 +apply (induct_tac x rule: convex_pd_induct)
   5.224 +apply (simp_all add: deflation.below monofun_cfun)
   5.225 +done
   5.226 +
   5.227 +(* FIXME: long proof! *)
   5.228 +lemma finite_deflation_convex_map:
   5.229 +  assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
   5.230 +proof (rule finite_deflation_intro)
   5.231 +  interpret d: finite_deflation d by fact
   5.232 +  have "deflation d" by fact
   5.233 +  thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
   5.234 +  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
   5.235 +  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
   5.236 +    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
   5.237 +  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
   5.238 +  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
   5.239 +    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
   5.240 +  hence *: "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
   5.241 +  hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
   5.242 +    apply (rule rev_finite_subset)
   5.243 +    apply clarsimp
   5.244 +    apply (induct_tac xs rule: convex_pd.principal_induct)
   5.245 +    apply (simp add: adm_mem_finite *)
   5.246 +    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
   5.247 +    apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
   5.248 +    apply simp
   5.249 +    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
   5.250 +    apply clarsimp
   5.251 +    apply (rule imageI)
   5.252 +    apply (rule vimageI2)
   5.253 +    apply (simp add: Rep_PDUnit)
   5.254 +    apply (rule range_eqI)
   5.255 +    apply (erule sym)
   5.256 +    apply (rule exI)
   5.257 +    apply (rule Abs_compact_basis_inverse [symmetric])
   5.258 +    apply (simp add: d.compact)
   5.259 +    apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
   5.260 +    apply clarsimp
   5.261 +    apply (rule imageI)
   5.262 +    apply (rule vimageI2)
   5.263 +    apply (simp add: Rep_PDPlus)
   5.264 +    done
   5.265 +  thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
   5.266 +    by (rule finite_range_imp_finite_fixes)
   5.267 +qed
   5.268 +
   5.269 +subsection {* Convex powerdomain is an SFP domain *}
   5.270 +
   5.271 +definition
   5.272 +  convex_approx :: "nat \<Rightarrow> udom convex_pd \<rightarrow> udom convex_pd"
   5.273 +where
   5.274 +  "convex_approx = (\<lambda>i. convex_map\<cdot>(udom_approx i))"
   5.275 +
   5.276 +lemma convex_approx: "approx_chain convex_approx"
   5.277 +proof (rule approx_chain.intro)
   5.278 +  show "chain (\<lambda>i. convex_approx i)"
   5.279 +    unfolding convex_approx_def by simp
   5.280 +  show "(\<Squnion>i. convex_approx i) = ID"
   5.281 +    unfolding convex_approx_def
   5.282 +    by (simp add: lub_distribs convex_map_ID)
   5.283 +  show "\<And>i. finite_deflation (convex_approx i)"
   5.284 +    unfolding convex_approx_def
   5.285 +    by (intro finite_deflation_convex_map finite_deflation_udom_approx)
   5.286 +qed
   5.287 +
   5.288 +definition convex_sfp :: "sfp \<rightarrow> sfp"
   5.289 +where "convex_sfp = sfp_fun1 convex_approx convex_map"
   5.290 +
   5.291 +lemma cast_convex_sfp:
   5.292 +  "cast\<cdot>(convex_sfp\<cdot>A) =
   5.293 +    udom_emb convex_approx oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj convex_approx"
   5.294 +unfolding convex_sfp_def
   5.295 +apply (rule cast_sfp_fun1 [OF convex_approx])
   5.296 +apply (erule finite_deflation_convex_map)
   5.297 +done
   5.298 +
   5.299 +instantiation convex_pd :: (sfp) sfp
   5.300 +begin
   5.301 +
   5.302 +definition
   5.303 +  "emb = udom_emb convex_approx oo convex_map\<cdot>emb"
   5.304 +
   5.305 +definition
   5.306 +  "prj = convex_map\<cdot>prj oo udom_prj convex_approx"
   5.307 +
   5.308 +definition
   5.309 +  "sfp (t::'a convex_pd itself) = convex_sfp\<cdot>SFP('a)"
   5.310 +
   5.311 +instance proof
   5.312 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a convex_pd)"
   5.313 +    unfolding emb_convex_pd_def prj_convex_pd_def
   5.314 +    using ep_pair_udom [OF convex_approx]
   5.315 +    by (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj)
   5.316 +next
   5.317 +  show "cast\<cdot>SFP('a convex_pd) = emb oo (prj :: udom \<rightarrow> 'a convex_pd)"
   5.318 +    unfolding emb_convex_pd_def prj_convex_pd_def sfp_convex_pd_def cast_convex_sfp
   5.319 +    by (simp add: cast_SFP oo_def expand_cfun_eq convex_map_map)
   5.320 +qed
   5.321 +
   5.322 +end
   5.323 +
   5.324 +text {* SFP of type constructor = type combinator *}
   5.325 +
   5.326 +lemma SFP_convex: "SFP('a convex_pd) = convex_sfp\<cdot>SFP('a)"
   5.327 +by (rule sfp_convex_pd_def)
   5.328 +
   5.329 +
   5.330 +subsection {* Join *}
   5.331 +
   5.332 +definition
   5.333 +  convex_join :: "'a convex_pd convex_pd \<rightarrow> 'a convex_pd" where
   5.334 +  "convex_join = (\<Lambda> xss. convex_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
   5.335 +
   5.336 +lemma convex_join_unit [simp]:
   5.337 +  "convex_join\<cdot>{xs}\<natural> = xs"
   5.338 +unfolding convex_join_def by simp
   5.339 +
   5.340 +lemma convex_join_plus [simp]:
   5.341 +  "convex_join\<cdot>(xss +\<natural> yss) = convex_join\<cdot>xss +\<natural> convex_join\<cdot>yss"
   5.342 +unfolding convex_join_def by simp
   5.343 +
   5.344  lemma convex_join_map_unit:
   5.345    "convex_join\<cdot>(convex_map\<cdot>convex_unit\<cdot>xs) = xs"
   5.346  by (induct xs rule: convex_pd_induct, simp_all)
   5.347 @@ -490,24 +549,6 @@
   5.348     convex_map\<cdot>f\<cdot>(convex_join\<cdot>xss)"
   5.349  by (induct xss rule: convex_pd_induct, simp_all)
   5.350  
   5.351 -lemma convex_map_approx: "convex_map\<cdot>(approx n)\<cdot>xs = approx n\<cdot>xs"
   5.352 -by (induct xs rule: convex_pd_induct, simp_all)
   5.353 -
   5.354 -lemma ep_pair_convex_map:
   5.355 -  "ep_pair e p \<Longrightarrow> ep_pair (convex_map\<cdot>e) (convex_map\<cdot>p)"
   5.356 -apply default
   5.357 -apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse)
   5.358 -apply (induct_tac y rule: convex_pd_induct)
   5.359 -apply (simp_all add: ep_pair.e_p_below monofun_cfun)
   5.360 -done
   5.361 -
   5.362 -lemma deflation_convex_map: "deflation d \<Longrightarrow> deflation (convex_map\<cdot>d)"
   5.363 -apply default
   5.364 -apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem)
   5.365 -apply (induct_tac x rule: convex_pd_induct)
   5.366 -apply (simp_all add: deflation.below monofun_cfun)
   5.367 -done
   5.368 -
   5.369  
   5.370  subsection {* Conversions to other powerdomains *}
   5.371  
   5.372 @@ -536,10 +577,6 @@
   5.373    "convex_to_upper\<cdot>(xs +\<natural> ys) = convex_to_upper\<cdot>xs +\<sharp> convex_to_upper\<cdot>ys"
   5.374  by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
   5.375  
   5.376 -lemma approx_convex_to_upper:
   5.377 -  "approx i\<cdot>(convex_to_upper\<cdot>xs) = convex_to_upper\<cdot>(approx i\<cdot>xs)"
   5.378 -by (induct xs rule: convex_pd_induct, simp, simp, simp)
   5.379 -
   5.380  lemma convex_to_upper_bind [simp]:
   5.381    "convex_to_upper\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
   5.382      upper_bind\<cdot>(convex_to_upper\<cdot>xs)\<cdot>(convex_to_upper oo f)"
   5.383 @@ -579,10 +616,6 @@
   5.384    "convex_to_lower\<cdot>(xs +\<natural> ys) = convex_to_lower\<cdot>xs +\<flat> convex_to_lower\<cdot>ys"
   5.385  by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
   5.386  
   5.387 -lemma approx_convex_to_lower:
   5.388 -  "approx i\<cdot>(convex_to_lower\<cdot>xs) = convex_to_lower\<cdot>(approx i\<cdot>xs)"
   5.389 -by (induct xs rule: convex_pd_induct, simp, simp, simp)
   5.390 -
   5.391  lemma convex_to_lower_bind [simp]:
   5.392    "convex_to_lower\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
   5.393      lower_bind\<cdot>(convex_to_lower\<cdot>xs)\<cdot>(convex_to_lower oo f)"
     6.1 --- a/src/HOLCF/Cprod.thy	Tue Oct 05 17:53:00 2010 -0700
     6.2 +++ b/src/HOLCF/Cprod.thy	Wed Oct 06 10:49:27 2010 -0700
     6.3 @@ -5,7 +5,7 @@
     6.4  header {* The cpo of cartesian products *}
     6.5  
     6.6  theory Cprod
     6.7 -imports Bifinite
     6.8 +imports Algebraic
     6.9  begin
    6.10  
    6.11  default_sort cpo
    6.12 @@ -40,4 +40,62 @@
    6.13  lemma csplit_Pair [simp]: "csplit\<cdot>f\<cdot>(x, y) = f\<cdot>x\<cdot>y"
    6.14  by (simp add: csplit_def)
    6.15  
    6.16 +subsection {* Cartesian product is an SFP domain *}
    6.17 +
    6.18 +definition
    6.19 +  prod_approx :: "nat \<Rightarrow> udom \<times> udom \<rightarrow> udom \<times> udom"
    6.20 +where
    6.21 +  "prod_approx = (\<lambda>i. cprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
    6.22 +
    6.23 +lemma prod_approx: "approx_chain prod_approx"
    6.24 +proof (rule approx_chain.intro)
    6.25 +  show "chain (\<lambda>i. prod_approx i)"
    6.26 +    unfolding prod_approx_def by simp
    6.27 +  show "(\<Squnion>i. prod_approx i) = ID"
    6.28 +    unfolding prod_approx_def
    6.29 +    by (simp add: lub_distribs cprod_map_ID)
    6.30 +  show "\<And>i. finite_deflation (prod_approx i)"
    6.31 +    unfolding prod_approx_def
    6.32 +    by (intro finite_deflation_cprod_map finite_deflation_udom_approx)
    6.33 +qed
    6.34 +
    6.35 +definition prod_sfp :: "sfp \<rightarrow> sfp \<rightarrow> sfp"
    6.36 +where "prod_sfp = sfp_fun2 prod_approx cprod_map"
    6.37 +
    6.38 +lemma cast_prod_sfp:
    6.39 +  "cast\<cdot>(prod_sfp\<cdot>A\<cdot>B) = udom_emb prod_approx oo
    6.40 +    cprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj prod_approx"
    6.41 +unfolding prod_sfp_def
    6.42 +apply (rule cast_sfp_fun2 [OF prod_approx])
    6.43 +apply (erule (1) finite_deflation_cprod_map)
    6.44 +done
    6.45 +
    6.46 +instantiation prod :: (sfp, sfp) sfp
    6.47 +begin
    6.48 +
    6.49 +definition
    6.50 +  "emb = udom_emb prod_approx oo cprod_map\<cdot>emb\<cdot>emb"
    6.51 +
    6.52 +definition
    6.53 +  "prj = cprod_map\<cdot>prj\<cdot>prj oo udom_prj prod_approx"
    6.54 +
    6.55 +definition
    6.56 +  "sfp (t::('a \<times> 'b) itself) = prod_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
    6.57 +
    6.58 +instance proof
    6.59 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<times> 'b)"
    6.60 +    unfolding emb_prod_def prj_prod_def
    6.61 +    using ep_pair_udom [OF prod_approx]
    6.62 +    by (intro ep_pair_comp ep_pair_cprod_map ep_pair_emb_prj)
    6.63 +next
    6.64 +  show "cast\<cdot>SFP('a \<times> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<times> 'b)"
    6.65 +    unfolding emb_prod_def prj_prod_def sfp_prod_def cast_prod_sfp
    6.66 +    by (simp add: cast_SFP oo_def expand_cfun_eq cprod_map_map)
    6.67 +qed
    6.68 +
    6.69  end
    6.70 +
    6.71 +lemma SFP_prod: "SFP('a::sfp \<times> 'b::sfp) = prod_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
    6.72 +by (rule sfp_prod_def)
    6.73 +
    6.74 +end
     7.1 --- a/src/HOLCF/Eventual.thy	Tue Oct 05 17:53:00 2010 -0700
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,153 +0,0 @@
     7.4 -(*  Title:      HOLCF/Eventual.thy
     7.5 -    Author:     Brian Huffman
     7.6 -*)
     7.7 -
     7.8 -header {* Eventually-constant sequences *}
     7.9 -
    7.10 -theory Eventual
    7.11 -imports Infinite_Set
    7.12 -begin
    7.13 -
    7.14 -subsection {* Lemmas about MOST *}
    7.15 -
    7.16 -lemma MOST_INFM:
    7.17 -  assumes inf: "infinite (UNIV::'a set)"
    7.18 -  shows "MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
    7.19 -  unfolding Alm_all_def Inf_many_def
    7.20 -  apply (auto simp add: Collect_neg_eq)
    7.21 -  apply (drule (1) finite_UnI)
    7.22 -  apply (simp add: Compl_partition2 inf)
    7.23 -  done
    7.24 -
    7.25 -lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
    7.26 -by (rule MOST_inj [OF _ inj_Suc])
    7.27 -
    7.28 -lemma MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
    7.29 -unfolding MOST_nat
    7.30 -apply (clarify, rule_tac x="Suc m" in exI, clarify)
    7.31 -apply (erule Suc_lessE, simp)
    7.32 -done
    7.33 -
    7.34 -lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
    7.35 -by (rule iffI [OF MOST_SucD MOST_SucI])
    7.36 -
    7.37 -lemma INFM_finite_Bex_distrib:
    7.38 -  "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)"
    7.39 -by (induct set: finite, simp, simp add: INFM_disj_distrib)
    7.40 -
    7.41 -lemma MOST_finite_Ball_distrib:
    7.42 -  "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)"
    7.43 -by (induct set: finite, simp, simp add: MOST_conj_distrib)
    7.44 -
    7.45 -lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
    7.46 -unfolding MOST_nat_le by fast
    7.47 -
    7.48 -subsection {* Eventually constant sequences *}
    7.49 -
    7.50 -definition
    7.51 -  eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
    7.52 -where
    7.53 -  "eventually_constant S = (\<exists>x. MOST i. S i = x)"
    7.54 -
    7.55 -lemma eventually_constant_MOST_MOST:
    7.56 -  "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
    7.57 -unfolding eventually_constant_def MOST_nat
    7.58 -apply safe
    7.59 -apply (rule_tac x=m in exI, clarify)
    7.60 -apply (rule_tac x=m in exI, clarify)
    7.61 -apply simp
    7.62 -apply fast
    7.63 -done
    7.64 -
    7.65 -lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
    7.66 -unfolding eventually_constant_def by fast
    7.67 -
    7.68 -lemma eventually_constant_comp:
    7.69 -  "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
    7.70 -unfolding eventually_constant_def
    7.71 -apply (erule exE, rule_tac x="f x" in exI)
    7.72 -apply (erule MOST_mono, simp)
    7.73 -done
    7.74 -
    7.75 -lemma eventually_constant_Suc_iff:
    7.76 -  "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
    7.77 -unfolding eventually_constant_def
    7.78 -by (subst MOST_Suc_iff, rule refl)
    7.79 -
    7.80 -lemma eventually_constant_SucD:
    7.81 -  "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
    7.82 -by (rule eventually_constant_Suc_iff [THEN iffD1])
    7.83 -
    7.84 -subsection {* Limits of eventually constant sequences *}
    7.85 -
    7.86 -definition
    7.87 -  eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
    7.88 -  "eventual S = (THE x. MOST i. S i = x)"
    7.89 -
    7.90 -lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
    7.91 -unfolding eventual_def
    7.92 -apply (rule the_equality, assumption)
    7.93 -apply (rename_tac y)
    7.94 -apply (subgoal_tac "MOST i::nat. y = x", simp)
    7.95 -apply (erule MOST_rev_mp)
    7.96 -apply (erule MOST_rev_mp)
    7.97 -apply simp
    7.98 -done
    7.99 -
   7.100 -lemma MOST_eq_eventual:
   7.101 -  "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
   7.102 -unfolding eventually_constant_def
   7.103 -by (erule exE, simp add: eventual_eqI)
   7.104 -
   7.105 -lemma eventual_mem_range:
   7.106 -  "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
   7.107 -apply (drule MOST_eq_eventual)
   7.108 -apply (simp only: MOST_nat_le, clarify)
   7.109 -apply (drule spec, drule mp, rule order_refl)
   7.110 -apply (erule range_eqI [OF sym])
   7.111 -done
   7.112 -
   7.113 -lemma eventually_constant_MOST_iff:
   7.114 -  assumes S: "eventually_constant S"
   7.115 -  shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
   7.116 -apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
   7.117 -apply simp
   7.118 -apply (rule iffI)
   7.119 -apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
   7.120 -apply (erule MOST_mono, force)
   7.121 -apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
   7.122 -apply (erule MOST_mono, simp)
   7.123 -done
   7.124 -
   7.125 -lemma MOST_eventual:
   7.126 -  "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
   7.127 -proof -
   7.128 -  assume "eventually_constant S"
   7.129 -  hence "MOST n. S n = eventual S"
   7.130 -    by (rule MOST_eq_eventual)
   7.131 -  moreover assume "MOST n. P (S n)"
   7.132 -  ultimately have "MOST n. S n = eventual S \<and> P (S n)"
   7.133 -    by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
   7.134 -  hence "MOST n::nat. P (eventual S)"
   7.135 -    by (rule MOST_mono) auto
   7.136 -  thus ?thesis by simp
   7.137 -qed
   7.138 -
   7.139 -lemma eventually_constant_MOST_Suc_eq:
   7.140 -  "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
   7.141 -apply (drule MOST_eq_eventual)
   7.142 -apply (frule MOST_Suc_iff [THEN iffD2])
   7.143 -apply (erule MOST_rev_mp)
   7.144 -apply (erule MOST_rev_mp)
   7.145 -apply simp
   7.146 -done
   7.147 -
   7.148 -lemma eventual_comp:
   7.149 -  "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
   7.150 -apply (rule eventual_eqI)
   7.151 -apply (rule MOST_mono)
   7.152 -apply (erule MOST_eq_eventual)
   7.153 -apply simp
   7.154 -done
   7.155 -
   7.156 -end
     8.1 --- a/src/HOLCF/HOLCF.thy	Tue Oct 05 17:53:00 2010 -0700
     8.2 +++ b/src/HOLCF/HOLCF.thy	Wed Oct 06 10:49:27 2010 -0700
     8.3 @@ -45,8 +45,6 @@
     8.4  lemmas expand_cfun_less = expand_cfun_below
     8.5  lemmas less_cfun_ext = below_cfun_ext
     8.6  lemmas injection_less = injection_below
     8.7 -lemmas approx_less = approx_below
     8.8 -lemmas profinite_less_ext = profinite_below_ext
     8.9  lemmas less_up_def = below_up_def
    8.10  lemmas not_Iup_less = not_Iup_below
    8.11  lemmas Iup_less = Iup_below
     9.1 --- a/src/HOLCF/IsaMakefile	Tue Oct 05 17:53:00 2010 -0700
     9.2 +++ b/src/HOLCF/IsaMakefile	Wed Oct 06 10:49:27 2010 -0700
     9.3 @@ -48,7 +48,6 @@
     9.4    Deflation.thy \
     9.5    Domain.thy \
     9.6    Domain_Aux.thy \
     9.7 -  Eventual.thy \
     9.8    Ffun.thy \
     9.9    Fixrec.thy \
    9.10    Fix.thy \
    10.1 --- a/src/HOLCF/Library/Strict_Fun.thy	Tue Oct 05 17:53:00 2010 -0700
    10.2 +++ b/src/HOLCF/Library/Strict_Fun.thy	Wed Oct 06 10:49:27 2010 -0700
    10.3 @@ -1,4 +1,4 @@
    10.4 -(*  Title:      HOLCF/ex/Strict_Fun.thy
    10.5 +(*  Title:      HOLCF/Library/Strict_Fun.thy
    10.6      Author:     Brian Huffman
    10.7  *)
    10.8  
    10.9 @@ -143,96 +143,78 @@
   10.10           deflation_strict `deflation d1` `deflation d2`)
   10.11  qed
   10.12  
   10.13 -subsection {* Strict function space is bifinite *}
   10.14 +subsection {* Strict function space is an SFP domain *}
   10.15 +
   10.16 +definition
   10.17 +  sfun_approx :: "nat \<Rightarrow> (udom \<rightarrow>! udom) \<rightarrow> (udom \<rightarrow>! udom)"
   10.18 +where
   10.19 +  "sfun_approx = (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
   10.20  
   10.21 -instantiation sfun :: (bifinite, bifinite) bifinite
   10.22 +lemma sfun_approx: "approx_chain sfun_approx"
   10.23 +proof (rule approx_chain.intro)
   10.24 +  show "chain (\<lambda>i. sfun_approx i)"
   10.25 +    unfolding sfun_approx_def by simp
   10.26 +  show "(\<Squnion>i. sfun_approx i) = ID"
   10.27 +    unfolding sfun_approx_def
   10.28 +    by (simp add: lub_distribs sfun_map_ID)
   10.29 +  show "\<And>i. finite_deflation (sfun_approx i)"
   10.30 +    unfolding sfun_approx_def
   10.31 +    by (intro finite_deflation_sfun_map finite_deflation_udom_approx)
   10.32 +qed
   10.33 +
   10.34 +definition sfun_sfp :: "sfp \<rightarrow> sfp \<rightarrow> sfp"
   10.35 +where "sfun_sfp = sfp_fun2 sfun_approx sfun_map"
   10.36 +
   10.37 +lemma cast_sfun_sfp:
   10.38 +  "cast\<cdot>(sfun_sfp\<cdot>A\<cdot>B) =
   10.39 +    udom_emb sfun_approx oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj sfun_approx"
   10.40 +unfolding sfun_sfp_def
   10.41 +apply (rule cast_sfp_fun2 [OF sfun_approx])
   10.42 +apply (erule (1) finite_deflation_sfun_map)
   10.43 +done
   10.44 +
   10.45 +instantiation sfun :: (sfp, sfp) sfp
   10.46  begin
   10.47  
   10.48  definition
   10.49 -  "approx = (\<lambda>i. sfun_map\<cdot>(approx i)\<cdot>(approx i))"
   10.50 +  "emb = udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb"
   10.51 +
   10.52 +definition
   10.53 +  "prj = sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx"
   10.54 +
   10.55 +definition
   10.56 +  "sfp (t::('a \<rightarrow>! 'b) itself) = sfun_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
   10.57  
   10.58  instance proof
   10.59 -  show "chain (approx :: nat \<Rightarrow> ('a \<rightarrow>! 'b) \<rightarrow> ('a \<rightarrow>! 'b))"
   10.60 -    unfolding approx_sfun_def by simp
   10.61 -next
   10.62 -  fix x :: "'a \<rightarrow>! 'b"
   10.63 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   10.64 -    unfolding approx_sfun_def
   10.65 -    by (simp add: lub_distribs sfun_map_ID [unfolded ID_def])
   10.66 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
   10.67 +    unfolding emb_sfun_def prj_sfun_def
   10.68 +    using ep_pair_udom [OF sfun_approx]
   10.69 +    by (intro ep_pair_comp ep_pair_sfun_map ep_pair_emb_prj)
   10.70  next
   10.71 -  fix i :: nat and x :: "'a \<rightarrow>! 'b"
   10.72 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   10.73 -    unfolding approx_sfun_def
   10.74 -    by (intro deflation.idem deflation_sfun_map deflation_approx)
   10.75 -next
   10.76 -  fix i :: nat
   10.77 -  show "finite {x::'a \<rightarrow>! 'b. approx i\<cdot>x = x}"
   10.78 -    unfolding approx_sfun_def
   10.79 -    by (intro finite_deflation.finite_fixes
   10.80 -              finite_deflation_sfun_map
   10.81 -              finite_deflation_approx)
   10.82 +  show "cast\<cdot>SFP('a \<rightarrow>! 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
   10.83 +    unfolding emb_sfun_def prj_sfun_def sfp_sfun_def cast_sfun_sfp
   10.84 +    by (simp add: cast_SFP oo_def expand_cfun_eq sfun_map_map)
   10.85  qed
   10.86  
   10.87  end
   10.88  
   10.89 -subsection {* Strict function space is representable *}
   10.90 -
   10.91 -instantiation sfun :: (rep, rep) rep
   10.92 -begin
   10.93 -
   10.94 -definition
   10.95 -  "emb = udom_emb oo sfun_map\<cdot>prj\<cdot>emb"
   10.96 -
   10.97 -definition
   10.98 -  "prj = sfun_map\<cdot>emb\<cdot>prj oo udom_prj"
   10.99 -
  10.100 -instance
  10.101 -apply (default, unfold emb_sfun_def prj_sfun_def)
  10.102 -apply (rule ep_pair_comp)
  10.103 -apply (rule ep_pair_sfun_map)
  10.104 -apply (rule ep_pair_emb_prj)
  10.105 -apply (rule ep_pair_emb_prj)
  10.106 -apply (rule ep_pair_udom)
  10.107 -done
  10.108 -
  10.109 -end
  10.110 +text {* SFP of type constructor = type combinator *}
  10.111  
  10.112 -text {*
  10.113 -  A deflation constructor lets us configure the domain package to work
  10.114 -  with the strict function space type constructor.
  10.115 -*}
  10.116 -
  10.117 -definition
  10.118 -  sfun_defl :: "TypeRep \<rightarrow> TypeRep \<rightarrow> TypeRep"
  10.119 -where
  10.120 -  "sfun_defl = TypeRep_fun2 sfun_map"
  10.121 -
  10.122 -lemma cast_sfun_defl:
  10.123 -  "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) = udom_emb oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
  10.124 -unfolding sfun_defl_def
  10.125 -apply (rule cast_TypeRep_fun2)
  10.126 -apply (erule (1) finite_deflation_sfun_map)
  10.127 -done
  10.128 -
  10.129 -lemma REP_sfun: "REP('a::rep \<rightarrow>! 'b::rep) = sfun_defl\<cdot>REP('a)\<cdot>REP('b)"
  10.130 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  10.131 -apply (simp add: cast_REP cast_sfun_defl)
  10.132 -apply (simp only: prj_sfun_def emb_sfun_def)
  10.133 -apply (simp add: sfun_map_def cfun_map_def strictify_cancel)
  10.134 -done
  10.135 +lemma SFP_sfun: "SFP('a::sfp \<rightarrow>! 'b::sfp) = sfun_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
  10.136 +by (rule sfp_sfun_def)
  10.137  
  10.138  lemma isodefl_sfun:
  10.139    "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  10.140 -    isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
  10.141 +    isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_sfp\<cdot>t1\<cdot>t2)"
  10.142  apply (rule isodeflI)
  10.143 -apply (simp add: cast_sfun_defl cast_isodefl)
  10.144 +apply (simp add: cast_sfun_sfp cast_isodefl)
  10.145  apply (simp add: emb_sfun_def prj_sfun_def)
  10.146  apply (simp add: sfun_map_map deflation_strict [OF isodefl_imp_deflation])
  10.147  done
  10.148  
  10.149  setup {*
  10.150    Domain_Isomorphism.add_type_constructor
  10.151 -    (@{type_name "sfun"}, @{term sfun_defl}, @{const_name sfun_map}, @{thm REP_sfun},
  10.152 +    (@{type_name "sfun"}, @{term sfun_sfp}, @{const_name sfun_map}, @{thm SFP_sfun},
  10.153         @{thm isodefl_sfun}, @{thm sfun_map_ID}, @{thm deflation_sfun_map})
  10.154  *}
  10.155  
    11.1 --- a/src/HOLCF/Library/Sum_Cpo.thy	Tue Oct 05 17:53:00 2010 -0700
    11.2 +++ b/src/HOLCF/Library/Sum_Cpo.thy	Wed Oct 06 10:49:27 2010 -0700
    11.3 @@ -5,7 +5,7 @@
    11.4  header {* The cpo of disjoint sums *}
    11.5  
    11.6  theory Sum_Cpo
    11.7 -imports Bifinite
    11.8 +imports HOLCF
    11.9  begin
   11.10  
   11.11  subsection {* Ordering on sum type *}
   11.12 @@ -218,38 +218,4 @@
   11.13  instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
   11.14  by intro_classes (simp add: below_sum_def split: sum.split)
   11.15  
   11.16 -subsection {* Sum type is a bifinite domain *}
   11.17 -
   11.18 -instantiation sum :: (profinite, profinite) profinite
   11.19 -begin
   11.20 -
   11.21 -definition
   11.22 -  approx_sum_def: "approx =
   11.23 -    (\<lambda>n. \<Lambda> x. case x of Inl a \<Rightarrow> Inl (approx n\<cdot>a) | Inr b \<Rightarrow> Inr (approx n\<cdot>b))"
   11.24 -
   11.25 -lemma approx_Inl [simp]: "approx n\<cdot>(Inl x) = Inl (approx n\<cdot>x)"
   11.26 -  unfolding approx_sum_def by simp
   11.27 -
   11.28 -lemma approx_Inr [simp]: "approx n\<cdot>(Inr x) = Inr (approx n\<cdot>x)"
   11.29 -  unfolding approx_sum_def by simp
   11.30 -
   11.31 -instance proof
   11.32 -  fix i :: nat and x :: "'a + 'b"
   11.33 -  show "chain (approx :: nat \<Rightarrow> 'a + 'b \<rightarrow> 'a + 'b)"
   11.34 -    unfolding approx_sum_def
   11.35 -    by (rule ch2ch_LAM, case_tac x, simp_all)
   11.36 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   11.37 -    by (induct x, simp_all add: lub_Inl lub_Inr)
   11.38 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   11.39 -    by (induct x, simp_all)
   11.40 -  have "{x::'a + 'b. approx i\<cdot>x = x} \<subseteq>
   11.41 -        {x::'a. approx i\<cdot>x = x} <+> {x::'b. approx i\<cdot>x = x}"
   11.42 -    by (rule subsetI, case_tac x, simp_all add: InlI InrI)
   11.43 -  thus "finite {x::'a + 'b. approx i\<cdot>x = x}"
   11.44 -    by (rule finite_subset,
   11.45 -        intro finite_Plus finite_fixes_approx)
   11.46 -qed
   11.47 -
   11.48  end
   11.49 -
   11.50 -end
    12.1 --- a/src/HOLCF/Lift.thy	Tue Oct 05 17:53:00 2010 -0700
    12.2 +++ b/src/HOLCF/Lift.thy	Wed Oct 06 10:49:27 2010 -0700
    12.3 @@ -171,51 +171,89 @@
    12.4  by (cases x, simp_all)
    12.5  
    12.6  
    12.7 -subsection {* Lifted countable types are bifinite *}
    12.8 -
    12.9 -instantiation lift :: (countable) bifinite
   12.10 -begin
   12.11 +subsection {* Lifted countable types are SFP domains *}
   12.12  
   12.13  definition
   12.14 -  approx_lift_def:
   12.15 -    "approx = (\<lambda>n. FLIFT x. if to_nat x < n then Def x else \<bottom>)"
   12.16 +  lift_approx :: "nat \<Rightarrow> 'a::countable lift \<rightarrow> 'a lift"
   12.17 +where
   12.18 +  "lift_approx = (\<lambda>i. FLIFT x. if to_nat x < i then Def x else \<bottom>)"
   12.19 +
   12.20 +lemma chain_lift_approx [simp]: "chain lift_approx"
   12.21 +  unfolding lift_approx_def
   12.22 +  by (rule chainI, simp add: FLIFT_mono)
   12.23  
   12.24 -instance proof
   12.25 -  fix x :: "'a lift"
   12.26 -  show "chain (approx :: nat \<Rightarrow> 'a lift \<rightarrow> 'a lift)"
   12.27 -    unfolding approx_lift_def
   12.28 -    by (rule chainI, simp add: FLIFT_mono)
   12.29 -next
   12.30 -  fix x :: "'a lift"
   12.31 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   12.32 -    unfolding approx_lift_def
   12.33 -    apply (cases x, simp)
   12.34 -    apply (rule thelubI)
   12.35 -    apply (rule is_lubI)
   12.36 -     apply (rule ub_rangeI, simp)
   12.37 -    apply (drule ub_rangeD)
   12.38 -    apply (erule rev_below_trans)
   12.39 -    apply simp
   12.40 -    apply (rule lessI)
   12.41 -    done
   12.42 -next
   12.43 -  fix i :: nat and x :: "'a lift"
   12.44 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   12.45 -    unfolding approx_lift_def
   12.46 +lemma lub_lift_approx [simp]: "(\<Squnion>i. lift_approx i) = ID"
   12.47 +apply (rule ext_cfun)
   12.48 +apply (simp add: contlub_cfun_fun)
   12.49 +apply (simp add: lift_approx_def)
   12.50 +apply (case_tac x, simp)
   12.51 +apply (rule thelubI)
   12.52 +apply (rule is_lubI)
   12.53 +apply (rule ub_rangeI, simp)
   12.54 +apply (drule ub_rangeD)
   12.55 +apply (erule rev_below_trans)
   12.56 +apply simp
   12.57 +apply (rule lessI)
   12.58 +done
   12.59 +
   12.60 +lemma finite_deflation_lift_approx: "finite_deflation (lift_approx i)"
   12.61 +proof
   12.62 +  fix x
   12.63 +  show "lift_approx i\<cdot>x \<sqsubseteq> x"
   12.64 +    unfolding lift_approx_def
   12.65      by (cases x, simp, simp)
   12.66 -next
   12.67 -  fix i :: nat
   12.68 -  show "finite {x::'a lift. approx i\<cdot>x = x}"
   12.69 +  show "lift_approx i\<cdot>(lift_approx i\<cdot>x) = lift_approx i\<cdot>x"
   12.70 +    unfolding lift_approx_def
   12.71 +    by (cases x, simp, simp)
   12.72 +  show "finite {x::'a lift. lift_approx i\<cdot>x = x}"
   12.73    proof (rule finite_subset)
   12.74      let ?S = "insert (\<bottom>::'a lift) (Def ` to_nat -` {..<i})"
   12.75 -    show "{x::'a lift. approx i\<cdot>x = x} \<subseteq> ?S"
   12.76 -      unfolding approx_lift_def
   12.77 +    show "{x::'a lift. lift_approx i\<cdot>x = x} \<subseteq> ?S"
   12.78 +      unfolding lift_approx_def
   12.79        by (rule subsetI, case_tac x, simp, simp split: split_if_asm)
   12.80      show "finite ?S"
   12.81        by (simp add: finite_vimageI)
   12.82    qed
   12.83  qed
   12.84  
   12.85 +lemma lift_approx: "approx_chain lift_approx"
   12.86 +using chain_lift_approx lub_lift_approx finite_deflation_lift_approx
   12.87 +by (rule approx_chain.intro)
   12.88 +
   12.89 +instantiation lift :: (countable) sfp
   12.90 +begin
   12.91 +
   12.92 +definition
   12.93 +  "emb = udom_emb lift_approx"
   12.94 +
   12.95 +definition
   12.96 +  "prj = udom_prj lift_approx"
   12.97 +
   12.98 +definition
   12.99 +  "sfp (t::'a lift itself) =
  12.100 +    (\<Squnion>i. sfp_principal (Abs_fin_defl (emb oo lift_approx i oo prj)))"
  12.101 +
  12.102 +instance proof
  12.103 +  show ep: "ep_pair emb (prj :: udom \<rightarrow> 'a lift)"
  12.104 +    unfolding emb_lift_def prj_lift_def
  12.105 +    by (rule ep_pair_udom [OF lift_approx])
  12.106 +  show "cast\<cdot>SFP('a lift) = emb oo (prj :: udom \<rightarrow> 'a lift)"
  12.107 +    unfolding sfp_lift_def
  12.108 +    apply (subst contlub_cfun_arg)
  12.109 +    apply (rule chainI)
  12.110 +    apply (rule sfp.principal_mono)
  12.111 +    apply (simp add: below_fin_defl_def)
  12.112 +    apply (simp add: Abs_fin_defl_inverse finite_deflation_lift_approx
  12.113 +                     ep_pair.finite_deflation_e_d_p [OF ep])
  12.114 +    apply (intro monofun_cfun below_refl)
  12.115 +    apply (rule chainE)
  12.116 +    apply (rule chain_lift_approx)
  12.117 +    apply (subst cast_sfp_principal)
  12.118 +    apply (simp add: Abs_fin_defl_inverse finite_deflation_lift_approx
  12.119 +                     ep_pair.finite_deflation_e_d_p [OF ep] lub_distribs)
  12.120 +    done
  12.121 +qed
  12.122 +
  12.123  end
  12.124  
  12.125  end
    13.1 --- a/src/HOLCF/LowerPD.thy	Tue Oct 05 17:53:00 2010 -0700
    13.2 +++ b/src/HOLCF/LowerPD.thy	Wed Oct 06 10:49:27 2010 -0700
    13.3 @@ -71,27 +71,6 @@
    13.4  apply (simp add: lower_le_PDPlus_iff 3)
    13.5  done
    13.6  
    13.7 -lemma pd_take_lower_chain:
    13.8 -  "pd_take n t \<le>\<flat> pd_take (Suc n) t"
    13.9 -apply (induct t rule: pd_basis_induct)
   13.10 -apply (simp add: compact_basis.take_chain)
   13.11 -apply (simp add: PDPlus_lower_mono)
   13.12 -done
   13.13 -
   13.14 -lemma pd_take_lower_le: "pd_take i t \<le>\<flat> t"
   13.15 -apply (induct t rule: pd_basis_induct)
   13.16 -apply (simp add: compact_basis.take_less)
   13.17 -apply (simp add: PDPlus_lower_mono)
   13.18 -done
   13.19 -
   13.20 -lemma pd_take_lower_mono:
   13.21 -  "t \<le>\<flat> u \<Longrightarrow> pd_take n t \<le>\<flat> pd_take n u"
   13.22 -apply (erule lower_le_induct)
   13.23 -apply (simp add: compact_basis.take_mono)
   13.24 -apply (simp add: lower_le_PDUnit_PDPlus_iff)
   13.25 -apply (simp add: lower_le_PDPlus_iff)
   13.26 -done
   13.27 -
   13.28  
   13.29  subsection {* Type definition *}
   13.30  
   13.31 @@ -99,7 +78,7 @@
   13.32    "{S::'a pd_basis set. lower_le.ideal S}"
   13.33  by (fast intro: lower_le.ideal_principal)
   13.34  
   13.35 -instantiation lower_pd :: (profinite) below
   13.36 +instantiation lower_pd :: (sfp) below
   13.37  begin
   13.38  
   13.39  definition
   13.40 @@ -108,11 +87,11 @@
   13.41  instance ..
   13.42  end
   13.43  
   13.44 -instance lower_pd :: (profinite) po
   13.45 +instance lower_pd :: (sfp) po
   13.46  by (rule lower_le.typedef_ideal_po
   13.47      [OF type_definition_lower_pd below_lower_pd_def])
   13.48  
   13.49 -instance lower_pd :: (profinite) cpo
   13.50 +instance lower_pd :: (sfp) cpo
   13.51  by (rule lower_le.typedef_ideal_cpo
   13.52      [OF type_definition_lower_pd below_lower_pd_def])
   13.53  
   13.54 @@ -134,18 +113,13 @@
   13.55  by (simp add: Abs_lower_pd_inverse lower_le.ideal_principal)
   13.56  
   13.57  interpretation lower_pd:
   13.58 -  ideal_completion lower_le pd_take lower_principal Rep_lower_pd
   13.59 +  ideal_completion lower_le lower_principal Rep_lower_pd
   13.60  apply unfold_locales
   13.61 -apply (rule pd_take_lower_le)
   13.62 -apply (rule pd_take_idem)
   13.63 -apply (erule pd_take_lower_mono)
   13.64 -apply (rule pd_take_lower_chain)
   13.65 -apply (rule finite_range_pd_take)
   13.66 -apply (rule pd_take_covers)
   13.67  apply (rule ideal_Rep_lower_pd)
   13.68  apply (erule Rep_lower_pd_lub)
   13.69  apply (rule Rep_lower_principal)
   13.70  apply (simp only: below_lower_pd_def)
   13.71 +apply (rule pd_basis_countable)
   13.72  done
   13.73  
   13.74  text {* Lower powerdomain is pointed *}
   13.75 @@ -153,42 +127,12 @@
   13.76  lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
   13.77  by (induct ys rule: lower_pd.principal_induct, simp, simp)
   13.78  
   13.79 -instance lower_pd :: (bifinite) pcpo
   13.80 +instance lower_pd :: (sfp) pcpo
   13.81  by intro_classes (fast intro: lower_pd_minimal)
   13.82  
   13.83  lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
   13.84  by (rule lower_pd_minimal [THEN UU_I, symmetric])
   13.85  
   13.86 -text {* Lower powerdomain is profinite *}
   13.87 -
   13.88 -instantiation lower_pd :: (profinite) profinite
   13.89 -begin
   13.90 -
   13.91 -definition
   13.92 -  approx_lower_pd_def: "approx = lower_pd.completion_approx"
   13.93 -
   13.94 -instance
   13.95 -apply (intro_classes, unfold approx_lower_pd_def)
   13.96 -apply (rule lower_pd.chain_completion_approx)
   13.97 -apply (rule lower_pd.lub_completion_approx)
   13.98 -apply (rule lower_pd.completion_approx_idem)
   13.99 -apply (rule lower_pd.finite_fixes_completion_approx)
  13.100 -done
  13.101 -
  13.102 -end
  13.103 -
  13.104 -instance lower_pd :: (bifinite) bifinite ..
  13.105 -
  13.106 -lemma approx_lower_principal [simp]:
  13.107 -  "approx n\<cdot>(lower_principal t) = lower_principal (pd_take n t)"
  13.108 -unfolding approx_lower_pd_def
  13.109 -by (rule lower_pd.completion_approx_principal)
  13.110 -
  13.111 -lemma approx_eq_lower_principal:
  13.112 -  "\<exists>t\<in>Rep_lower_pd xs. approx n\<cdot>xs = lower_principal (pd_take n t)"
  13.113 -unfolding approx_lower_pd_def
  13.114 -by (rule lower_pd.completion_approx_eq_principal)
  13.115 -
  13.116  
  13.117  subsection {* Monadic unit and plus *}
  13.118  
  13.119 @@ -224,16 +168,6 @@
  13.120  by (simp add: lower_pd.basis_fun_principal
  13.121      lower_pd.basis_fun_mono PDPlus_lower_mono)
  13.122  
  13.123 -lemma approx_lower_unit [simp]:
  13.124 -  "approx n\<cdot>{x}\<flat> = {approx n\<cdot>x}\<flat>"
  13.125 -apply (induct x rule: compact_basis.principal_induct, simp)
  13.126 -apply (simp add: approx_Rep_compact_basis)
  13.127 -done
  13.128 -
  13.129 -lemma approx_lower_plus [simp]:
  13.130 -  "approx n\<cdot>(xs +\<flat> ys) = (approx n\<cdot>xs) +\<flat> (approx n\<cdot>ys)"
  13.131 -by (induct xs ys rule: lower_pd.principal_induct2, simp, simp, simp)
  13.132 -
  13.133  interpretation lower_add: semilattice lower_add proof
  13.134    fix xs ys zs :: "'a lower_pd"
  13.135    show "(xs +\<flat> ys) +\<flat> zs = xs +\<flat> (ys +\<flat> zs)"
  13.136 @@ -309,7 +243,8 @@
  13.137  by (simp add: po_eq_conv)
  13.138  
  13.139  lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
  13.140 -unfolding inst_lower_pd_pcpo Rep_compact_bot [symmetric] by simp
  13.141 +using lower_unit_Rep_compact_basis [of compact_bot]
  13.142 +by (simp add: inst_lower_pd_pcpo)
  13.143  
  13.144  lemma lower_unit_strict_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
  13.145  unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)
  13.146 @@ -332,8 +267,14 @@
  13.147  apply (simp add: lower_plus_least)
  13.148  done
  13.149  
  13.150 +lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
  13.151 +by (auto dest!: compact_basis.compact_imp_principal)
  13.152 +
  13.153  lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
  13.154 -unfolding profinite_compact_iff by simp
  13.155 +apply (safe elim!: compact_lower_unit)
  13.156 +apply (simp only: compact_def lower_unit_below_iff [symmetric])
  13.157 +apply (erule adm_subst [OF cont_Rep_CFun2])
  13.158 +done
  13.159  
  13.160  lemma compact_lower_plus [simp]:
  13.161    "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<flat> ys)"
  13.162 @@ -429,16 +370,12 @@
  13.163  unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)
  13.164  
  13.165  
  13.166 -subsection {* Map and join *}
  13.167 +subsection {* Map *}
  13.168  
  13.169  definition
  13.170    lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
  13.171    "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"
  13.172  
  13.173 -definition
  13.174 -  lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
  13.175 -  "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
  13.176 -
  13.177  lemma lower_map_unit [simp]:
  13.178    "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
  13.179  unfolding lower_map_def by simp
  13.180 @@ -447,14 +384,6 @@
  13.181    "lower_map\<cdot>f\<cdot>(xs +\<flat> ys) = lower_map\<cdot>f\<cdot>xs +\<flat> lower_map\<cdot>f\<cdot>ys"
  13.182  unfolding lower_map_def by simp
  13.183  
  13.184 -lemma lower_join_unit [simp]:
  13.185 -  "lower_join\<cdot>{xs}\<flat> = xs"
  13.186 -unfolding lower_join_def by simp
  13.187 -
  13.188 -lemma lower_join_plus [simp]:
  13.189 -  "lower_join\<cdot>(xss +\<flat> yss) = lower_join\<cdot>xss +\<flat> lower_join\<cdot>yss"
  13.190 -unfolding lower_join_def by simp
  13.191 -
  13.192  lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
  13.193  by (induct xs rule: lower_pd_induct, simp_all)
  13.194  
  13.195 @@ -465,22 +394,6 @@
  13.196    "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
  13.197  by (induct xs rule: lower_pd_induct, simp_all)
  13.198  
  13.199 -lemma lower_join_map_unit:
  13.200 -  "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
  13.201 -by (induct xs rule: lower_pd_induct, simp_all)
  13.202 -
  13.203 -lemma lower_join_map_join:
  13.204 -  "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
  13.205 -by (induct xsss rule: lower_pd_induct, simp_all)
  13.206 -
  13.207 -lemma lower_join_map_map:
  13.208 -  "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
  13.209 -   lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
  13.210 -by (induct xss rule: lower_pd_induct, simp_all)
  13.211 -
  13.212 -lemma lower_map_approx: "lower_map\<cdot>(approx n)\<cdot>xs = approx n\<cdot>xs"
  13.213 -by (induct xs rule: lower_pd_induct, simp_all)
  13.214 -
  13.215  lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
  13.216  apply default
  13.217  apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
  13.218 @@ -495,4 +408,134 @@
  13.219  apply (simp_all add: deflation.below monofun_cfun)
  13.220  done
  13.221  
  13.222 +(* FIXME: long proof! *)
  13.223 +lemma finite_deflation_lower_map:
  13.224 +  assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
  13.225 +proof (rule finite_deflation_intro)
  13.226 +  interpret d: finite_deflation d by fact
  13.227 +  have "deflation d" by fact
  13.228 +  thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
  13.229 +  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  13.230 +  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
  13.231 +    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  13.232 +  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  13.233 +  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
  13.234 +    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  13.235 +  hence *: "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  13.236 +  hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
  13.237 +    apply (rule rev_finite_subset)
  13.238 +    apply clarsimp
  13.239 +    apply (induct_tac xs rule: lower_pd.principal_induct)
  13.240 +    apply (simp add: adm_mem_finite *)
  13.241 +    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
  13.242 +    apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
  13.243 +    apply simp
  13.244 +    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
  13.245 +    apply clarsimp
  13.246 +    apply (rule imageI)
  13.247 +    apply (rule vimageI2)
  13.248 +    apply (simp add: Rep_PDUnit)
  13.249 +    apply (rule range_eqI)
  13.250 +    apply (erule sym)
  13.251 +    apply (rule exI)
  13.252 +    apply (rule Abs_compact_basis_inverse [symmetric])
  13.253 +    apply (simp add: d.compact)
  13.254 +    apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
  13.255 +    apply clarsimp
  13.256 +    apply (rule imageI)
  13.257 +    apply (rule vimageI2)
  13.258 +    apply (simp add: Rep_PDPlus)
  13.259 +    done
  13.260 +  thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
  13.261 +    by (rule finite_range_imp_finite_fixes)
  13.262 +qed
  13.263 +
  13.264 +subsection {* Lower powerdomain is an SFP domain *}
  13.265 +
  13.266 +definition
  13.267 +  lower_approx :: "nat \<Rightarrow> udom lower_pd \<rightarrow> udom lower_pd"
  13.268 +where
  13.269 +  "lower_approx = (\<lambda>i. lower_map\<cdot>(udom_approx i))"
  13.270 +
  13.271 +lemma lower_approx: "approx_chain lower_approx"
  13.272 +proof (rule approx_chain.intro)
  13.273 +  show "chain (\<lambda>i. lower_approx i)"
  13.274 +    unfolding lower_approx_def by simp
  13.275 +  show "(\<Squnion>i. lower_approx i) = ID"
  13.276 +    unfolding lower_approx_def
  13.277 +    by (simp add: lub_distribs lower_map_ID)
  13.278 +  show "\<And>i. finite_deflation (lower_approx i)"
  13.279 +    unfolding lower_approx_def
  13.280 +    by (intro finite_deflation_lower_map finite_deflation_udom_approx)
  13.281 +qed
  13.282 +
  13.283 +definition lower_sfp :: "sfp \<rightarrow> sfp"
  13.284 +where "lower_sfp = sfp_fun1 lower_approx lower_map"
  13.285 +
  13.286 +lemma cast_lower_sfp:
  13.287 +  "cast\<cdot>(lower_sfp\<cdot>A) =
  13.288 +    udom_emb lower_approx oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj lower_approx"
  13.289 +unfolding lower_sfp_def
  13.290 +apply (rule cast_sfp_fun1 [OF lower_approx])
  13.291 +apply (erule finite_deflation_lower_map)
  13.292 +done
  13.293 +
  13.294 +instantiation lower_pd :: (sfp) sfp
  13.295 +begin
  13.296 +
  13.297 +definition
  13.298 +  "emb = udom_emb lower_approx oo lower_map\<cdot>emb"
  13.299 +
  13.300 +definition
  13.301 +  "prj = lower_map\<cdot>prj oo udom_prj lower_approx"
  13.302 +
  13.303 +definition
  13.304 +  "sfp (t::'a lower_pd itself) = lower_sfp\<cdot>SFP('a)"
  13.305 +
  13.306 +instance proof
  13.307 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
  13.308 +    unfolding emb_lower_pd_def prj_lower_pd_def
  13.309 +    using ep_pair_udom [OF lower_approx]
  13.310 +    by (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj)
  13.311 +next
  13.312 +  show "cast\<cdot>SFP('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
  13.313 +    unfolding emb_lower_pd_def prj_lower_pd_def sfp_lower_pd_def cast_lower_sfp
  13.314 +    by (simp add: cast_SFP oo_def expand_cfun_eq lower_map_map)
  13.315 +qed
  13.316 +
  13.317  end
  13.318 +
  13.319 +text {* SFP of type constructor = type combinator *}
  13.320 +
  13.321 +lemma SFP_lower: "SFP('a lower_pd) = lower_sfp\<cdot>SFP('a)"
  13.322 +by (rule sfp_lower_pd_def)
  13.323 +
  13.324 +
  13.325 +subsection {* Join *}
  13.326 +
  13.327 +definition
  13.328 +  lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
  13.329 +  "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
  13.330 +
  13.331 +lemma lower_join_unit [simp]:
  13.332 +  "lower_join\<cdot>{xs}\<flat> = xs"
  13.333 +unfolding lower_join_def by simp
  13.334 +
  13.335 +lemma lower_join_plus [simp]:
  13.336 +  "lower_join\<cdot>(xss +\<flat> yss) = lower_join\<cdot>xss +\<flat> lower_join\<cdot>yss"
  13.337 +unfolding lower_join_def by simp
  13.338 +
  13.339 +lemma lower_join_map_unit:
  13.340 +  "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
  13.341 +by (induct xs rule: lower_pd_induct, simp_all)
  13.342 +
  13.343 +lemma lower_join_map_join:
  13.344 +  "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
  13.345 +by (induct xsss rule: lower_pd_induct, simp_all)
  13.346 +
  13.347 +lemma lower_join_map_map:
  13.348 +  "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
  13.349 +   lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
  13.350 +by (induct xss rule: lower_pd_induct, simp_all)
  13.351 +
  13.352 +end
    14.1 --- a/src/HOLCF/Powerdomains.thy	Tue Oct 05 17:53:00 2010 -0700
    14.2 +++ b/src/HOLCF/Powerdomains.thy	Wed Oct 06 10:49:27 2010 -0700
    14.3 @@ -5,290 +5,29 @@
    14.4  header {* Powerdomains *}
    14.5  
    14.6  theory Powerdomains
    14.7 -imports Representable ConvexPD
    14.8 -begin
    14.9 -
   14.10 -subsection {* Powerdomains are representable *}
   14.11 -
   14.12 -text "Upper powerdomain of a representable type is representable."
   14.13 -
   14.14 -instantiation upper_pd :: (rep) rep
   14.15 -begin
   14.16 -
   14.17 -definition emb_upper_pd_def: "emb = udom_emb oo upper_map\<cdot>emb"
   14.18 -definition prj_upper_pd_def: "prj = upper_map\<cdot>prj oo udom_prj"
   14.19 -
   14.20 -instance
   14.21 - apply (intro_classes, unfold emb_upper_pd_def prj_upper_pd_def)
   14.22 - apply (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj ep_pair_udom)
   14.23 -done
   14.24 -
   14.25 -end
   14.26 -
   14.27 -text "Lower powerdomain of a representable type is representable."
   14.28 -
   14.29 -instantiation lower_pd :: (rep) rep
   14.30 -begin
   14.31 -
   14.32 -definition emb_lower_pd_def: "emb = udom_emb oo lower_map\<cdot>emb"
   14.33 -definition prj_lower_pd_def: "prj = lower_map\<cdot>prj oo udom_prj"
   14.34 -
   14.35 -instance
   14.36 - apply (intro_classes, unfold emb_lower_pd_def prj_lower_pd_def)
   14.37 - apply (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj ep_pair_udom)
   14.38 -done
   14.39 -
   14.40 -end
   14.41 -
   14.42 -text "Convex powerdomain of a representable type is representable."
   14.43 -
   14.44 -instantiation convex_pd :: (rep) rep
   14.45 +imports ConvexPD Domain
   14.46  begin
   14.47  
   14.48 -definition emb_convex_pd_def: "emb = udom_emb oo convex_map\<cdot>emb"
   14.49 -definition prj_convex_pd_def: "prj = convex_map\<cdot>prj oo udom_prj"
   14.50 -
   14.51 -instance
   14.52 - apply (intro_classes, unfold emb_convex_pd_def prj_convex_pd_def)
   14.53 - apply (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj ep_pair_udom)
   14.54 -done
   14.55 -
   14.56 -end
   14.57 -
   14.58 -subsection {* Finite deflation lemmas *}
   14.59 -
   14.60 -text "TODO: move these lemmas somewhere else"
   14.61 -
   14.62 -lemma finite_compact_range_imp_finite_range:
   14.63 -  fixes d :: "'a::profinite \<rightarrow> 'b::cpo"
   14.64 -  assumes "finite ((\<lambda>x. d\<cdot>x) ` {x. compact x})"
   14.65 -  shows "finite (range (\<lambda>x. d\<cdot>x))"
   14.66 -proof (rule finite_subset [OF _ prems])
   14.67 -  {
   14.68 -    fix x :: 'a
   14.69 -    have "range (\<lambda>i. d\<cdot>(approx i\<cdot>x)) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
   14.70 -      by auto
   14.71 -    hence "finite (range (\<lambda>i. d\<cdot>(approx i\<cdot>x)))"
   14.72 -      using prems by (rule finite_subset)
   14.73 -    hence "finite_chain (\<lambda>i. d\<cdot>(approx i\<cdot>x))"
   14.74 -      by (simp add: finite_range_imp_finch)
   14.75 -    hence "\<exists>i. (\<Squnion>i. d\<cdot>(approx i\<cdot>x)) = d\<cdot>(approx i\<cdot>x)"
   14.76 -      by (simp add: finite_chain_def maxinch_is_thelub)
   14.77 -    hence "\<exists>i. d\<cdot>x = d\<cdot>(approx i\<cdot>x)"
   14.78 -      by (simp add: lub_distribs)
   14.79 -    hence "d\<cdot>x \<in> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
   14.80 -      by auto
   14.81 -  }
   14.82 -  thus "range (\<lambda>x. d\<cdot>x) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
   14.83 -    by clarsimp
   14.84 -qed
   14.85 -
   14.86 -lemma finite_deflation_upper_map:
   14.87 -  assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
   14.88 -proof (rule finite_deflation_intro)
   14.89 -  interpret d: finite_deflation d by fact
   14.90 -  have "deflation d" by fact
   14.91 -  thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
   14.92 -  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
   14.93 -  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
   14.94 -    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
   14.95 -  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
   14.96 -  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
   14.97 -    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
   14.98 -  hence "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
   14.99 -  hence "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` range upper_principal)"
  14.100 -    apply (rule finite_subset [COMP swap_prems_rl])
  14.101 -    apply (clarsimp, rename_tac t)
  14.102 -    apply (induct_tac t rule: pd_basis_induct)
  14.103 -    apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
  14.104 -    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
  14.105 -    apply clarsimp
  14.106 -    apply (rule imageI)
  14.107 -    apply (rule vimageI2)
  14.108 -    apply (simp add: Rep_PDUnit)
  14.109 -    apply (rule image_eqI)
  14.110 -    apply (erule sym)
  14.111 -    apply simp
  14.112 -    apply (rule exI)
  14.113 -    apply (rule Abs_compact_basis_inverse [symmetric])
  14.114 -    apply (simp add: d.compact)
  14.115 -    apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
  14.116 -    apply clarsimp
  14.117 -    apply (rule imageI)
  14.118 -    apply (rule vimageI2)
  14.119 -    apply (simp add: Rep_PDPlus)
  14.120 -    done
  14.121 -  moreover have "{xs::'a upper_pd. compact xs} = range upper_principal"
  14.122 -    by (auto dest: upper_pd.compact_imp_principal)
  14.123 -  ultimately have "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` {xs::'a upper_pd. compact xs})"
  14.124 -    by simp
  14.125 -  hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
  14.126 -    by (rule finite_compact_range_imp_finite_range)
  14.127 -  thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
  14.128 -    by (rule finite_range_imp_finite_fixes)
  14.129 -qed
  14.130 -
  14.131 -lemma finite_deflation_lower_map:
  14.132 -  assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
  14.133 -proof (rule finite_deflation_intro)
  14.134 -  interpret d: finite_deflation d by fact
  14.135 -  have "deflation d" by fact
  14.136 -  thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
  14.137 -  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  14.138 -  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
  14.139 -    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  14.140 -  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  14.141 -  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
  14.142 -    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  14.143 -  hence "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  14.144 -  hence "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` range lower_principal)"
  14.145 -    apply (rule finite_subset [COMP swap_prems_rl])
  14.146 -    apply (clarsimp, rename_tac t)
  14.147 -    apply (induct_tac t rule: pd_basis_induct)
  14.148 -    apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
  14.149 -    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
  14.150 -    apply clarsimp
  14.151 -    apply (rule imageI)
  14.152 -    apply (rule vimageI2)
  14.153 -    apply (simp add: Rep_PDUnit)
  14.154 -    apply (rule image_eqI)
  14.155 -    apply (erule sym)
  14.156 -    apply simp
  14.157 -    apply (rule exI)
  14.158 -    apply (rule Abs_compact_basis_inverse [symmetric])
  14.159 -    apply (simp add: d.compact)
  14.160 -    apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
  14.161 -    apply clarsimp
  14.162 -    apply (rule imageI)
  14.163 -    apply (rule vimageI2)
  14.164 -    apply (simp add: Rep_PDPlus)
  14.165 -    done
  14.166 -  moreover have "{xs::'a lower_pd. compact xs} = range lower_principal"
  14.167 -    by (auto dest: lower_pd.compact_imp_principal)
  14.168 -  ultimately have "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` {xs::'a lower_pd. compact xs})"
  14.169 -    by simp
  14.170 -  hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
  14.171 -    by (rule finite_compact_range_imp_finite_range)
  14.172 -  thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
  14.173 -    by (rule finite_range_imp_finite_fixes)
  14.174 -qed
  14.175 -
  14.176 -lemma finite_deflation_convex_map:
  14.177 -  assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
  14.178 -proof (rule finite_deflation_intro)
  14.179 -  interpret d: finite_deflation d by fact
  14.180 -  have "deflation d" by fact
  14.181 -  thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
  14.182 -  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  14.183 -  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
  14.184 -    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  14.185 -  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  14.186 -  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
  14.187 -    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  14.188 -  hence "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  14.189 -  hence "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` range convex_principal)"
  14.190 -    apply (rule finite_subset [COMP swap_prems_rl])
  14.191 -    apply (clarsimp, rename_tac t)
  14.192 -    apply (induct_tac t rule: pd_basis_induct)
  14.193 -    apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
  14.194 -    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
  14.195 -    apply clarsimp
  14.196 -    apply (rule imageI)
  14.197 -    apply (rule vimageI2)
  14.198 -    apply (simp add: Rep_PDUnit)
  14.199 -    apply (rule image_eqI)
  14.200 -    apply (erule sym)
  14.201 -    apply simp
  14.202 -    apply (rule exI)
  14.203 -    apply (rule Abs_compact_basis_inverse [symmetric])
  14.204 -    apply (simp add: d.compact)
  14.205 -    apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
  14.206 -    apply clarsimp
  14.207 -    apply (rule imageI)
  14.208 -    apply (rule vimageI2)
  14.209 -    apply (simp add: Rep_PDPlus)
  14.210 -    done
  14.211 -  moreover have "{xs::'a convex_pd. compact xs} = range convex_principal"
  14.212 -    by (auto dest: convex_pd.compact_imp_principal)
  14.213 -  ultimately have "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` {xs::'a convex_pd. compact xs})"
  14.214 -    by simp
  14.215 -  hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
  14.216 -    by (rule finite_compact_range_imp_finite_range)
  14.217 -  thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
  14.218 -    by (rule finite_range_imp_finite_fixes)
  14.219 -qed
  14.220 -
  14.221 -subsection {* Deflation combinators *}
  14.222 -
  14.223 -definition "upper_defl = TypeRep_fun1 upper_map"
  14.224 -definition "lower_defl = TypeRep_fun1 lower_map"
  14.225 -definition "convex_defl = TypeRep_fun1 convex_map"
  14.226 -
  14.227 -lemma cast_upper_defl:
  14.228 -  "cast\<cdot>(upper_defl\<cdot>A) = udom_emb oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj"
  14.229 -unfolding upper_defl_def
  14.230 -apply (rule cast_TypeRep_fun1)
  14.231 -apply (erule finite_deflation_upper_map)
  14.232 -done
  14.233 -
  14.234 -lemma cast_lower_defl:
  14.235 -  "cast\<cdot>(lower_defl\<cdot>A) = udom_emb oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj"
  14.236 -unfolding lower_defl_def
  14.237 -apply (rule cast_TypeRep_fun1)
  14.238 -apply (erule finite_deflation_lower_map)
  14.239 -done
  14.240 -
  14.241 -lemma cast_convex_defl:
  14.242 -  "cast\<cdot>(convex_defl\<cdot>A) = udom_emb oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj"
  14.243 -unfolding convex_defl_def
  14.244 -apply (rule cast_TypeRep_fun1)
  14.245 -apply (erule finite_deflation_convex_map)
  14.246 -done
  14.247 -
  14.248 -lemma REP_upper: "REP('a upper_pd) = upper_defl\<cdot>REP('a)"
  14.249 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  14.250 -apply (simp add: cast_REP cast_upper_defl)
  14.251 -apply (simp add: prj_upper_pd_def)
  14.252 -apply (simp add: emb_upper_pd_def)
  14.253 -apply (simp add: upper_map_map cfcomp1)
  14.254 -done
  14.255 -
  14.256 -lemma REP_lower: "REP('a lower_pd) = lower_defl\<cdot>REP('a)"
  14.257 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  14.258 -apply (simp add: cast_REP cast_lower_defl)
  14.259 -apply (simp add: prj_lower_pd_def)
  14.260 -apply (simp add: emb_lower_pd_def)
  14.261 -apply (simp add: lower_map_map cfcomp1)
  14.262 -done
  14.263 -
  14.264 -lemma REP_convex: "REP('a convex_pd) = convex_defl\<cdot>REP('a)"
  14.265 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  14.266 -apply (simp add: cast_REP cast_convex_defl)
  14.267 -apply (simp add: prj_convex_pd_def)
  14.268 -apply (simp add: emb_convex_pd_def)
  14.269 -apply (simp add: convex_map_map cfcomp1)
  14.270 -done
  14.271 -
  14.272  lemma isodefl_upper:
  14.273 -  "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
  14.274 +  "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_sfp\<cdot>t)"
  14.275  apply (rule isodeflI)
  14.276 -apply (simp add: cast_upper_defl cast_isodefl)
  14.277 +apply (simp add: cast_upper_sfp cast_isodefl)
  14.278  apply (simp add: emb_upper_pd_def prj_upper_pd_def)
  14.279  apply (simp add: upper_map_map)
  14.280  done
  14.281  
  14.282  lemma isodefl_lower:
  14.283 -  "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
  14.284 +  "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_sfp\<cdot>t)"
  14.285  apply (rule isodeflI)
  14.286 -apply (simp add: cast_lower_defl cast_isodefl)
  14.287 +apply (simp add: cast_lower_sfp cast_isodefl)
  14.288  apply (simp add: emb_lower_pd_def prj_lower_pd_def)
  14.289  apply (simp add: lower_map_map)
  14.290  done
  14.291  
  14.292  lemma isodefl_convex:
  14.293 -  "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
  14.294 +  "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_sfp\<cdot>t)"
  14.295  apply (rule isodeflI)
  14.296 -apply (simp add: cast_convex_defl cast_isodefl)
  14.297 +apply (simp add: cast_convex_sfp cast_isodefl)
  14.298  apply (simp add: emb_convex_pd_def prj_convex_pd_def)
  14.299  apply (simp add: convex_map_map)
  14.300  done
  14.301 @@ -297,16 +36,16 @@
  14.302  
  14.303  setup {*
  14.304    fold Domain_Isomorphism.add_type_constructor
  14.305 -    [(@{type_name "upper_pd"}, @{term upper_defl}, @{const_name upper_map},
  14.306 -        @{thm REP_upper}, @{thm isodefl_upper}, @{thm upper_map_ID},
  14.307 +    [(@{type_name "upper_pd"}, @{term upper_sfp}, @{const_name upper_map},
  14.308 +        @{thm SFP_upper}, @{thm isodefl_upper}, @{thm upper_map_ID},
  14.309            @{thm deflation_upper_map}),
  14.310  
  14.311 -     (@{type_name "lower_pd"}, @{term lower_defl}, @{const_name lower_map},
  14.312 -        @{thm REP_lower}, @{thm isodefl_lower}, @{thm lower_map_ID},
  14.313 +     (@{type_name "lower_pd"}, @{term lower_sfp}, @{const_name lower_map},
  14.314 +        @{thm SFP_lower}, @{thm isodefl_lower}, @{thm lower_map_ID},
  14.315            @{thm deflation_lower_map}),
  14.316  
  14.317 -     (@{type_name "convex_pd"}, @{term convex_defl}, @{const_name convex_map},
  14.318 -        @{thm REP_convex}, @{thm isodefl_convex}, @{thm convex_map_ID},
  14.319 +     (@{type_name "convex_pd"}, @{term convex_sfp}, @{const_name convex_map},
  14.320 +        @{thm SFP_convex}, @{thm isodefl_convex}, @{thm convex_map_ID},
  14.321            @{thm deflation_convex_map})]
  14.322  *}
  14.323  
    15.1 --- a/src/HOLCF/Representable.thy	Tue Oct 05 17:53:00 2010 -0700
    15.2 +++ b/src/HOLCF/Representable.thy	Wed Oct 06 10:49:27 2010 -0700
    15.3 @@ -5,97 +5,30 @@
    15.4  header {* Representable Types *}
    15.5  
    15.6  theory Representable
    15.7 -imports Algebraic Universal Ssum Sprod One Fixrec Domain_Aux
    15.8 +imports Algebraic Universal Ssum One Fixrec Domain_Aux
    15.9  uses
   15.10    ("Tools/repdef.ML")
   15.11    ("Tools/Domain/domain_isomorphism.ML")
   15.12  begin
   15.13  
   15.14 -subsection {* Class of representable types *}
   15.15 -
   15.16 -text "Overloaded embedding and projection functions between
   15.17 -      a representable type and the universal domain."
   15.18 -
   15.19 -class rep = bifinite +
   15.20 -  fixes emb :: "'a::pcpo \<rightarrow> udom"
   15.21 -  fixes prj :: "udom \<rightarrow> 'a::pcpo"
   15.22 -  assumes ep_pair_emb_prj: "ep_pair emb prj"
   15.23 -
   15.24 -interpretation rep:
   15.25 -  pcpo_ep_pair
   15.26 -    "emb :: 'a::rep \<rightarrow> udom"
   15.27 -    "prj :: udom \<rightarrow> 'a::rep"
   15.28 -  unfolding pcpo_ep_pair_def
   15.29 -  by (rule ep_pair_emb_prj)
   15.30 -
   15.31 -lemmas emb_inverse = rep.e_inverse
   15.32 -lemmas emb_prj_below = rep.e_p_below
   15.33 -lemmas emb_eq_iff = rep.e_eq_iff
   15.34 -lemmas emb_strict = rep.e_strict
   15.35 -lemmas prj_strict = rep.p_strict
   15.36 -
   15.37 -
   15.38 -subsection {* Making \emph{rep} the default class *}
   15.39 -
   15.40 -text {*
   15.41 -  From now on, free type variables are assumed to be in class
   15.42 -  @{term rep}, unless specified otherwise.
   15.43 -*}
   15.44 -
   15.45 -default_sort rep
   15.46 +default_sort sfp
   15.47  
   15.48  subsection {* Representations of types *}
   15.49  
   15.50 -text "A TypeRep is an algebraic deflation over the universe of values."
   15.51 -
   15.52 -types TypeRep = "udom alg_defl"
   15.53 -translations (type) "TypeRep" \<leftharpoondown> (type) "udom alg_defl"
   15.54 -
   15.55 -definition
   15.56 -  Rep_of :: "'a::rep itself \<Rightarrow> TypeRep"
   15.57 -where
   15.58 -  "Rep_of TYPE('a::rep) =
   15.59 -    (\<Squnion>i. alg_defl_principal (Abs_fin_defl
   15.60 -      (emb oo (approx i :: 'a \<rightarrow> 'a) oo prj)))"
   15.61 -
   15.62 -syntax "_REP" :: "type \<Rightarrow> TypeRep"  ("(1REP/(1'(_')))")
   15.63 -translations "REP('t)" \<rightleftharpoons> "CONST Rep_of TYPE('t)"
   15.64 +lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a::sfp) = cast\<cdot>SFP('a)\<cdot>x"
   15.65 +by (simp add: cast_SFP)
   15.66  
   15.67 -lemma cast_REP:
   15.68 -  "cast\<cdot>REP('a::rep) = (emb::'a \<rightarrow> udom) oo (prj::udom \<rightarrow> 'a)"
   15.69 -proof -
   15.70 -  let ?a = "\<lambda>i. emb oo approx i oo (prj::udom \<rightarrow> 'a)"
   15.71 -  have a: "\<And>i. finite_deflation (?a i)"
   15.72 -    apply (rule rep.finite_deflation_e_d_p)
   15.73 -    apply (rule finite_deflation_approx)
   15.74 -    done
   15.75 -  show ?thesis
   15.76 -    unfolding Rep_of_def
   15.77 -    apply (subst contlub_cfun_arg)
   15.78 -    apply (rule chainI)
   15.79 -    apply (rule alg_defl.principal_mono)
   15.80 -    apply (rule Abs_fin_defl_mono [OF a a])
   15.81 -    apply (rule chainE, simp)
   15.82 -    apply (subst cast_alg_defl_principal)
   15.83 -    apply (simp add: Abs_fin_defl_inverse a)
   15.84 -    apply (simp add: expand_cfun_eq lub_distribs)
   15.85 -    done
   15.86 -qed
   15.87 -
   15.88 -lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a::rep) = cast\<cdot>REP('a)\<cdot>x"
   15.89 -by (simp add: cast_REP)
   15.90 -
   15.91 -lemma in_REP_iff:
   15.92 -  "x ::: REP('a::rep) \<longleftrightarrow> emb\<cdot>((prj\<cdot>x)::'a) = x"
   15.93 -by (simp add: in_deflation_def cast_REP)
   15.94 +lemma in_SFP_iff:
   15.95 +  "x ::: SFP('a::sfp) \<longleftrightarrow> emb\<cdot>((prj\<cdot>x)::'a) = x"
   15.96 +by (simp add: in_sfp_def cast_SFP)
   15.97  
   15.98  lemma prj_inverse:
   15.99 -  "x ::: REP('a::rep) \<Longrightarrow> emb\<cdot>((prj\<cdot>x)::'a) = x"
  15.100 -by (simp only: in_REP_iff)
  15.101 +  "x ::: SFP('a::sfp) \<Longrightarrow> emb\<cdot>((prj\<cdot>x)::'a) = x"
  15.102 +by (simp only: in_SFP_iff)
  15.103  
  15.104 -lemma emb_in_REP [simp]:
  15.105 -  "emb\<cdot>(x::'a::rep) ::: REP('a)"
  15.106 -by (simp add: in_REP_iff)
  15.107 +lemma emb_in_SFP [simp]:
  15.108 +  "emb\<cdot>(x::'a::sfp) ::: SFP('a)"
  15.109 +by (simp add: in_SFP_iff)
  15.110  
  15.111  subsection {* Coerce operator *}
  15.112  
  15.113 @@ -115,16 +48,16 @@
  15.114  by (rule ext_cfun, simp add: beta_coerce)
  15.115  
  15.116  lemma emb_coerce:
  15.117 -  "REP('a) \<sqsubseteq> REP('b)
  15.118 +  "SFP('a) \<sqsubseteq> SFP('b)
  15.119     \<Longrightarrow> emb\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) = emb\<cdot>x"
  15.120   apply (simp add: beta_coerce)
  15.121   apply (rule prj_inverse)
  15.122 - apply (erule subdeflationD)
  15.123 - apply (rule emb_in_REP)
  15.124 + apply (erule sfp_belowD)
  15.125 + apply (rule emb_in_SFP)
  15.126  done
  15.127  
  15.128  lemma coerce_prj:
  15.129 -  "REP('a) \<sqsubseteq> REP('b)
  15.130 +  "SFP('a) \<sqsubseteq> SFP('b)
  15.131     \<Longrightarrow> (coerce::'b \<rightarrow> 'a)\<cdot>(prj\<cdot>x) = prj\<cdot>x"
  15.132   apply (simp add: coerce_def)
  15.133   apply (rule emb_eq_iff [THEN iffD1])
  15.134 @@ -136,21 +69,21 @@
  15.135  done
  15.136  
  15.137  lemma coerce_coerce [simp]:
  15.138 -  "REP('a) \<sqsubseteq> REP('b)
  15.139 +  "SFP('a) \<sqsubseteq> SFP('b)
  15.140     \<Longrightarrow> coerce\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) = coerce\<cdot>x"
  15.141 -by (simp add: beta_coerce prj_inverse subdeflationD)
  15.142 +by (simp add: beta_coerce prj_inverse sfp_belowD)
  15.143  
  15.144  lemma coerce_inverse:
  15.145 -  "emb\<cdot>(x::'a) ::: REP('b) \<Longrightarrow> coerce\<cdot>(coerce\<cdot>x :: 'b) = x"
  15.146 +  "emb\<cdot>(x::'a) ::: SFP('b) \<Longrightarrow> coerce\<cdot>(coerce\<cdot>x :: 'b) = x"
  15.147  by (simp only: beta_coerce prj_inverse emb_inverse)
  15.148  
  15.149  lemma coerce_type:
  15.150 -  "REP('a) \<sqsubseteq> REP('b)
  15.151 -   \<Longrightarrow> emb\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) ::: REP('a)"
  15.152 -by (simp add: beta_coerce prj_inverse subdeflationD)
  15.153 +  "SFP('a) \<sqsubseteq> SFP('b)
  15.154 +   \<Longrightarrow> emb\<cdot>((coerce::'a \<rightarrow> 'b)\<cdot>x) ::: SFP('a)"
  15.155 +by (simp add: beta_coerce prj_inverse sfp_belowD)
  15.156  
  15.157  lemma ep_pair_coerce:
  15.158 -  "REP('a) \<sqsubseteq> REP('b)
  15.159 +  "SFP('a) \<sqsubseteq> SFP('b)
  15.160     \<Longrightarrow> ep_pair (coerce::'a \<rightarrow> 'b) (coerce::'b \<rightarrow> 'a)"
  15.161   apply (rule ep_pair.intro)
  15.162    apply simp
  15.163 @@ -165,30 +98,29 @@
  15.164  
  15.165  lemma domain_abs_iso:
  15.166    fixes abs and rep
  15.167 -  assumes REP: "REP('b) = REP('a)"
  15.168 +  assumes SFP: "SFP('b) = SFP('a)"
  15.169    assumes abs_def: "abs \<equiv> (coerce :: 'a \<rightarrow> 'b)"
  15.170    assumes rep_def: "rep \<equiv> (coerce :: 'b \<rightarrow> 'a)"
  15.171    shows "rep\<cdot>(abs\<cdot>x) = x"
  15.172 -unfolding abs_def rep_def by (simp add: REP)
  15.173 +unfolding abs_def rep_def by (simp add: SFP)
  15.174  
  15.175  lemma domain_rep_iso:
  15.176    fixes abs and rep
  15.177 -  assumes REP: "REP('b) = REP('a)"
  15.178 +  assumes SFP: "SFP('b) = SFP('a)"
  15.179    assumes abs_def: "abs \<equiv> (coerce :: 'a \<rightarrow> 'b)"
  15.180    assumes rep_def: "rep \<equiv> (coerce :: 'b \<rightarrow> 'a)"
  15.181    shows "abs\<cdot>(rep\<cdot>x) = x"
  15.182 -unfolding abs_def rep_def by (simp add: REP [symmetric])
  15.183 +unfolding abs_def rep_def by (simp add: SFP [symmetric])
  15.184  
  15.185  
  15.186  subsection {* Proving a subtype is representable *}
  15.187  
  15.188  text {*
  15.189 -  Temporarily relax type constraints for @{term "approx"},
  15.190 -  @{term emb}, and @{term prj}.
  15.191 +  Temporarily relax type constraints for @{term emb}, and @{term prj}.
  15.192  *}
  15.193  
  15.194  setup {* Sign.add_const_constraint
  15.195 -  (@{const_name "approx"}, SOME @{typ "nat \<Rightarrow> 'a::cpo \<rightarrow> 'a"}) *}
  15.196 +  (@{const_name sfp}, SOME @{typ "'a::pcpo itself \<Rightarrow> sfp"}) *}
  15.197  
  15.198  setup {* Sign.add_const_constraint
  15.199    (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"}) *}
  15.200 @@ -196,118 +128,19 @@
  15.201  setup {* Sign.add_const_constraint
  15.202    (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"}) *}
  15.203  
  15.204 -definition
  15.205 -  repdef_approx ::
  15.206 -    "('a::pcpo \<Rightarrow> udom) \<Rightarrow> (udom \<Rightarrow> 'a) \<Rightarrow> udom alg_defl \<Rightarrow> nat \<Rightarrow> 'a \<rightarrow> 'a"
  15.207 -where
  15.208 -  "repdef_approx Rep Abs t = (\<lambda>i. \<Lambda> x. Abs (cast\<cdot>(approx i\<cdot>t)\<cdot>(Rep x)))"
  15.209 -
  15.210  lemma typedef_rep_class:
  15.211    fixes Rep :: "'a::pcpo \<Rightarrow> udom"
  15.212    fixes Abs :: "udom \<Rightarrow> 'a::pcpo"
  15.213 -  fixes t :: TypeRep
  15.214 +  fixes t :: sfp
  15.215    assumes type: "type_definition Rep Abs {x. x ::: t}"
  15.216    assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  15.217    assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)"
  15.218    assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))"
  15.219 -  assumes approx: "(approx :: nat \<Rightarrow> 'a \<rightarrow> 'a) \<equiv> repdef_approx Rep Abs t"
  15.220 -  shows "OFCLASS('a, rep_class)"
  15.221 +  assumes sfp: "sfp \<equiv> (\<lambda> a::'a itself. t)"
  15.222 +  shows "OFCLASS('a, sfp_class)"
  15.223  proof
  15.224    have adm: "adm (\<lambda>x. x \<in> {x. x ::: t})"
  15.225 -    by (simp add: adm_in_deflation)
  15.226 -  have emb_beta: "\<And>x. emb\<cdot>x = Rep x"
  15.227 -    unfolding emb
  15.228 -    apply (rule beta_cfun)
  15.229 -    apply (rule typedef_cont_Rep [OF type below adm])
  15.230 -    done
  15.231 -  have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)"
  15.232 -    unfolding prj
  15.233 -    apply (rule beta_cfun)
  15.234 -    apply (rule typedef_cont_Abs [OF type below adm])
  15.235 -    apply simp_all
  15.236 -    done
  15.237 -  have cast_cast_approx:
  15.238 -    "\<And>i x. cast\<cdot>t\<cdot>(cast\<cdot>(approx i\<cdot>t)\<cdot>x) = cast\<cdot>(approx i\<cdot>t)\<cdot>x"
  15.239 -    apply (rule cast_fixed)
  15.240 -    apply (rule subdeflationD)
  15.241 -    apply (rule approx.below)
  15.242 -    apply (rule cast_in_deflation)
  15.243 -    done
  15.244 -  have approx':
  15.245 -    "approx = (\<lambda>i. \<Lambda>(x::'a). prj\<cdot>(cast\<cdot>(approx i\<cdot>t)\<cdot>(emb\<cdot>x)))"
  15.246 -    unfolding approx repdef_approx_def
  15.247 -    apply (subst cast_cast_approx [symmetric])
  15.248 -    apply (simp add: prj_beta [symmetric] emb_beta [symmetric])
  15.249 -    done
  15.250 -  have emb_in_deflation: "\<And>x::'a. emb\<cdot>x ::: t"
  15.251 -    using type_definition.Rep [OF type]
  15.252 -    by (simp add: emb_beta)
  15.253 -  have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x"
  15.254 -    unfolding prj_beta
  15.255 -    apply (simp add: cast_fixed [OF emb_in_deflation])
  15.256 -    apply (simp add: emb_beta type_definition.Rep_inverse [OF type])
  15.257 -    done
  15.258 -  have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y"
  15.259 -    unfolding prj_beta emb_beta
  15.260 -    by (simp add: type_definition.Abs_inverse [OF type])
  15.261 -  show "ep_pair (emb :: 'a \<rightarrow> udom) prj"
  15.262 -    apply default
  15.263 -    apply (simp add: prj_emb)
  15.264 -    apply (simp add: emb_prj cast.below)
  15.265 -    done
  15.266 -  show "chain (approx :: nat \<Rightarrow> 'a \<rightarrow> 'a)"
  15.267 -    unfolding approx' by simp
  15.268 -  show "\<And>x::'a. (\<Squnion>i. approx i\<cdot>x) = x"
  15.269 -    unfolding approx'
  15.270 -    apply (simp add: lub_distribs)
  15.271 -    apply (subst cast_fixed [OF emb_in_deflation])
  15.272 -    apply (rule prj_emb)
  15.273 -    done
  15.274 -  show "\<And>(i::nat) (x::'a). approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
  15.275 -    unfolding approx'
  15.276 -    apply simp
  15.277 -    apply (simp add: emb_prj)
  15.278 -    apply (simp add: cast_cast_approx)
  15.279 -    done
  15.280 -  show "\<And>i::nat. finite {x::'a. approx i\<cdot>x = x}"
  15.281 -    apply (rule_tac B="(\<lambda>x. prj\<cdot>x) ` {x. cast\<cdot>(approx i\<cdot>t)\<cdot>x = x}"
  15.282 -           in finite_subset)
  15.283 -    apply (clarsimp simp add: approx')
  15.284 -    apply (drule_tac f="\<lambda>x. emb\<cdot>x" in arg_cong)
  15.285 -    apply (rule image_eqI)
  15.286 -    apply (rule prj_emb [symmetric])
  15.287 -    apply (simp add: emb_prj)
  15.288 -    apply (simp add: cast_cast_approx)
  15.289 -    apply (rule finite_imageI)
  15.290 -    apply (simp add: cast_approx_fixed_iff)
  15.291 -    apply (simp add: Collect_conj_eq)
  15.292 -    apply (simp add: finite_fixes_approx)
  15.293 -    done
  15.294 -qed
  15.295 -
  15.296 -text {* Restore original typing constraints *}
  15.297 -
  15.298 -setup {* Sign.add_const_constraint
  15.299 -  (@{const_name "approx"}, SOME @{typ "nat \<Rightarrow> 'a::profinite \<rightarrow> 'a"}) *}
  15.300 -
  15.301 -setup {* Sign.add_const_constraint
  15.302 -  (@{const_name emb}, SOME @{typ "'a::rep \<rightarrow> udom"}) *}
  15.303 -
  15.304 -setup {* Sign.add_const_constraint
  15.305 -  (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::rep"}) *}
  15.306 -
  15.307 -lemma typedef_REP:
  15.308 -  fixes Rep :: "'a::rep \<Rightarrow> udom"
  15.309 -  fixes Abs :: "udom \<Rightarrow> 'a::rep"
  15.310 -  fixes t :: TypeRep
  15.311 -  assumes type: "type_definition Rep Abs {x. x ::: t}"
  15.312 -  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  15.313 -  assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)"
  15.314 -  assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))"
  15.315 -  shows "REP('a) = t"
  15.316 -proof -
  15.317 -  have adm: "adm (\<lambda>x. x \<in> {x. x ::: t})"
  15.318 -    by (simp add: adm_in_deflation)
  15.319 +    by (simp add: adm_in_sfp)
  15.320    have emb_beta: "\<And>x. emb\<cdot>x = Rep x"
  15.321      unfolding emb
  15.322      apply (rule beta_cfun)
  15.323 @@ -319,313 +152,51 @@
  15.324      apply (rule typedef_cont_Abs [OF type below adm])
  15.325      apply simp_all
  15.326      done
  15.327 -  have emb_in_deflation: "\<And>x::'a. emb\<cdot>x ::: t"
  15.328 +  have emb_in_sfp: "\<And>x::'a. emb\<cdot>x ::: t"
  15.329      using type_definition.Rep [OF type]
  15.330      by (simp add: emb_beta)
  15.331    have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x"
  15.332      unfolding prj_beta
  15.333 -    apply (simp add: cast_fixed [OF emb_in_deflation])
  15.334 +    apply (simp add: cast_fixed [OF emb_in_sfp])
  15.335      apply (simp add: emb_beta type_definition.Rep_inverse [OF type])
  15.336      done
  15.337    have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y"
  15.338      unfolding prj_beta emb_beta
  15.339      by (simp add: type_definition.Abs_inverse [OF type])
  15.340 -  show "REP('a) = t"
  15.341 -    apply (rule cast_eq_imp_eq, rule ext_cfun)
  15.342 -    apply (simp add: cast_REP emb_prj)
  15.343 +  show "ep_pair (emb :: 'a \<rightarrow> udom) prj"
  15.344 +    apply default
  15.345 +    apply (simp add: prj_emb)
  15.346 +    apply (simp add: emb_prj cast.below)
  15.347      done
  15.348 +  show "cast\<cdot>SFP('a) = emb oo (prj :: udom \<rightarrow> 'a)"
  15.349 +    by (rule ext_cfun, simp add: sfp emb_prj)
  15.350  qed
  15.351  
  15.352 -lemma adm_mem_Collect_in_deflation: "adm (\<lambda>x. x \<in> {x. x ::: A})"
  15.353 -unfolding mem_Collect_eq by (rule adm_in_deflation)
  15.354 +lemma typedef_SFP:
  15.355 +  assumes "sfp \<equiv> (\<lambda>a::'a::pcpo itself. t)"
  15.356 +  shows "SFP('a::pcpo) = t"
  15.357 +unfolding assms ..
  15.358 +
  15.359 +text {* Restore original typing constraints *}
  15.360 +
  15.361 +setup {* Sign.add_const_constraint
  15.362 +  (@{const_name sfp}, SOME @{typ "'a::sfp itself \<Rightarrow> sfp"}) *}
  15.363 +
  15.364 +setup {* Sign.add_const_constraint
  15.365 +  (@{const_name emb}, SOME @{typ "'a::sfp \<rightarrow> udom"}) *}
  15.366 +
  15.367 +setup {* Sign.add_const_constraint
  15.368 +  (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::sfp"}) *}
  15.369 +
  15.370 +lemma adm_mem_Collect_in_sfp: "adm (\<lambda>x. x \<in> {x. x ::: A})"
  15.371 +unfolding mem_Collect_eq by (rule adm_in_sfp)
  15.372  
  15.373  use "Tools/repdef.ML"
  15.374  
  15.375 -
  15.376 -subsection {* Instances of class \emph{rep} *}
  15.377 -
  15.378 -subsubsection {* Universal Domain *}
  15.379 -
  15.380 -text "The Universal Domain itself is trivially representable."
  15.381 -
  15.382 -instantiation udom :: rep
  15.383 -begin
  15.384 -
  15.385 -definition emb_udom_def [simp]: "emb = (ID :: udom \<rightarrow> udom)"
  15.386 -definition prj_udom_def [simp]: "prj = (ID :: udom \<rightarrow> udom)"
  15.387 -
  15.388 -instance
  15.389 - apply (intro_classes)
  15.390 - apply (simp_all add: ep_pair.intro)
  15.391 -done
  15.392 -
  15.393 -end
  15.394 -
  15.395 -subsubsection {* Lifted types *}
  15.396 -
  15.397 -instantiation lift :: (countable) rep
  15.398 -begin
  15.399 -
  15.400 -definition emb_lift_def:
  15.401 -  "emb = udom_emb oo (FLIFT x. Def (to_nat x))"
  15.402 -
  15.403 -definition prj_lift_def:
  15.404 -  "prj = (FLIFT n. if (\<exists>x::'a::countable. n = to_nat x)
  15.405 -                    then Def (THE x::'a. n = to_nat x) else \<bottom>) oo udom_prj"
  15.406 -
  15.407 -instance
  15.408 - apply (intro_classes, unfold emb_lift_def prj_lift_def)
  15.409 - apply (rule ep_pair_comp [OF _ ep_pair_udom])
  15.410 - apply (rule ep_pair.intro)
  15.411 -  apply (case_tac x, simp, simp)
  15.412 - apply (case_tac y, simp, clarsimp)
  15.413 -done
  15.414 -
  15.415 -end
  15.416 -
  15.417 -subsubsection {* Representable type constructors *}
  15.418 -
  15.419 -text "Functions between representable types are representable."
  15.420 -
  15.421 -instantiation cfun :: (rep, rep) rep
  15.422 -begin
  15.423 -
  15.424 -definition emb_cfun_def: "emb = udom_emb oo cfun_map\<cdot>prj\<cdot>emb"
  15.425 -definition prj_cfun_def: "prj = cfun_map\<cdot>emb\<cdot>prj oo udom_prj"
  15.426 -
  15.427 -instance
  15.428 - apply (intro_classes, unfold emb_cfun_def prj_cfun_def)
  15.429 - apply (intro ep_pair_comp ep_pair_cfun_map ep_pair_emb_prj ep_pair_udom)
  15.430 -done
  15.431 -
  15.432 -end
  15.433 -
  15.434 -text "Strict products of representable types are representable."
  15.435 -
  15.436 -instantiation sprod :: (rep, rep) rep
  15.437 -begin
  15.438 -
  15.439 -definition emb_sprod_def: "emb = udom_emb oo sprod_map\<cdot>emb\<cdot>emb"
  15.440 -definition prj_sprod_def: "prj = sprod_map\<cdot>prj\<cdot>prj oo udom_prj"
  15.441 -
  15.442 -instance
  15.443 - apply (intro_classes, unfold emb_sprod_def prj_sprod_def)
  15.444 - apply (intro ep_pair_comp ep_pair_sprod_map ep_pair_emb_prj ep_pair_udom)
  15.445 -done
  15.446 -
  15.447 -end
  15.448 -
  15.449 -text "Strict sums of representable types are representable."
  15.450 -
  15.451 -instantiation ssum :: (rep, rep) rep
  15.452 -begin
  15.453 -
  15.454 -definition emb_ssum_def: "emb = udom_emb oo ssum_map\<cdot>emb\<cdot>emb"
  15.455 -definition prj_ssum_def: "prj = ssum_map\<cdot>prj\<cdot>prj oo udom_prj"
  15.456 -
  15.457 -instance
  15.458 - apply (intro_classes, unfold emb_ssum_def prj_ssum_def)
  15.459 - apply (intro ep_pair_comp ep_pair_ssum_map ep_pair_emb_prj ep_pair_udom)
  15.460 -done
  15.461 -
  15.462 -end
  15.463 -
  15.464 -text "Up of a representable type is representable."
  15.465 -
  15.466 -instantiation "u" :: (rep) rep
  15.467 -begin
  15.468 -
  15.469 -definition emb_u_def: "emb = udom_emb oo u_map\<cdot>emb"
  15.470 -definition prj_u_def: "prj = u_map\<cdot>prj oo udom_prj"
  15.471 -
  15.472 -instance
  15.473 - apply (intro_classes, unfold emb_u_def prj_u_def)
  15.474 - apply (intro ep_pair_comp ep_pair_u_map ep_pair_emb_prj ep_pair_udom)
  15.475 -done
  15.476 -
  15.477 -end
  15.478 -
  15.479 -text "Cartesian products of representable types are representable."
  15.480 -
  15.481 -instantiation prod :: (rep, rep) rep
  15.482 -begin
  15.483 -
  15.484 -definition emb_cprod_def: "emb = udom_emb oo cprod_map\<cdot>emb\<cdot>emb"
  15.485 -definition prj_cprod_def: "prj = cprod_map\<cdot>prj\<cdot>prj oo udom_prj"
  15.486 -
  15.487 -instance
  15.488 - apply (intro_classes, unfold emb_cprod_def prj_cprod_def)
  15.489 - apply (intro ep_pair_comp ep_pair_cprod_map ep_pair_emb_prj ep_pair_udom)
  15.490 -done
  15.491 -
  15.492 -end
  15.493 -
  15.494 -subsection {* Type combinators *}
  15.495 -
  15.496 -definition
  15.497 -  TypeRep_fun1 ::
  15.498 -    "((udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a))
  15.499 -      \<Rightarrow> (TypeRep \<rightarrow> TypeRep)"
  15.500 -where
  15.501 -  "TypeRep_fun1 f =
  15.502 -    alg_defl.basis_fun (\<lambda>a.
  15.503 -      alg_defl_principal (
  15.504 -        Abs_fin_defl (udom_emb oo f\<cdot>(Rep_fin_defl a) oo udom_prj)))"
  15.505 -
  15.506 -definition
  15.507 -  TypeRep_fun2 ::
  15.508 -    "((udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a))
  15.509 -      \<Rightarrow> (TypeRep \<rightarrow> TypeRep \<rightarrow> TypeRep)"
  15.510 -where
  15.511 -  "TypeRep_fun2 f =
  15.512 -    alg_defl.basis_fun (\<lambda>a.
  15.513 -      alg_defl.basis_fun (\<lambda>b.
  15.514 -        alg_defl_principal (
  15.515 -          Abs_fin_defl (udom_emb oo
  15.516 -            f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj))))"
  15.517 -
  15.518 -definition "cfun_defl = TypeRep_fun2 cfun_map"
  15.519 -definition "ssum_defl = TypeRep_fun2 ssum_map"
  15.520 -definition "sprod_defl = TypeRep_fun2 sprod_map"
  15.521 -definition "cprod_defl = TypeRep_fun2 cprod_map"
  15.522 -definition "u_defl = TypeRep_fun1 u_map"
  15.523 -
  15.524 -lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
  15.525 -unfolding below_fin_defl_def .
  15.526 -
  15.527 -lemma cast_TypeRep_fun1:
  15.528 -  assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
  15.529 -  shows "cast\<cdot>(TypeRep_fun1 f\<cdot>A) = udom_emb oo f\<cdot>(cast\<cdot>A) oo udom_prj"
  15.530 -proof -
  15.531 -  have 1: "\<And>a. finite_deflation (udom_emb oo f\<cdot>(Rep_fin_defl a) oo udom_prj)"
  15.532 -    apply (rule ep_pair.finite_deflation_e_d_p [OF ep_pair_udom])
  15.533 -    apply (rule f, rule finite_deflation_Rep_fin_defl)
  15.534 -    done
  15.535 -  show ?thesis
  15.536 -    by (induct A rule: alg_defl.principal_induct, simp)
  15.537 -       (simp only: TypeRep_fun1_def
  15.538 -                   alg_defl.basis_fun_principal
  15.539 -                   alg_defl.basis_fun_mono
  15.540 -                   alg_defl.principal_mono
  15.541 -                   Abs_fin_defl_mono [OF 1 1]
  15.542 -                   monofun_cfun below_refl
  15.543 -                   Rep_fin_defl_mono
  15.544 -                   cast_alg_defl_principal
  15.545 -                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
  15.546 -qed
  15.547 -
  15.548 -lemma cast_TypeRep_fun2:
  15.549 -  assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
  15.550 -                finite_deflation (f\<cdot>a\<cdot>b)"
  15.551 -  shows "cast\<cdot>(TypeRep_fun2 f\<cdot>A\<cdot>B) =
  15.552 -    udom_emb oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
  15.553 -proof -
  15.554 -  have 1: "\<And>a b. finite_deflation
  15.555 -           (udom_emb oo f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj)"
  15.556 -    apply (rule ep_pair.finite_deflation_e_d_p [OF ep_pair_udom])
  15.557 -    apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
  15.558 -    done
  15.559 -  show ?thesis
  15.560 -    by (induct A B rule: alg_defl.principal_induct2, simp, simp)
  15.561 -       (simp only: TypeRep_fun2_def
  15.562 -                   alg_defl.basis_fun_principal
  15.563 -                   alg_defl.basis_fun_mono
  15.564 -                   alg_defl.principal_mono
  15.565 -                   Abs_fin_defl_mono [OF 1 1]
  15.566 -                   monofun_cfun below_refl
  15.567 -                   Rep_fin_defl_mono
  15.568 -                   cast_alg_defl_principal
  15.569 -                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
  15.570 -qed
  15.571 -
  15.572 -lemma cast_cfun_defl:
  15.573 -  "cast\<cdot>(cfun_defl\<cdot>A\<cdot>B) = udom_emb oo cfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
  15.574 -unfolding cfun_defl_def
  15.575 -apply (rule cast_TypeRep_fun2)
  15.576 -apply (erule (1) finite_deflation_cfun_map)
  15.577 -done
  15.578 -
  15.579 -lemma cast_ssum_defl:
  15.580 -  "cast\<cdot>(ssum_defl\<cdot>A\<cdot>B) = udom_emb oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
  15.581 -unfolding ssum_defl_def
  15.582 -apply (rule cast_TypeRep_fun2)
  15.583 -apply (erule (1) finite_deflation_ssum_map)
  15.584 -done
  15.585 -
  15.586 -lemma cast_sprod_defl:
  15.587 -  "cast\<cdot>(sprod_defl\<cdot>A\<cdot>B) = udom_emb oo sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
  15.588 -unfolding sprod_defl_def
  15.589 -apply (rule cast_TypeRep_fun2)
  15.590 -apply (erule (1) finite_deflation_sprod_map)
  15.591 -done
  15.592 -
  15.593 -lemma cast_cprod_defl:
  15.594 -  "cast\<cdot>(cprod_defl\<cdot>A\<cdot>B) = udom_emb oo cprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
  15.595 -unfolding cprod_defl_def
  15.596 -apply (rule cast_TypeRep_fun2)
  15.597 -apply (erule (1) finite_deflation_cprod_map)
  15.598 -done
  15.599 -
  15.600 -lemma cast_u_defl:
  15.601 -  "cast\<cdot>(u_defl\<cdot>A) = udom_emb oo u_map\<cdot>(cast\<cdot>A) oo udom_prj"
  15.602 -unfolding u_defl_def
  15.603 -apply (rule cast_TypeRep_fun1)
  15.604 -apply (erule finite_deflation_u_map)
  15.605 -done
  15.606 -
  15.607 -text {* REP of type constructor = type combinator *}
  15.608 -
  15.609 -lemma REP_cfun: "REP('a \<rightarrow> 'b) = cfun_defl\<cdot>REP('a)\<cdot>REP('b)"
  15.610 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  15.611 -apply (simp add: cast_REP cast_cfun_defl)
  15.612 -apply (simp add: cfun_map_def)
  15.613 -apply (simp only: prj_cfun_def emb_cfun_def)
  15.614 -apply (simp add: expand_cfun_eq ep_pair.e_eq_iff [OF ep_pair_udom])
  15.615 -done
  15.616 -
  15.617 -lemma REP_ssum: "REP('a \<oplus> 'b) = ssum_defl\<cdot>REP('a)\<cdot>REP('b)"
  15.618 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  15.619 -apply (simp add: cast_REP cast_ssum_defl)
  15.620 -apply (simp add: prj_ssum_def)
  15.621 -apply (simp add: emb_ssum_def)
  15.622 -apply (simp add: ssum_map_map cfcomp1)
  15.623 -done
  15.624 -
  15.625 -lemma REP_sprod: "REP('a \<otimes> 'b) = sprod_defl\<cdot>REP('a)\<cdot>REP('b)"
  15.626 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  15.627 -apply (simp add: cast_REP cast_sprod_defl)
  15.628 -apply (simp add: prj_sprod_def)
  15.629 -apply (simp add: emb_sprod_def)
  15.630 -apply (simp add: sprod_map_map cfcomp1)
  15.631 -done
  15.632 -
  15.633 -lemma REP_cprod: "REP('a \<times> 'b) = cprod_defl\<cdot>REP('a)\<cdot>REP('b)"
  15.634 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  15.635 -apply (simp add: cast_REP cast_cprod_defl)
  15.636 -apply (simp add: prj_cprod_def)
  15.637 -apply (simp add: emb_cprod_def)
  15.638 -apply (simp add: cprod_map_map cfcomp1)
  15.639 -done
  15.640 -
  15.641 -lemma REP_up: "REP('a u) = u_defl\<cdot>REP('a)"
  15.642 -apply (rule cast_eq_imp_eq, rule ext_cfun)
  15.643 -apply (simp add: cast_REP cast_u_defl)
  15.644 -apply (simp add: prj_u_def)
  15.645 -apply (simp add: emb_u_def)
  15.646 -apply (simp add: u_map_map cfcomp1)
  15.647 -done
  15.648 -
  15.649 -lemmas REP_simps =
  15.650 -  REP_cfun
  15.651 -  REP_ssum
  15.652 -  REP_sprod
  15.653 -  REP_cprod
  15.654 -  REP_up
  15.655 -
  15.656  subsection {* Isomorphic deflations *}
  15.657  
  15.658  definition
  15.659 -  isodefl :: "('a::rep \<rightarrow> 'a) \<Rightarrow> udom alg_defl \<Rightarrow> bool"
  15.660 +  isodefl :: "('a::sfp \<rightarrow> 'a) \<Rightarrow> sfp \<Rightarrow> bool"
  15.661  where
  15.662    "isodefl d t \<longleftrightarrow> cast\<cdot>t = emb oo d oo prj"
  15.663  
  15.664 @@ -640,10 +211,10 @@
  15.665  by (drule cfun_fun_cong [where x="\<bottom>"], simp)
  15.666  
  15.667  lemma isodefl_imp_deflation:
  15.668 -  fixes d :: "'a::rep \<rightarrow> 'a"
  15.669 +  fixes d :: "'a::sfp \<rightarrow> 'a"
  15.670    assumes "isodefl d t" shows "deflation d"
  15.671  proof
  15.672 -  note prems [unfolded isodefl_def, simp]
  15.673 +  note assms [unfolded isodefl_def, simp]
  15.674    fix x :: 'a
  15.675    show "d\<cdot>(d\<cdot>x) = d\<cdot>x"
  15.676      using cast.idem [of t "emb\<cdot>x"] by simp
  15.677 @@ -651,12 +222,12 @@
  15.678      using cast.below [of t "emb\<cdot>x"] by simp
  15.679  qed
  15.680  
  15.681 -lemma isodefl_ID_REP: "isodefl (ID :: 'a \<rightarrow> 'a) REP('a)"
  15.682 -unfolding isodefl_def by (simp add: cast_REP)
  15.683 +lemma isodefl_ID_SFP: "isodefl (ID :: 'a \<rightarrow> 'a) SFP('a)"
  15.684 +unfolding isodefl_def by (simp add: cast_SFP)
  15.685  
  15.686 -lemma isodefl_REP_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) REP('a) \<Longrightarrow> d = ID"
  15.687 +lemma isodefl_SFP_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) SFP('a) \<Longrightarrow> d = ID"
  15.688  unfolding isodefl_def
  15.689 -apply (simp add: cast_REP)
  15.690 +apply (simp add: cast_SFP)
  15.691  apply (simp add: expand_cfun_eq)
  15.692  apply (rule allI)
  15.693  apply (drule_tac x="emb\<cdot>x" in spec)
  15.694 @@ -684,66 +255,66 @@
  15.695  apply (rule isodefl_lub, simp, simp)
  15.696  apply (induct_tac i)
  15.697  apply (simp add: isodefl_bottom)
  15.698 -apply (simp add: prems)
  15.699 +apply (simp add: assms)
  15.700  done
  15.701  
  15.702  lemma isodefl_coerce:
  15.703    fixes d :: "'a \<rightarrow> 'a"
  15.704 -  assumes REP: "REP('b) = REP('a)"
  15.705 +  assumes SFP: "SFP('b) = SFP('a)"
  15.706    shows "isodefl d t \<Longrightarrow> isodefl (coerce oo d oo coerce :: 'b \<rightarrow> 'b) t"
  15.707  unfolding isodefl_def
  15.708  apply (simp add: expand_cfun_eq)
  15.709 -apply (simp add: emb_coerce coerce_prj REP)
  15.710 +apply (simp add: emb_coerce coerce_prj SFP)
  15.711  done
  15.712  
  15.713  lemma isodefl_abs_rep:
  15.714    fixes abs and rep and d
  15.715 -  assumes REP: "REP('b) = REP('a)"
  15.716 +  assumes SFP: "SFP('b) = SFP('a)"
  15.717    assumes abs_def: "abs \<equiv> (coerce :: 'a \<rightarrow> 'b)"
  15.718    assumes rep_def: "rep \<equiv> (coerce :: 'b \<rightarrow> 'a)"
  15.719    shows "isodefl d t \<Longrightarrow> isodefl (abs oo d oo rep) t"
  15.720 -unfolding abs_def rep_def using REP by (rule isodefl_coerce)
  15.721 +unfolding abs_def rep_def using SFP by (rule isodefl_coerce)
  15.722  
  15.723  lemma isodefl_cfun:
  15.724    "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  15.725 -    isodefl (cfun_map\<cdot>d1\<cdot>d2) (cfun_defl\<cdot>t1\<cdot>t2)"
  15.726 +    isodefl (cfun_map\<cdot>d1\<cdot>d2) (cfun_sfp\<cdot>t1\<cdot>t2)"
  15.727  apply (rule isodeflI)
  15.728 -apply (simp add: cast_cfun_defl cast_isodefl)
  15.729 +apply (simp add: cast_cfun_sfp cast_isodefl)
  15.730  apply (simp add: emb_cfun_def prj_cfun_def)
  15.731  apply (simp add: cfun_map_map cfcomp1)
  15.732  done
  15.733  
  15.734  lemma isodefl_ssum:
  15.735    "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  15.736 -    isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_defl\<cdot>t1\<cdot>t2)"
  15.737 +    isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_sfp\<cdot>t1\<cdot>t2)"
  15.738  apply (rule isodeflI)
  15.739 -apply (simp add: cast_ssum_defl cast_isodefl)
  15.740 +apply (simp add: cast_ssum_sfp cast_isodefl)
  15.741  apply (simp add: emb_ssum_def prj_ssum_def)
  15.742  apply (simp add: ssum_map_map isodefl_strict)
  15.743  done
  15.744  
  15.745  lemma isodefl_sprod:
  15.746    "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  15.747 -    isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_defl\<cdot>t1\<cdot>t2)"
  15.748 +    isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_sfp\<cdot>t1\<cdot>t2)"
  15.749  apply (rule isodeflI)
  15.750 -apply (simp add: cast_sprod_defl cast_isodefl)
  15.751 +apply (simp add: cast_sprod_sfp cast_isodefl)
  15.752  apply (simp add: emb_sprod_def prj_sprod_def)
  15.753  apply (simp add: sprod_map_map isodefl_strict)
  15.754  done
  15.755  
  15.756  lemma isodefl_cprod:
  15.757    "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  15.758 -    isodefl (cprod_map\<cdot>d1\<cdot>d2) (cprod_defl\<cdot>t1\<cdot>t2)"
  15.759 +    isodefl (cprod_map\<cdot>d1\<cdot>d2) (prod_sfp\<cdot>t1\<cdot>t2)"
  15.760  apply (rule isodeflI)
  15.761 -apply (simp add: cast_cprod_defl cast_isodefl)
  15.762 -apply (simp add: emb_cprod_def prj_cprod_def)
  15.763 +apply (simp add: cast_prod_sfp cast_isodefl)
  15.764 +apply (simp add: emb_prod_def prj_prod_def)
  15.765  apply (simp add: cprod_map_map cfcomp1)
  15.766  done
  15.767  
  15.768  lemma isodefl_u:
  15.769 -  "isodefl d t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_defl\<cdot>t)"
  15.770 +  "isodefl d t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_sfp\<cdot>t)"
  15.771  apply (rule isodeflI)
  15.772 -apply (simp add: cast_u_defl cast_isodefl)
  15.773 +apply (simp add: cast_u_sfp cast_isodefl)
  15.774  apply (simp add: emb_u_def prj_u_def)
  15.775  apply (simp add: u_map_map)
  15.776  done
  15.777 @@ -754,19 +325,19 @@
  15.778  
  15.779  setup {*
  15.780    fold Domain_Isomorphism.add_type_constructor
  15.781 -    [(@{type_name cfun}, @{term cfun_defl}, @{const_name cfun_map}, @{thm REP_cfun},
  15.782 +    [(@{type_name cfun}, @{term cfun_sfp}, @{const_name cfun_map}, @{thm SFP_cfun},
  15.783          @{thm isodefl_cfun}, @{thm cfun_map_ID}, @{thm deflation_cfun_map}),
  15.784  
  15.785 -     (@{type_name ssum}, @{term ssum_defl}, @{const_name ssum_map}, @{thm REP_ssum},
  15.786 +     (@{type_name ssum}, @{term ssum_sfp}, @{const_name ssum_map}, @{thm SFP_ssum},
  15.787          @{thm isodefl_ssum}, @{thm ssum_map_ID}, @{thm deflation_ssum_map}),
  15.788  
  15.789 -     (@{type_name sprod}, @{term sprod_defl}, @{const_name sprod_map}, @{thm REP_sprod},
  15.790 +     (@{type_name sprod}, @{term sprod_sfp}, @{const_name sprod_map}, @{thm SFP_sprod},
  15.791          @{thm isodefl_sprod}, @{thm sprod_map_ID}, @{thm deflation_sprod_map}),
  15.792  
  15.793 -     (@{type_name prod}, @{term cprod_defl}, @{const_name cprod_map}, @{thm REP_cprod},
  15.794 +     (@{type_name prod}, @{term cprod_sfp}, @{const_name cprod_map}, @{thm SFP_prod},
  15.795          @{thm isodefl_cprod}, @{thm cprod_map_ID}, @{thm deflation_cprod_map}),
  15.796  
  15.797 -     (@{type_name "u"}, @{term u_defl}, @{const_name u_map}, @{thm REP_up},
  15.798 +     (@{type_name "u"}, @{term u_sfp}, @{const_name u_map}, @{thm SFP_u},
  15.799          @{thm isodefl_u}, @{thm u_map_ID}, @{thm deflation_u_map})]
  15.800  *}
  15.801  
    16.1 --- a/src/HOLCF/Sprod.thy	Tue Oct 05 17:53:00 2010 -0700
    16.2 +++ b/src/HOLCF/Sprod.thy	Wed Oct 06 10:49:27 2010 -0700
    16.3 @@ -5,7 +5,7 @@
    16.4  header {* The type of strict products *}
    16.5  
    16.6  theory Sprod
    16.7 -imports Bifinite
    16.8 +imports Algebraic
    16.9  begin
   16.10  
   16.11  default_sort pcpo
   16.12 @@ -310,37 +310,66 @@
   16.13      by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
   16.14  qed
   16.15  
   16.16 -subsection {* Strict product is a bifinite domain *}
   16.17 +subsection {* Strict product is an SFP domain *}
   16.18 +
   16.19 +definition
   16.20 +  sprod_approx :: "nat \<Rightarrow> udom \<otimes> udom \<rightarrow> udom \<otimes> udom"
   16.21 +where
   16.22 +  "sprod_approx = (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
   16.23  
   16.24 -instantiation sprod :: (bifinite, bifinite) bifinite
   16.25 +lemma sprod_approx: "approx_chain sprod_approx"
   16.26 +proof (rule approx_chain.intro)
   16.27 +  show "chain (\<lambda>i. sprod_approx i)"
   16.28 +    unfolding sprod_approx_def by simp
   16.29 +  show "(\<Squnion>i. sprod_approx i) = ID"
   16.30 +    unfolding sprod_approx_def
   16.31 +    by (simp add: lub_distribs sprod_map_ID)
   16.32 +  show "\<And>i. finite_deflation (sprod_approx i)"
   16.33 +    unfolding sprod_approx_def
   16.34 +    by (intro finite_deflation_sprod_map finite_deflation_udom_approx)
   16.35 +qed
   16.36 +
   16.37 +definition sprod_sfp :: "sfp \<rightarrow> sfp \<rightarrow> sfp"
   16.38 +where "sprod_sfp = sfp_fun2 sprod_approx sprod_map"
   16.39 +
   16.40 +lemma cast_sprod_sfp:
   16.41 +  "cast\<cdot>(sprod_sfp\<cdot>A\<cdot>B) =
   16.42 +    udom_emb sprod_approx oo
   16.43 +      sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo
   16.44 +        udom_prj sprod_approx"
   16.45 +unfolding sprod_sfp_def
   16.46 +apply (rule cast_sfp_fun2 [OF sprod_approx])
   16.47 +apply (erule (1) finite_deflation_sprod_map)
   16.48 +done
   16.49 +
   16.50 +instantiation sprod :: (sfp, sfp) sfp
   16.51  begin
   16.52  
   16.53  definition
   16.54 -  approx_sprod_def:
   16.55 -    "approx = (\<lambda>n. sprod_map\<cdot>(approx n)\<cdot>(approx n))"
   16.56 +  "emb = udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb"
   16.57 +
   16.58 +definition
   16.59 +  "prj = sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx"
   16.60 +
   16.61 +definition
   16.62 +  "sfp (t::('a \<otimes> 'b) itself) = sprod_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
   16.63  
   16.64  instance proof
   16.65 -  fix i :: nat and x :: "'a \<otimes> 'b"
   16.66 -  show "chain (approx :: nat \<Rightarrow> 'a \<otimes> 'b \<rightarrow> 'a \<otimes> 'b)"
   16.67 -    unfolding approx_sprod_def by simp
   16.68 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   16.69 -    unfolding approx_sprod_def sprod_map_def
   16.70 -    by (simp add: lub_distribs eta_cfun)
   16.71 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   16.72 -    unfolding approx_sprod_def sprod_map_def
   16.73 -    by (simp add: ssplit_def strictify_conv_if)
   16.74 -  show "finite {x::'a \<otimes> 'b. approx i\<cdot>x = x}"
   16.75 -    unfolding approx_sprod_def
   16.76 -    by (intro finite_deflation.finite_fixes
   16.77 -              finite_deflation_sprod_map
   16.78 -              finite_deflation_approx)
   16.79 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
   16.80 +    unfolding emb_sprod_def prj_sprod_def
   16.81 +    using ep_pair_udom [OF sprod_approx]
   16.82 +    by (intro ep_pair_comp ep_pair_sprod_map ep_pair_emb_prj)
   16.83 +next
   16.84 +  show "cast\<cdot>SFP('a \<otimes> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
   16.85 +    unfolding emb_sprod_def prj_sprod_def sfp_sprod_def cast_sprod_sfp
   16.86 +    by (simp add: cast_SFP oo_def expand_cfun_eq sprod_map_map)
   16.87  qed
   16.88  
   16.89  end
   16.90  
   16.91 -lemma approx_spair [simp]:
   16.92 -  "approx i\<cdot>(:x, y:) = (:approx i\<cdot>x, approx i\<cdot>y:)"
   16.93 -unfolding approx_sprod_def sprod_map_def
   16.94 -by (simp add: ssplit_def strictify_conv_if)
   16.95 +text {* SFP of type constructor = type combinator *}
   16.96 +
   16.97 +lemma SFP_sprod: "SFP('a::sfp \<otimes> 'b::sfp) = sprod_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
   16.98 +by (rule sfp_sprod_def)
   16.99  
  16.100  end
    17.1 --- a/src/HOLCF/Ssum.thy	Tue Oct 05 17:53:00 2010 -0700
    17.2 +++ b/src/HOLCF/Ssum.thy	Wed Oct 06 10:49:27 2010 -0700
    17.3 @@ -295,37 +295,64 @@
    17.4      by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
    17.5  qed
    17.6  
    17.7 -subsection {* Strict sum is a bifinite domain *}
    17.8 +subsection {* Strict sum is an SFP domain *}
    17.9 +
   17.10 +definition
   17.11 +  ssum_approx :: "nat \<Rightarrow> udom \<oplus> udom \<rightarrow> udom \<oplus> udom"
   17.12 +where
   17.13 +  "ssum_approx = (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
   17.14  
   17.15 -instantiation ssum :: (bifinite, bifinite) bifinite
   17.16 +lemma ssum_approx: "approx_chain ssum_approx"
   17.17 +proof (rule approx_chain.intro)
   17.18 +  show "chain (\<lambda>i. ssum_approx i)"
   17.19 +    unfolding ssum_approx_def by simp
   17.20 +  show "(\<Squnion>i. ssum_approx i) = ID"
   17.21 +    unfolding ssum_approx_def
   17.22 +    by (simp add: lub_distribs ssum_map_ID)
   17.23 +  show "\<And>i. finite_deflation (ssum_approx i)"
   17.24 +    unfolding ssum_approx_def
   17.25 +    by (intro finite_deflation_ssum_map finite_deflation_udom_approx)
   17.26 +qed
   17.27 +
   17.28 +definition ssum_sfp :: "sfp \<rightarrow> sfp \<rightarrow> sfp"
   17.29 +where "ssum_sfp = sfp_fun2 ssum_approx ssum_map"
   17.30 +
   17.31 +lemma cast_ssum_sfp:
   17.32 +  "cast\<cdot>(ssum_sfp\<cdot>A\<cdot>B) =
   17.33 +    udom_emb ssum_approx oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj ssum_approx"
   17.34 +unfolding ssum_sfp_def
   17.35 +apply (rule cast_sfp_fun2 [OF ssum_approx])
   17.36 +apply (erule (1) finite_deflation_ssum_map)
   17.37 +done
   17.38 +
   17.39 +instantiation ssum :: (sfp, sfp) sfp
   17.40  begin
   17.41  
   17.42  definition
   17.43 -  approx_ssum_def:
   17.44 -    "approx = (\<lambda>n. ssum_map\<cdot>(approx n)\<cdot>(approx n))"
   17.45 +  "emb = udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb"
   17.46  
   17.47 -lemma approx_sinl [simp]: "approx i\<cdot>(sinl\<cdot>x) = sinl\<cdot>(approx i\<cdot>x)"
   17.48 -unfolding approx_ssum_def by (cases "x = \<bottom>") simp_all
   17.49 +definition
   17.50 +  "prj = ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx"
   17.51  
   17.52 -lemma approx_sinr [simp]: "approx i\<cdot>(sinr\<cdot>x) = sinr\<cdot>(approx i\<cdot>x)"
   17.53 -unfolding approx_ssum_def by (cases "x = \<bottom>") simp_all
   17.54 +definition
   17.55 +  "sfp (t::('a \<oplus> 'b) itself) = ssum_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
   17.56  
   17.57  instance proof
   17.58 -  fix i :: nat and x :: "'a \<oplus> 'b"
   17.59 -  show "chain (approx :: nat \<Rightarrow> 'a \<oplus> 'b \<rightarrow> 'a \<oplus> 'b)"
   17.60 -    unfolding approx_ssum_def by simp
   17.61 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   17.62 -    unfolding approx_ssum_def
   17.63 -    by (cases x, simp_all add: lub_distribs)
   17.64 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   17.65 -    by (cases x, simp add: approx_ssum_def, simp, simp)
   17.66 -  show "finite {x::'a \<oplus> 'b. approx i\<cdot>x = x}"
   17.67 -    unfolding approx_ssum_def
   17.68 -    by (intro finite_deflation.finite_fixes
   17.69 -              finite_deflation_ssum_map
   17.70 -              finite_deflation_approx)
   17.71 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
   17.72 +    unfolding emb_ssum_def prj_ssum_def
   17.73 +    using ep_pair_udom [OF ssum_approx]
   17.74 +    by (intro ep_pair_comp ep_pair_ssum_map ep_pair_emb_prj)
   17.75 +next
   17.76 +  show "cast\<cdot>SFP('a \<oplus> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
   17.77 +    unfolding emb_ssum_def prj_ssum_def sfp_ssum_def cast_ssum_sfp
   17.78 +    by (simp add: cast_SFP oo_def expand_cfun_eq ssum_map_map)
   17.79  qed
   17.80  
   17.81  end
   17.82  
   17.83 +text {* SFP of type constructor = type combinator *}
   17.84 +
   17.85 +lemma SFP_ssum: "SFP('a::sfp \<oplus> 'b::sfp) = ssum_sfp\<cdot>SFP('a)\<cdot>SFP('b)"
   17.86 +by (rule sfp_ssum_def)
   17.87 +
   17.88  end
    18.1 --- a/src/HOLCF/Tools/Domain/domain_extender.ML	Tue Oct 05 17:53:00 2010 -0700
    18.2 +++ b/src/HOLCF/Tools/Domain/domain_extender.ML	Wed Oct 06 10:49:27 2010 -0700
    18.3 @@ -144,7 +144,7 @@
    18.4  
    18.5      fun thy_type  (dname,tvars,mx) = (dname, length tvars, mx);
    18.6      fun thy_arity (dname,tvars,mx) =
    18.7 -      (Sign.full_name thy dname, map (snd o dest_TFree) tvars, @{sort rep});
    18.8 +      (Sign.full_name thy dname, map (snd o dest_TFree) tvars, arg_sort false);
    18.9  
   18.10      (* this theory is used just for parsing and error checking *)
   18.11      val tmp_thy = thy
   18.12 @@ -213,7 +213,7 @@
   18.13    end;
   18.14  
   18.15  fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo};
   18.16 -fun rep_arg lazy = @{sort rep};
   18.17 +fun rep_arg lazy = @{sort sfp};
   18.18  
   18.19  val add_domain =
   18.20      gen_add_domain Sign.certify_typ Domain_Axioms.add_axioms pcpo_arg;
    19.1 --- a/src/HOLCF/Tools/Domain/domain_isomorphism.ML	Tue Oct 05 17:53:00 2010 -0700
    19.2 +++ b/src/HOLCF/Tools/Domain/domain_isomorphism.ML	Wed Oct 06 10:49:27 2010 -0700
    19.3 @@ -48,7 +48,7 @@
    19.4  
    19.5  structure DeflData = Theory_Data
    19.6  (
    19.7 -  (* terms like "foo_defl" *)
    19.8 +  (* terms like "foo_sfp" *)
    19.9    type T = term Symtab.table;
   19.10    val empty = Symtab.empty;
   19.11    val extend = I;
   19.12 @@ -57,7 +57,7 @@
   19.13  
   19.14  structure RepData = Theory_Data
   19.15  (
   19.16 -  (* theorems like "REP('a foo) = foo_defl$REP('a)" *)
   19.17 +  (* theorems like "SFP('a foo) = foo_sfp$SFP('a)" *)
   19.18    type T = thm list;
   19.19    val empty = [];
   19.20    val extend = I;
   19.21 @@ -83,11 +83,11 @@
   19.22  );
   19.23  
   19.24  fun add_type_constructor
   19.25 -  (tname, defl_const, map_name, REP_thm,
   19.26 +  (tname, defl_const, map_name, SFP_thm,
   19.27     isodefl_thm, map_ID_thm, defl_map_thm) =
   19.28      DeflData.map (Symtab.insert (K true) (tname, defl_const))
   19.29      #> Domain_Take_Proofs.add_map_function (tname, map_name, defl_map_thm)
   19.30 -    #> RepData.map (Thm.add_thm REP_thm)
   19.31 +    #> RepData.map (Thm.add_thm SFP_thm)
   19.32      #> IsodeflData.map (Thm.add_thm isodefl_thm)
   19.33      #> MapIdData.map (Thm.add_thm map_ID_thm);
   19.34  
   19.35 @@ -104,19 +104,19 @@
   19.36  infixr 6 ->>;
   19.37  infix -->>;
   19.38  
   19.39 -val deflT = @{typ "udom alg_defl"};
   19.40 +val sfpT = @{typ "sfp"};
   19.41  
   19.42  fun mapT (T as Type (_, Ts)) =
   19.43      (map (fn T => T ->> T) Ts) -->> (T ->> T)
   19.44    | mapT T = T ->> T;
   19.45  
   19.46 -fun mk_Rep_of T =
   19.47 -  Const (@{const_name Rep_of}, Term.itselfT T --> deflT) $ Logic.mk_type T;
   19.48 +fun mk_SFP T =
   19.49 +  Const (@{const_name sfp}, Term.itselfT T --> sfpT) $ Logic.mk_type T;
   19.50  
   19.51  fun coerce_const T = Const (@{const_name coerce}, T);
   19.52  
   19.53  fun isodefl_const T =
   19.54 -  Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
   19.55 +  Const (@{const_name isodefl}, (T ->> T) --> sfpT --> HOLogic.boolT);
   19.56  
   19.57  fun mk_deflation t =
   19.58    Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
   19.59 @@ -218,13 +218,13 @@
   19.60    let
   19.61      fun is_closed_typ (Type (_, Ts)) = forall is_closed_typ Ts
   19.62        | is_closed_typ _ = false;
   19.63 -    fun defl_of (TFree (a, _)) = Free (Library.unprefix "'" a, deflT)
   19.64 +    fun defl_of (TFree (a, _)) = Free (Library.unprefix "'" a, sfpT)
   19.65        | defl_of (TVar _) = error ("defl_of_typ: TVar")
   19.66        | defl_of (T as Type (c, Ts)) =
   19.67          case Symtab.lookup tab c of
   19.68            SOME t => list_ccomb (t, map defl_of Ts)
   19.69          | NONE => if is_closed_typ T
   19.70 -                  then mk_Rep_of T
   19.71 +                  then mk_SFP T
   19.72                    else error ("defl_of_typ: type variable under unsupported type constructor " ^ c);
   19.73    in defl_of T end;
   19.74  
   19.75 @@ -443,7 +443,7 @@
   19.76      (* declare deflation combinator constants *)
   19.77      fun declare_defl_const (vs, tbind, mx, rhs, morphs) thy =
   19.78        let
   19.79 -        val defl_type = map (K deflT) vs -->> deflT;
   19.80 +        val defl_type = map (K sfpT) vs -->> sfpT;
   19.81          val defl_bind = Binding.suffix_name "_defl" tbind;
   19.82        in
   19.83          Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
   19.84 @@ -470,34 +470,34 @@
   19.85      fun make_repdef ((vs, tbind, mx, _, _), defl_const) thy =
   19.86        let
   19.87          fun tfree a = TFree (a, the (AList.lookup (op =) sorts a))
   19.88 -        val reps = map (mk_Rep_of o tfree) vs;
   19.89 +        val reps = map (mk_SFP o tfree) vs;
   19.90          val defl = list_ccomb (defl_const, reps);
   19.91 -        val ((_, _, _, {REP, ...}), thy) =
   19.92 +        val ((_, _, _, {SFP, ...}), thy) =
   19.93            Repdef.add_repdef false NONE (tbind, map (rpair dummyS) vs, mx) defl NONE thy;
   19.94        in
   19.95 -        (REP, thy)
   19.96 +        (SFP, thy)
   19.97        end;
   19.98 -    val (REP_thms, thy) = fold_map make_repdef (doms ~~ defl_consts) thy;
   19.99 -    val thy = RepData.map (fold Thm.add_thm REP_thms) thy;
  19.100 +    val (SFP_thms, thy) = fold_map make_repdef (doms ~~ defl_consts) thy;
  19.101 +    val thy = RepData.map (fold Thm.add_thm SFP_thms) thy;
  19.102  
  19.103 -    (* prove REP equations *)
  19.104 -    fun mk_REP_eq_thm (lhsT, rhsT) =
  19.105 +    (* prove SFP equations *)
  19.106 +    fun mk_SFP_eq_thm (lhsT, rhsT) =
  19.107        let
  19.108 -        val goal = mk_eqs (mk_Rep_of lhsT, mk_Rep_of rhsT);
  19.109 -        val REP_simps = RepData.get thy;
  19.110 +        val goal = mk_eqs (mk_SFP lhsT, mk_SFP rhsT);
  19.111 +        val SFP_simps = RepData.get thy;
  19.112          val tac =
  19.113 -          rewrite_goals_tac (map mk_meta_eq REP_simps)
  19.114 +          rewrite_goals_tac (map mk_meta_eq SFP_simps)
  19.115            THEN resolve_tac defl_unfold_thms 1;
  19.116        in
  19.117          Goal.prove_global thy [] [] goal (K tac)
  19.118        end;
  19.119 -    val REP_eq_thms = map mk_REP_eq_thm dom_eqns;
  19.120 +    val SFP_eq_thms = map mk_SFP_eq_thm dom_eqns;
  19.121  
  19.122 -    (* register REP equations *)
  19.123 -    val REP_eq_binds = map (Binding.prefix_name "REP_eq_") dbinds;
  19.124 +    (* register SFP equations *)
  19.125 +    val SFP_eq_binds = map (Binding.prefix_name "SFP_eq_") dbinds;
  19.126      val (_, thy) = thy |>
  19.127        (Global_Theory.add_thms o map Thm.no_attributes)
  19.128 -        (REP_eq_binds ~~ REP_eq_thms);
  19.129 +        (SFP_eq_binds ~~ SFP_eq_thms);
  19.130  
  19.131      (* define rep/abs functions *)
  19.132      fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
  19.133 @@ -516,10 +516,10 @@
  19.134        |>> ListPair.unzip;
  19.135  
  19.136      (* prove isomorphism and isodefl rules *)
  19.137 -    fun mk_iso_thms ((tbind, REP_eq), (rep_def, abs_def)) thy =
  19.138 +    fun mk_iso_thms ((tbind, SFP_eq), (rep_def, abs_def)) thy =
  19.139        let
  19.140          fun make thm =
  19.141 -            Drule.zero_var_indexes (thm OF [REP_eq, abs_def, rep_def]);
  19.142 +            Drule.zero_var_indexes (thm OF [SFP_eq, abs_def, rep_def]);
  19.143          val rep_iso_thm = make @{thm domain_rep_iso};
  19.144          val abs_iso_thm = make @{thm domain_abs_iso};
  19.145          val isodefl_thm = make @{thm isodefl_abs_rep};
  19.146 @@ -532,7 +532,7 @@
  19.147        end;
  19.148      val ((iso_thms, isodefl_abs_rep_thms), thy) =
  19.149        thy
  19.150 -      |> fold_map mk_iso_thms (dbinds ~~ REP_eq_thms ~~ rep_abs_defs)
  19.151 +      |> fold_map mk_iso_thms (dbinds ~~ SFP_eq_thms ~~ rep_abs_defs)
  19.152        |>> ListPair.unzip;
  19.153  
  19.154      (* collect info about rep/abs *)
  19.155 @@ -561,7 +561,7 @@
  19.156      val isodefl_thm =
  19.157        let
  19.158          fun unprime a = Library.unprefix "'" a;
  19.159 -        fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
  19.160 +        fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), sfpT);
  19.161          fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
  19.162          fun mk_assm T = mk_trp (isodefl_const T $ mk_f T $ mk_d T);
  19.163          fun mk_goal ((map_const, defl_const), (T, rhsT)) =
  19.164 @@ -579,9 +579,9 @@
  19.165            @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id};
  19.166          val bottom_rules =
  19.167            @{thms fst_strict snd_strict isodefl_bottom simp_thms};
  19.168 -        val REP_simps = map (fn th => th RS sym) (RepData.get thy);
  19.169 +        val SFP_simps = map (fn th => th RS sym) (RepData.get thy);
  19.170          val isodefl_rules =
  19.171 -          @{thms conjI isodefl_ID_REP}
  19.172 +          @{thms conjI isodefl_ID_SFP}
  19.173            @ isodefl_abs_rep_thms
  19.174            @ IsodeflData.get thy;
  19.175        in
  19.176 @@ -595,7 +595,7 @@
  19.177             simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
  19.178             simp_tac beta_ss 1,
  19.179             simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
  19.180 -           simp_tac (HOL_basic_ss addsimps REP_simps) 1,
  19.181 +           simp_tac (HOL_basic_ss addsimps SFP_simps) 1,
  19.182             REPEAT (etac @{thm conjE} 1),
  19.183             REPEAT (resolve_tac (isodefl_rules @ prems) 1 ORELSE atac 1)])
  19.184        end;
  19.185 @@ -613,23 +613,23 @@
  19.186  
  19.187      (* prove map_ID theorems *)
  19.188      fun prove_map_ID_thm
  19.189 -        (((map_const, (lhsT, _)), REP_thm), isodefl_thm) =
  19.190 +        (((map_const, (lhsT, _)), SFP_thm), isodefl_thm) =
  19.191        let
  19.192          val Ts = snd (dest_Type lhsT);
  19.193          val lhs = list_ccomb (map_const, map mk_ID Ts);
  19.194          val goal = mk_eqs (lhs, mk_ID lhsT);
  19.195          val tac = EVERY
  19.196 -          [rtac @{thm isodefl_REP_imp_ID} 1,
  19.197 -           stac REP_thm 1,
  19.198 +          [rtac @{thm isodefl_SFP_imp_ID} 1,
  19.199 +           stac SFP_thm 1,
  19.200             rtac isodefl_thm 1,
  19.201 -           REPEAT (rtac @{thm isodefl_ID_REP} 1)];
  19.202 +           REPEAT (rtac @{thm isodefl_ID_SFP} 1)];
  19.203        in
  19.204          Goal.prove_global thy [] [] goal (K tac)
  19.205        end;
  19.206      val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds;
  19.207      val map_ID_thms =
  19.208        map prove_map_ID_thm
  19.209 -        (map_consts ~~ dom_eqns ~~ REP_thms ~~ isodefl_thms);
  19.210 +        (map_consts ~~ dom_eqns ~~ SFP_thms ~~ isodefl_thms);
  19.211      val (_, thy) = thy |>
  19.212        (Global_Theory.add_thms o map Thm.no_attributes)
  19.213          (map_ID_binds ~~ map_ID_thms);
    20.1 --- a/src/HOLCF/Tools/repdef.ML	Tue Oct 05 17:53:00 2010 -0700
    20.2 +++ b/src/HOLCF/Tools/repdef.ML	Wed Oct 06 10:49:27 2010 -0700
    20.3 @@ -7,7 +7,7 @@
    20.4  signature REPDEF =
    20.5  sig
    20.6    type rep_info =
    20.7 -    { emb_def: thm, prj_def: thm, approx_def: thm, REP: thm }
    20.8 +    { emb_def: thm, prj_def: thm, sfp_def: thm, SFP: thm }
    20.9  
   20.10    val add_repdef: bool -> binding option -> binding * (string * sort) list * mixfix ->
   20.11      term -> (binding * binding) option -> theory ->
   20.12 @@ -28,20 +28,19 @@
   20.13  (** type definitions **)
   20.14  
   20.15  type rep_info =
   20.16 -  { emb_def: thm, prj_def: thm, approx_def: thm, REP: thm };
   20.17 +  { emb_def: thm, prj_def: thm, sfp_def: thm, SFP: thm };
   20.18  
   20.19  (* building types and terms *)
   20.20  
   20.21  val udomT = @{typ udom};
   20.22 -fun alg_deflT T = Type (@{type_name alg_defl}, [T]);
   20.23 +val sfpT = @{typ sfp};
   20.24  fun emb_const T = Const (@{const_name emb}, T ->> udomT);
   20.25  fun prj_const T = Const (@{const_name prj}, udomT ->> T);
   20.26 -fun approx_const T = Const (@{const_name approx}, natT --> (T ->> T));
   20.27 +fun sfp_const T = Const (@{const_name sfp}, Term.itselfT T --> sfpT);
   20.28  
   20.29 -fun cast_const T = Const (@{const_name cast}, alg_deflT T ->> T ->> T);
   20.30  fun mk_cast (t, x) =
   20.31    capply_const (udomT, udomT)
   20.32 -  $ (capply_const (alg_deflT udomT, udomT ->> udomT) $ cast_const udomT $ t)
   20.33 +  $ (capply_const (sfpT, udomT ->> udomT) $ @{const cast} $ t)
   20.34    $ x;
   20.35  
   20.36  (* manipulating theorems *)
   20.37 @@ -71,8 +70,8 @@
   20.38      val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl;
   20.39  
   20.40      val deflT = Term.fastype_of defl;
   20.41 -    val _ = if deflT = @{typ "udom alg_defl"} then ()
   20.42 -            else error ("Not type udom alg_defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
   20.43 +    val _ = if deflT = @{typ "sfp"} then ()
   20.44 +            else error ("Not type sfp: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
   20.45  
   20.46      (*lhs*)
   20.47      val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args;
   20.48 @@ -85,12 +84,12 @@
   20.49        |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
   20.50  
   20.51      (*set*)
   20.52 -    val in_defl = @{term "in_deflation :: udom => udom alg_defl => bool"};
   20.53 +    val in_defl = @{term "in_sfp :: udom => sfp => bool"};
   20.54      val set = HOLogic.Collect_const udomT $ Abs ("x", udomT, in_defl $ Bound 0 $ defl);
   20.55  
   20.56      (*pcpodef*)
   20.57 -    val tac1 = rtac @{thm CollectI} 1 THEN rtac @{thm bottom_in_deflation} 1;
   20.58 -    val tac2 = rtac @{thm adm_mem_Collect_in_deflation} 1;
   20.59 +    val tac1 = rtac @{thm CollectI} 1 THEN rtac @{thm bottom_in_sfp} 1;
   20.60 +    val tac2 = rtac @{thm adm_mem_Collect_in_sfp} 1;
   20.61      val ((info, cpo_info, pcpo_info), thy) = thy
   20.62        |> Pcpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2);
   20.63  
   20.64 @@ -100,52 +99,48 @@
   20.65      val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
   20.66      val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
   20.67        Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
   20.68 -    val repdef_approx_const =
   20.69 -      Const (@{const_name repdef_approx}, (newT --> udomT) --> (udomT --> newT)
   20.70 -        --> alg_deflT udomT --> natT --> (newT ->> newT));
   20.71 -    val approx_eqn = Logic.mk_equals (approx_const newT,
   20.72 -      repdef_approx_const $ Rep_const $ Abs_const $ defl);
   20.73 +    val sfp_eqn = Logic.mk_equals (sfp_const newT,
   20.74 +      Abs ("x", Term.itselfT newT, defl));
   20.75      val name_def = Binding.suffix_name "_def" name;
   20.76      val emb_bind = (Binding.prefix_name "emb_" name_def, []);
   20.77      val prj_bind = (Binding.prefix_name "prj_" name_def, []);
   20.78 -    val approx_bind = (Binding.prefix_name "approx_" name_def, []);
   20.79 +    val sfp_bind = (Binding.prefix_name "sfp_" name_def, []);
   20.80  
   20.81      (*instantiate class rep*)
   20.82      val lthy = thy
   20.83 -      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort rep});
   20.84 +      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort sfp});
   20.85      val ((_, (_, emb_ldef)), lthy) =
   20.86          Specification.definition (NONE, (emb_bind, emb_eqn)) lthy;
   20.87      val ((_, (_, prj_ldef)), lthy) =
   20.88          Specification.definition (NONE, (prj_bind, prj_eqn)) lthy;
   20.89 -    val ((_, (_, approx_ldef)), lthy) =
   20.90 -        Specification.definition (NONE, (approx_bind, approx_eqn)) lthy;
   20.91 +    val ((_, (_, sfp_ldef)), lthy) =
   20.92 +        Specification.definition (NONE, (sfp_bind, sfp_eqn)) lthy;
   20.93      val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy);
   20.94      val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef;
   20.95      val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef;
   20.96 -    val approx_def = singleton (ProofContext.export lthy ctxt_thy) approx_ldef;
   20.97 +    val sfp_def = singleton (ProofContext.export lthy ctxt_thy) sfp_ldef;
   20.98      val type_definition_thm =
   20.99        MetaSimplifier.rewrite_rule
  20.100          (the_list (#set_def (#2 info)))
  20.101          (#type_definition (#2 info));
  20.102      val typedef_thms =
  20.103 -      [type_definition_thm, #below_def cpo_info, emb_def, prj_def, approx_def];
  20.104 +      [type_definition_thm, #below_def cpo_info, emb_def, prj_def, sfp_def];
  20.105      val thy = lthy
  20.106        |> Class.prove_instantiation_instance
  20.107            (K (Tactic.rtac (@{thm typedef_rep_class} OF typedef_thms) 1))
  20.108        |> Local_Theory.exit_global;
  20.109  
  20.110      (*other theorems*)
  20.111 -    val typedef_thms' = map (Thm.transfer thy)
  20.112 -      [type_definition_thm, #below_def cpo_info, emb_def, prj_def];
  20.113 -    val (REP_thm, thy) = thy
  20.114 +    val sfp_thm' = Thm.transfer thy sfp_def;
  20.115 +    val (SFP_thm, thy) = thy
  20.116        |> Sign.add_path (Binding.name_of name)
  20.117        |> Global_Theory.add_thm
  20.118 -         ((Binding.prefix_name "REP_" name,
  20.119 -          Drule.zero_var_indexes (@{thm typedef_REP} OF typedef_thms')), [])
  20.120 +         ((Binding.prefix_name "SFP_" name,
  20.121 +          Drule.zero_var_indexes (@{thm typedef_SFP} OF [sfp_thm'])), [])
  20.122        ||> Sign.restore_naming thy;
  20.123  
  20.124      val rep_info =
  20.125 -      { emb_def = emb_def, prj_def = prj_def, approx_def = approx_def, REP = REP_thm };
  20.126 +      { emb_def = emb_def, prj_def = prj_def, sfp_def = sfp_def, SFP = SFP_thm };
  20.127    in
  20.128      ((info, cpo_info, pcpo_info, rep_info), thy)
  20.129    end
    21.1 --- a/src/HOLCF/Tutorial/New_Domain.thy	Tue Oct 05 17:53:00 2010 -0700
    21.2 +++ b/src/HOLCF/Tutorial/New_Domain.thy	Wed Oct 06 10:49:27 2010 -0700
    21.3 @@ -9,14 +9,14 @@
    21.4  begin
    21.5  
    21.6  text {*
    21.7 -  The definitional domain package only works with representable domains,
    21.8 -  i.e. types in class @{text rep}.
    21.9 +  The definitional domain package only works with SFP domains,
   21.10 +  i.e. types in class @{text sfp}.
   21.11  *}
   21.12  
   21.13 -default_sort rep
   21.14 +default_sort sfp
   21.15  
   21.16  text {*
   21.17 -  Provided that @{text rep} is the default sort, the @{text new_domain}
   21.18 +  Provided that @{text sfp} is the default sort, the @{text new_domain}
   21.19    package should work with any type definition supported by the old
   21.20    domain package.
   21.21  *}
    22.1 --- a/src/HOLCF/Universal.thy	Tue Oct 05 17:53:00 2010 -0700
    22.2 +++ b/src/HOLCF/Universal.thy	Wed Oct 06 10:49:27 2010 -0700
    22.3 @@ -5,10 +5,12 @@
    22.4  header {* A universal bifinite domain *}
    22.5  
    22.6  theory Universal
    22.7 -imports CompactBasis Nat_Bijection
    22.8 +imports Completion Deflation Nat_Bijection
    22.9  begin
   22.10  
   22.11 -subsection {* Basis datatype *}
   22.12 +subsection {* Basis for universal domain *}
   22.13 +
   22.14 +subsubsection {* Basis datatype *}
   22.15  
   22.16  types ubasis = nat
   22.17  
   22.18 @@ -75,7 +77,7 @@
   22.19   apply (simp add: 2 node_gt1 node_gt2)
   22.20  done
   22.21  
   22.22 -subsection {* Basis ordering *}
   22.23 +subsubsection {* Basis ordering *}
   22.24  
   22.25  inductive
   22.26    ubasis_le :: "nat \<Rightarrow> nat \<Rightarrow> bool"
   22.27 @@ -95,6 +97,12 @@
   22.28  apply (erule ubasis_le_lower)
   22.29  done
   22.30  
   22.31 +interpretation udom: preorder ubasis_le
   22.32 +apply default
   22.33 +apply (rule ubasis_le_refl)
   22.34 +apply (erule (1) ubasis_le_trans)
   22.35 +done
   22.36 +
   22.37  subsubsection {* Generic take function *}
   22.38  
   22.39  function
   22.40 @@ -187,66 +195,6 @@
   22.41  apply simp
   22.42  done
   22.43  
   22.44 -subsubsection {* Take function for \emph{ubasis} *}
   22.45 -
   22.46 -definition
   22.47 -  ubasis_take :: "nat \<Rightarrow> ubasis \<Rightarrow> ubasis"
   22.48 -where
   22.49 -  "ubasis_take n = ubasis_until (\<lambda>x. x \<le> n)"
   22.50 -
   22.51 -lemma ubasis_take_le: "ubasis_take n x \<le> n"
   22.52 -unfolding ubasis_take_def by (rule ubasis_until, rule le0)
   22.53 -
   22.54 -lemma ubasis_take_same: "x \<le> n \<Longrightarrow> ubasis_take n x = x"
   22.55 -unfolding ubasis_take_def by (rule ubasis_until_same)
   22.56 -
   22.57 -lemma ubasis_take_idem: "ubasis_take n (ubasis_take n x) = ubasis_take n x"
   22.58 -by (rule ubasis_take_same [OF ubasis_take_le])
   22.59 -
   22.60 -lemma ubasis_take_0 [simp]: "ubasis_take 0 x = 0"
   22.61 -unfolding ubasis_take_def by (simp add: ubasis_until_0)
   22.62 -
   22.63 -lemma ubasis_take_less: "ubasis_le (ubasis_take n x) x"
   22.64 -unfolding ubasis_take_def by (rule ubasis_until_less)
   22.65 -
   22.66 -lemma ubasis_take_chain: "ubasis_le (ubasis_take n x) (ubasis_take (Suc n) x)"
   22.67 -unfolding ubasis_take_def by (rule ubasis_until_chain) simp
   22.68 -
   22.69 -lemma ubasis_take_mono:
   22.70 -  assumes "ubasis_le x y"
   22.71 -  shows "ubasis_le (ubasis_take n x) (ubasis_take n y)"
   22.72 -unfolding ubasis_take_def
   22.73 - apply (rule ubasis_until_mono [OF _ prems])
   22.74 - apply (frule (2) order_less_le_trans [OF node_gt2])
   22.75 - apply (erule order_less_imp_le)
   22.76 -done
   22.77 -
   22.78 -lemma finite_range_ubasis_take: "finite (range (ubasis_take n))"
   22.79 -apply (rule finite_subset [where B="{..n}"])
   22.80 -apply (simp add: subset_eq ubasis_take_le)
   22.81 -apply simp
   22.82 -done
   22.83 -
   22.84 -lemma ubasis_take_covers: "\<exists>n. ubasis_take n x = x"
   22.85 -apply (rule exI [where x=x])
   22.86 -apply (simp add: ubasis_take_same)
   22.87 -done
   22.88 -
   22.89 -interpretation udom: preorder ubasis_le
   22.90 -apply default
   22.91 -apply (rule ubasis_le_refl)
   22.92 -apply (erule (1) ubasis_le_trans)
   22.93 -done
   22.94 -
   22.95 -interpretation udom: basis_take ubasis_le ubasis_take
   22.96 -apply default
   22.97 -apply (rule ubasis_take_less)
   22.98 -apply (rule ubasis_take_idem)
   22.99 -apply (erule ubasis_take_mono)
  22.100 -apply (rule ubasis_take_chain)
  22.101 -apply (rule finite_range_ubasis_take)
  22.102 -apply (rule ubasis_take_covers)
  22.103 -done
  22.104  
  22.105  subsection {* Defining the universal domain by ideal completion *}
  22.106  
  22.107 @@ -263,17 +211,17 @@
  22.108  end
  22.109  
  22.110  instance udom :: po
  22.111 -by (rule udom.typedef_ideal_po
  22.112 -    [OF type_definition_udom below_udom_def])
  22.113 +using type_definition_udom below_udom_def
  22.114 +by (rule udom.typedef_ideal_po)
  22.115  
  22.116  instance udom :: cpo
  22.117 -by (rule udom.typedef_ideal_cpo
  22.118 -    [OF type_definition_udom below_udom_def])
  22.119 +using type_definition_udom below_udom_def
  22.120 +by (rule udom.typedef_ideal_cpo)
  22.121  
  22.122  lemma Rep_udom_lub:
  22.123    "chain Y \<Longrightarrow> Rep_udom (\<Squnion>i. Y i) = (\<Union>i. Rep_udom (Y i))"
  22.124 -by (rule udom.typedef_ideal_rep_contlub
  22.125 -    [OF type_definition_udom below_udom_def])
  22.126 +using type_definition_udom below_udom_def
  22.127 +by (rule udom.typedef_ideal_rep_contlub)
  22.128  
  22.129  lemma ideal_Rep_udom: "udom.ideal (Rep_udom xs)"
  22.130  by (rule Rep_udom [unfolded mem_Collect_eq])
  22.131 @@ -288,12 +236,13 @@
  22.132  by (simp add: Abs_udom_inverse udom.ideal_principal)
  22.133  
  22.134  interpretation udom:
  22.135 -  ideal_completion ubasis_le ubasis_take udom_principal Rep_udom
  22.136 +  ideal_completion ubasis_le udom_principal Rep_udom
  22.137  apply unfold_locales
  22.138  apply (rule ideal_Rep_udom)
  22.139  apply (erule Rep_udom_lub)
  22.140  apply (rule Rep_udom_principal)
  22.141  apply (simp only: below_udom_def)
  22.142 +apply (rule exI, rule inj_on_id)
  22.143  done
  22.144  
  22.145  text {* Universal domain is pointed *}
  22.146 @@ -309,43 +258,60 @@
  22.147  lemma inst_udom_pcpo: "\<bottom> = udom_principal 0"
  22.148  by (rule udom_minimal [THEN UU_I, symmetric])
  22.149  
  22.150 -text {* Universal domain is bifinite *}
  22.151 +
  22.152 +subsection {* Compact bases of domains *}
  22.153  
  22.154 -instantiation udom :: bifinite
  22.155 +typedef (open) 'a compact_basis = "{x::'a::pcpo. compact x}"
  22.156 +by auto
  22.157 +
  22.158 +lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
  22.159 +by (rule Rep_compact_basis [unfolded mem_Collect_eq])
  22.160 +
  22.161 +instantiation compact_basis :: (pcpo) below
  22.162  begin
  22.163  
  22.164  definition
  22.165 -  approx_udom_def: "approx = udom.completion_approx"
  22.166 +  compact_le_def:
  22.167 +    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. Rep_compact_basis x \<sqsubseteq> Rep_compact_basis y)"
  22.168  
  22.169 -instance
  22.170 -apply (intro_classes, unfold approx_udom_def)
  22.171 -apply (rule udom.chain_completion_approx)
  22.172 -apply (rule udom.lub_completion_approx)
  22.173 -apply (rule udom.completion_approx_idem)
  22.174 -apply (rule udom.finite_fixes_completion_approx)
  22.175 -done
  22.176 -
  22.177 +instance ..
  22.178  end
  22.179  
  22.180 -lemma approx_udom_principal [simp]:
  22.181 -  "approx n\<cdot>(udom_principal x) = udom_principal (ubasis_take n x)"
  22.182 -unfolding approx_udom_def
  22.183 -by (rule udom.completion_approx_principal)
  22.184 +instance compact_basis :: (pcpo) po
  22.185 +using type_definition_compact_basis compact_le_def
  22.186 +by (rule typedef_po)
  22.187 +
  22.188 +definition
  22.189 +  approximants :: "'a \<Rightarrow> 'a compact_basis set" where
  22.190 +  "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
  22.191  
  22.192 -lemma approx_eq_udom_principal:
  22.193 -  "\<exists>a\<in>Rep_udom x. approx n\<cdot>x = udom_principal (ubasis_take n a)"
  22.194 -unfolding approx_udom_def
  22.195 -by (rule udom.completion_approx_eq_principal)
  22.196 +definition
  22.197 +  compact_bot :: "'a::pcpo compact_basis" where
  22.198 +  "compact_bot = Abs_compact_basis \<bottom>"
  22.199 +
  22.200 +lemma Rep_compact_bot [simp]: "Rep_compact_basis compact_bot = \<bottom>"
  22.201 +unfolding compact_bot_def by (simp add: Abs_compact_basis_inverse)
  22.202 +
  22.203 +lemma compact_bot_minimal [simp]: "compact_bot \<sqsubseteq> a"
  22.204 +unfolding compact_le_def Rep_compact_bot by simp
  22.205  
  22.206  
  22.207  subsection {* Universality of \emph{udom} *}
  22.208  
  22.209 -default_sort bifinite
  22.210 +text {* We use a locale to parameterize the construction over a chain
  22.211 +of approx functions on the type to be embedded. *}
  22.212 +
  22.213 +locale approx_chain =
  22.214 +  fixes approx :: "nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a"
  22.215 +  assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
  22.216 +  assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
  22.217 +  assumes finite_deflation_approx: "\<And>i. finite_deflation (approx i)"
  22.218 +begin
  22.219  
  22.220  subsubsection {* Choosing a maximal element from a finite set *}
  22.221  
  22.222  lemma finite_has_maximal:
  22.223 -  fixes A :: "'a::po set"
  22.224 +  fixes A :: "'a compact_basis set"
  22.225    shows "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y"
  22.226  proof (induct rule: finite_ne_induct)
  22.227    case (singleton x)
  22.228 @@ -456,43 +422,86 @@
  22.229   apply (simp add: choose_pos.simps)
  22.230  done
  22.231  
  22.232 -subsubsection {* Rank of basis elements *}
  22.233 +subsubsection {* Properties of approx function *}
  22.234 +
  22.235 +lemma deflation_approx: "deflation (approx i)"
  22.236 +using finite_deflation_approx by (rule finite_deflation_imp_deflation)
  22.237 +
  22.238 +lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
  22.239 +using deflation_approx by (rule deflation.idem)
  22.240 +
  22.241 +lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
  22.242 +using deflation_approx by (rule deflation.below)
  22.243 +
  22.244 +lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
  22.245 +apply (rule finite_deflation.finite_range)
  22.246 +apply (rule finite_deflation_approx)
  22.247 +done
  22.248 +
  22.249 +lemma compact_approx: "compact (approx n\<cdot>x)"
  22.250 +apply (rule finite_deflation.compact)
  22.251 +apply (rule finite_deflation_approx)
  22.252 +done
  22.253 +
  22.254 +lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
  22.255 +by (rule admD2, simp_all)
  22.256 +
  22.257 +subsubsection {* Compact basis take function *}
  22.258  
  22.259  primrec
  22.260 -  cb_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis"
  22.261 -where
  22.262 +  cb_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis" where
  22.263    "cb_take 0 = (\<lambda>x. compact_bot)"
  22.264 -| "cb_take (Suc n) = compact_take n"
  22.265 +| "cb_take (Suc n) = (\<lambda>a. Abs_compact_basis (approx n\<cdot>(Rep_compact_basis a)))"
  22.266 +
  22.267 +declare cb_take.simps [simp del]
  22.268 +
  22.269 +lemma cb_take_zero [simp]: "cb_take 0 a = compact_bot"
  22.270 +by (simp only: cb_take.simps)
  22.271 +
  22.272 +lemma Rep_cb_take:
  22.273 +  "Rep_compact_basis (cb_take (Suc n) a) = approx n\<cdot>(Rep_compact_basis a)"
  22.274 +by (simp add: Abs_compact_basis_inverse cb_take.simps(2) compact_approx)
  22.275 +
  22.276 +lemmas approx_Rep_compact_basis = Rep_cb_take [symmetric]
  22.277  
  22.278  lemma cb_take_covers: "\<exists>n. cb_take n x = x"
  22.279 -apply (rule exE [OF compact_basis.take_covers [where a=x]])
  22.280 -apply (rename_tac n, rule_tac x="Suc n" in exI, simp)
  22.281 +apply (subgoal_tac "\<exists>n. cb_take (Suc n) x = x", fast)
  22.282 +apply (simp add: Rep_compact_basis_inject [symmetric])
  22.283 +apply (simp add: Rep_cb_take)
  22.284 +apply (rule compact_eq_approx)
  22.285 +apply (rule compact_Rep_compact_basis)
  22.286  done
  22.287  
  22.288  lemma cb_take_less: "cb_take n x \<sqsubseteq> x"
  22.289 -by (cases n, simp, simp add: compact_basis.take_less)
  22.290 +unfolding compact_le_def
  22.291 +by (cases n, simp, simp add: Rep_cb_take approx_below)
  22.292  
  22.293  lemma cb_take_idem: "cb_take n (cb_take n x) = cb_take n x"
  22.294 -by (cases n, simp, simp add: compact_basis.take_take)
  22.295 +unfolding Rep_compact_basis_inject [symmetric]
  22.296 +by (cases n, simp, simp add: Rep_cb_take approx_idem)
  22.297  
  22.298  lemma cb_take_mono: "x \<sqsubseteq> y \<Longrightarrow> cb_take n x \<sqsubseteq> cb_take n y"
  22.299 -by (cases n, simp, simp add: compact_basis.take_mono)
  22.300 +unfolding compact_le_def
  22.301 +by (cases n, simp, simp add: Rep_cb_take monofun_cfun_arg)
  22.302  
  22.303  lemma cb_take_chain_le: "m \<le> n \<Longrightarrow> cb_take m x \<sqsubseteq> cb_take n x"
  22.304 -apply (cases m, simp)
  22.305 -apply (cases n, simp)
  22.306 -apply (simp add: compact_basis.take_chain_le)
  22.307 +unfolding compact_le_def
  22.308 +apply (cases m, simp, cases n, simp)
  22.309 +apply (simp add: Rep_cb_take, rule chain_mono, simp, simp)
  22.310  done
  22.311  
  22.312 -lemma range_const: "range (\<lambda>x. c) = {c}"
  22.313 -by auto
  22.314 -
  22.315  lemma finite_range_cb_take: "finite (range (cb_take n))"
  22.316  apply (cases n)
  22.317 -apply (simp add: range_const)
  22.318 -apply (simp add: compact_basis.finite_range_take)
  22.319 +apply (subgoal_tac "range (cb_take 0) = {compact_bot}", simp, force)
  22.320 +apply (rule finite_imageD [where f="Rep_compact_basis"])
  22.321 +apply (rule finite_subset [where B="range (\<lambda>x. approx (n - 1)\<cdot>x)"])
  22.322 +apply (clarsimp simp add: Rep_cb_take)
  22.323 +apply (rule finite_range_approx)
  22.324 +apply (rule inj_onI, simp add: Rep_compact_basis_inject)
  22.325  done
  22.326  
  22.327 +subsubsection {* Rank of basis elements *}
  22.328 +
  22.329  definition
  22.330    rank :: "'a compact_basis \<Rightarrow> nat"
  22.331  where
  22.332 @@ -809,22 +818,86 @@
  22.333   apply (rule ubasis_until_less)
  22.334  done
  22.335  
  22.336 -hide_const (open)
  22.337 -  node
  22.338 -  choose
  22.339 -  choose_pos
  22.340 -  place
  22.341 -  sub
  22.342 +end
  22.343 +
  22.344 +sublocale approx_chain \<subseteq> compact_basis!:
  22.345 +  ideal_completion below Rep_compact_basis
  22.346 +    "approximants :: 'a \<Rightarrow> 'a compact_basis set"
  22.347 +proof
  22.348 +  fix w :: "'a"
  22.349 +  show "below.ideal (approximants w)"
  22.350 +  proof (rule below.idealI)
  22.351 +    show "\<exists>x. x \<in> approximants w"
  22.352 +      unfolding approximants_def
  22.353 +      apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
  22.354 +      apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
  22.355 +      done
  22.356 +  next
  22.357 +    fix x y :: "'a compact_basis"
  22.358 +    assume "x \<in> approximants w" "y \<in> approximants w"
  22.359 +    thus "\<exists>z \<in> approximants w. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
  22.360 +      unfolding approximants_def
  22.361 +      apply simp
  22.362 +      apply (cut_tac a=x in compact_Rep_compact_basis)
  22.363 +      apply (cut_tac a=y in compact_Rep_compact_basis)
  22.364 +      apply (drule compact_eq_approx)
  22.365 +      apply (drule compact_eq_approx)
  22.366 +      apply (clarify, rename_tac i j)
  22.367 +      apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
  22.368 +      apply (simp add: compact_le_def)
  22.369 +      apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
  22.370 +      apply (erule subst, erule subst)
  22.371 +      apply (simp add: monofun_cfun chain_mono [OF chain_approx])
  22.372 +      done
  22.373 +  next
  22.374 +    fix x y :: "'a compact_basis"
  22.375 +    assume "x \<sqsubseteq> y" "y \<in> approximants w" thus "x \<in> approximants w"
  22.376 +      unfolding approximants_def
  22.377 +      apply simp
  22.378 +      apply (simp add: compact_le_def)
  22.379 +      apply (erule (1) below_trans)
  22.380 +      done
  22.381 +  qed
  22.382 +next
  22.383 +  fix Y :: "nat \<Rightarrow> 'a"
  22.384 +  assume Y: "chain Y"
  22.385 +  show "approximants (\<Squnion>i. Y i) = (\<Union>i. approximants (Y i))"
  22.386 +    unfolding approximants_def
  22.387 +    apply safe
  22.388 +    apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
  22.389 +    apply (erule below_trans, rule is_ub_thelub [OF Y])
  22.390 +    done
  22.391 +next
  22.392 +  fix a :: "'a compact_basis"
  22.393 +  show "approximants (Rep_compact_basis a) = {b. b \<sqsubseteq> a}"
  22.394 +    unfolding approximants_def compact_le_def ..
  22.395 +next
  22.396 +  fix x y :: "'a"
  22.397 +  assume "approximants x \<subseteq> approximants y" thus "x \<sqsubseteq> y"
  22.398 +    apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y")
  22.399 +    apply (simp add: lub_distribs)
  22.400 +    apply (rule admD, simp, simp)
  22.401 +    apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
  22.402 +    apply (simp add: approximants_def Abs_compact_basis_inverse
  22.403 +                     approx_below compact_approx)
  22.404 +    apply (simp add: approximants_def Abs_compact_basis_inverse compact_approx)
  22.405 +    done
  22.406 +next
  22.407 +  show "\<exists>f::'a compact_basis \<Rightarrow> nat. inj f"
  22.408 +    by (rule exI, rule inj_place)
  22.409 +qed
  22.410  
  22.411  subsubsection {* EP-pair from any bifinite domain into \emph{udom} *}
  22.412  
  22.413 +context approx_chain begin
  22.414 +
  22.415  definition
  22.416 -  udom_emb :: "'a::bifinite \<rightarrow> udom"
  22.417 +  udom_emb :: "'a \<rightarrow> udom"
  22.418  where
  22.419    "udom_emb = compact_basis.basis_fun (\<lambda>x. udom_principal (basis_emb x))"
  22.420  
  22.421  definition
  22.422 -  udom_prj :: "udom \<rightarrow> 'a::bifinite"
  22.423 +  udom_prj :: "udom \<rightarrow> 'a"
  22.424  where
  22.425    "udom_prj = udom.basis_fun (\<lambda>x. Rep_compact_basis (basis_prj x))"
  22.426  
  22.427 @@ -855,3 +928,103 @@
  22.428  done
  22.429  
  22.430  end
  22.431 +
  22.432 +abbreviation "udom_emb \<equiv> approx_chain.udom_emb"
  22.433 +abbreviation "udom_prj \<equiv> approx_chain.udom_prj"
  22.434 +
  22.435 +lemmas ep_pair_udom = approx_chain.ep_pair_udom
  22.436 +
  22.437 +subsection {* Chain of approx functions for type \emph{udom} *}
  22.438 +
  22.439 +definition
  22.440 +  udom_approx :: "nat \<Rightarrow> udom \<rightarrow> udom"
  22.441 +where
  22.442 +  "udom_approx i =
  22.443 +    udom.basis_fun (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x))"
  22.444 +
  22.445 +lemma udom_approx_mono:
  22.446 +  "ubasis_le a b \<Longrightarrow>
  22.447 +    udom_principal (ubasis_until (\<lambda>y. y \<le> i) a) \<sqsubseteq>
  22.448 +    udom_principal (ubasis_until (\<lambda>y. y \<le> i) b)"
  22.449 +apply (rule udom.principal_mono)
  22.450 +apply (rule ubasis_until_mono)
  22.451 +apply (frule (2) order_less_le_trans [OF node_gt2])
  22.452 +apply (erule order_less_imp_le)
  22.453 +apply assumption
  22.454 +done
  22.455 +
  22.456 +lemma adm_mem_finite: "\<lbrakk>cont f; finite S\<rbrakk> \<Longrightarrow> adm (\<lambda>x. f x \<in> S)"
  22.457 +by (erule adm_subst, induct set: finite, simp_all)
  22.458 +
  22.459 +lemma udom_approx_principal:
  22.460 +  "udom_approx i\<cdot>(udom_principal x) =
  22.461 +    udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)"
  22.462 +unfolding udom_approx_def
  22.463 +apply (rule udom.basis_fun_principal)
  22.464 +apply (erule udom_approx_mono)
  22.465 +done
  22.466 +
  22.467 +lemma finite_deflation_udom_approx: "finite_deflation (udom_approx i)"
  22.468 +proof
  22.469 +  fix x show "udom_approx i\<cdot>(udom_approx i\<cdot>x) = udom_approx i\<cdot>x"
  22.470 +    by (induct x rule: udom.principal_induct, simp)
  22.471 +       (simp add: udom_approx_principal ubasis_until_idem)
  22.472 +next
  22.473 +  fix x show "udom_approx i\<cdot>x \<sqsubseteq> x"
  22.474 +    by (induct x rule: udom.principal_induct, simp)
  22.475 +       (simp add: udom_approx_principal ubasis_until_less)
  22.476 +next
  22.477 +  have *: "finite (range (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)))"
  22.478 +    apply (subst range_composition [where f=udom_principal])
  22.479 +    apply (simp add: finite_range_ubasis_until)
  22.480 +    done
  22.481 +  show "finite {x. udom_approx i\<cdot>x = x}"
  22.482 +    apply (rule finite_range_imp_finite_fixes)
  22.483 +    apply (rule rev_finite_subset [OF *])
  22.484 +    apply (clarsimp, rename_tac x)
  22.485 +    apply (induct_tac x rule: udom.principal_induct)
  22.486 +    apply (simp add: adm_mem_finite *)
  22.487 +    apply (simp add: udom_approx_principal)
  22.488 +    done
  22.489 +qed
  22.490 +
  22.491 +interpretation udom_approx: finite_deflation "udom_approx i"
  22.492 +by (rule finite_deflation_udom_approx)
  22.493 +
  22.494 +lemma chain_udom_approx [simp]: "chain (\<lambda>i. udom_approx i)"
  22.495 +unfolding udom_approx_def
  22.496 +apply (rule chainI)
  22.497 +apply (rule udom.basis_fun_mono)
  22.498 +apply (erule udom_approx_mono)
  22.499 +apply (erule udom_approx_mono)
  22.500 +apply (rule udom.principal_mono)
  22.501 +apply (rule ubasis_until_chain, simp)
  22.502 +done
  22.503 +
  22.504 +lemma lub_udom_approx [simp]: "(\<Squnion>i. udom_approx i) = ID"
  22.505 +apply (rule ext_cfun, simp add: contlub_cfun_fun)
  22.506 +apply (rule below_antisym)
  22.507 +apply (rule is_lub_thelub)
  22.508 +apply (simp)
  22.509 +apply (rule ub_rangeI)
  22.510 +apply (rule udom_approx.below)
  22.511 +apply (rule_tac x=x in udom.principal_induct)
  22.512 +apply (simp add: lub_distribs)
  22.513 +apply (rule rev_below_trans)
  22.514 +apply (rule_tac x=a in is_ub_thelub)
  22.515 +apply simp
  22.516 +apply (simp add: udom_approx_principal)
  22.517 +apply (simp add: ubasis_until_same ubasis_le_refl)
  22.518 +done
  22.519 + 
  22.520 +lemma udom_approx: "approx_chain udom_approx"
  22.521 +proof
  22.522 +  show "chain (\<lambda>i. udom_approx i)"
  22.523 +    by (rule chain_udom_approx)
  22.524 +  show "(\<Squnion>i. udom_approx i) = ID"
  22.525 +    by (rule lub_udom_approx)
  22.526 +qed
  22.527 +
  22.528 +hide_const (open) node
  22.529 +
  22.530 +end
    23.1 --- a/src/HOLCF/Up.thy	Tue Oct 05 17:53:00 2010 -0700
    23.2 +++ b/src/HOLCF/Up.thy	Wed Oct 06 10:49:27 2010 -0700
    23.3 @@ -5,7 +5,7 @@
    23.4  header {* The type of lifted values *}
    23.5  
    23.6  theory Up
    23.7 -imports Bifinite
    23.8 +imports Algebraic
    23.9  begin
   23.10  
   23.11  default_sort cpo
   23.12 @@ -332,35 +332,62 @@
   23.13      by (rule finite_subset, simp add: d.finite_fixes)
   23.14  qed
   23.15  
   23.16 -subsection {* Lifted cpo is a bifinite domain *}
   23.17 +subsection {* Lifted cpo is an SFP domain *}
   23.18 +
   23.19 +definition u_approx :: "nat \<Rightarrow> udom\<^sub>\<bottom> \<rightarrow> udom\<^sub>\<bottom>"
   23.20 +where "u_approx = (\<lambda>i. u_map\<cdot>(udom_approx i))"
   23.21  
   23.22 -instantiation u :: (profinite) bifinite
   23.23 +lemma u_approx: "approx_chain u_approx"
   23.24 +proof (rule approx_chain.intro)
   23.25 +  show "chain (\<lambda>i. u_approx i)"
   23.26 +    unfolding u_approx_def by simp
   23.27 +  show "(\<Squnion>i. u_approx i) = ID"
   23.28 +    unfolding u_approx_def
   23.29 +    by (simp add: lub_distribs u_map_ID)
   23.30 +  show "\<And>i. finite_deflation (u_approx i)"
   23.31 +    unfolding u_approx_def
   23.32 +    by (intro finite_deflation_u_map finite_deflation_udom_approx)
   23.33 +qed
   23.34 +
   23.35 +definition u_sfp :: "sfp \<rightarrow> sfp"
   23.36 +where "u_sfp = sfp_fun1 u_approx u_map"
   23.37 +
   23.38 +lemma cast_u_sfp:
   23.39 +  "cast\<cdot>(u_sfp\<cdot>A) =
   23.40 +    udom_emb u_approx oo u_map\<cdot>(cast\<cdot>A) oo udom_prj u_approx"
   23.41 +unfolding u_sfp_def
   23.42 +apply (rule cast_sfp_fun1 [OF u_approx])
   23.43 +apply (erule finite_deflation_u_map)
   23.44 +done
   23.45 +
   23.46 +instantiation u :: (sfp) sfp
   23.47  begin
   23.48  
   23.49  definition
   23.50 -  approx_up_def:
   23.51 -    "approx = (\<lambda>n. u_map\<cdot>(approx n))"
   23.52 +  "emb = udom_emb u_approx oo u_map\<cdot>emb"
   23.53 +
   23.54 +definition
   23.55 +  "prj = u_map\<cdot>prj oo udom_prj u_approx"
   23.56 +
   23.57 +definition
   23.58 +  "sfp (t::'a u itself) = u_sfp\<cdot>SFP('a)"
   23.59  
   23.60  instance proof
   23.61 -  fix i :: nat and x :: "'a u"
   23.62 -  show "chain (approx :: nat \<Rightarrow> 'a u \<rightarrow> 'a u)"
   23.63 -    unfolding approx_up_def by simp
   23.64 -  show "(\<Squnion>i. approx i\<cdot>x) = x"
   23.65 -    unfolding approx_up_def
   23.66 -    by (induct x, simp, simp add: lub_distribs)
   23.67 -  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   23.68 -    unfolding approx_up_def
   23.69 -    by (induct x) simp_all
   23.70 -  show "finite {x::'a u. approx i\<cdot>x = x}"
   23.71 -    unfolding approx_up_def
   23.72 -    by (intro finite_deflation.finite_fixes
   23.73 -              finite_deflation_u_map
   23.74 -              finite_deflation_approx)
   23.75 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a u)"
   23.76 +    unfolding emb_u_def prj_u_def
   23.77 +    using ep_pair_udom [OF u_approx]
   23.78 +    by (intro ep_pair_comp ep_pair_u_map ep_pair_emb_prj)
   23.79 +next
   23.80 +  show "cast\<cdot>SFP('a u) = emb oo (prj :: udom \<rightarrow> 'a u)"
   23.81 +    unfolding emb_u_def prj_u_def sfp_u_def cast_u_sfp
   23.82 +    by (simp add: cast_SFP oo_def expand_cfun_eq u_map_map)
   23.83  qed
   23.84  
   23.85  end
   23.86  
   23.87 -lemma approx_up [simp]: "approx i\<cdot>(up\<cdot>x) = up\<cdot>(approx i\<cdot>x)"
   23.88 -unfolding approx_up_def by simp
   23.89 +text {* SFP of type constructor = type combinator *}
   23.90 +
   23.91 +lemma SFP_u: "SFP('a::sfp u) = u_sfp\<cdot>SFP('a)"
   23.92 +by (rule sfp_u_def)
   23.93  
   23.94  end
    24.1 --- a/src/HOLCF/UpperPD.thy	Tue Oct 05 17:53:00 2010 -0700
    24.2 +++ b/src/HOLCF/UpperPD.thy	Wed Oct 06 10:49:27 2010 -0700
    24.3 @@ -69,27 +69,6 @@
    24.4  apply (simp add: upper_le_PDPlus_iff 3)
    24.5  done
    24.6  
    24.7 -lemma pd_take_upper_chain:
    24.8 -  "pd_take n t \<le>\<sharp> pd_take (Suc n) t"
    24.9 -apply (induct t rule: pd_basis_induct)
   24.10 -apply (simp add: compact_basis.take_chain)
   24.11 -apply (simp add: PDPlus_upper_mono)
   24.12 -done
   24.13 -
   24.14 -lemma pd_take_upper_le: "pd_take i t \<le>\<sharp> t"
   24.15 -apply (induct t rule: pd_basis_induct)
   24.16 -apply (simp add: compact_basis.take_less)
   24.17 -apply (simp add: PDPlus_upper_mono)
   24.18 -done
   24.19 -
   24.20 -lemma pd_take_upper_mono:
   24.21 -  "t \<le>\<sharp> u \<Longrightarrow> pd_take n t \<le>\<sharp> pd_take n u"
   24.22 -apply (erule upper_le_induct)
   24.23 -apply (simp add: compact_basis.take_mono)
   24.24 -apply (simp add: upper_le_PDPlus_PDUnit_iff)
   24.25 -apply (simp add: upper_le_PDPlus_iff)
   24.26 -done
   24.27 -
   24.28  
   24.29  subsection {* Type definition *}
   24.30  
   24.31 @@ -97,7 +76,7 @@
   24.32    "{S::'a pd_basis set. upper_le.ideal S}"
   24.33  by (fast intro: upper_le.ideal_principal)
   24.34  
   24.35 -instantiation upper_pd :: (profinite) below
   24.36 +instantiation upper_pd :: (sfp) below
   24.37  begin
   24.38  
   24.39  definition
   24.40 @@ -106,18 +85,18 @@
   24.41  instance ..
   24.42  end
   24.43  
   24.44 -instance upper_pd :: (profinite) po
   24.45 -by (rule upper_le.typedef_ideal_po
   24.46 -    [OF type_definition_upper_pd below_upper_pd_def])
   24.47 +instance upper_pd :: (sfp) po
   24.48 +using type_definition_upper_pd below_upper_pd_def
   24.49 +by (rule upper_le.typedef_ideal_po)
   24.50  
   24.51 -instance upper_pd :: (profinite) cpo
   24.52 -by (rule upper_le.typedef_ideal_cpo
   24.53 -    [OF type_definition_upper_pd below_upper_pd_def])
   24.54 +instance upper_pd :: (sfp) cpo
   24.55 +using type_definition_upper_pd below_upper_pd_def
   24.56 +by (rule upper_le.typedef_ideal_cpo)
   24.57  
   24.58  lemma Rep_upper_pd_lub:
   24.59    "chain Y \<Longrightarrow> Rep_upper_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_upper_pd (Y i))"
   24.60 -by (rule upper_le.typedef_ideal_rep_contlub
   24.61 -    [OF type_definition_upper_pd below_upper_pd_def])
   24.62 +using type_definition_upper_pd below_upper_pd_def
   24.63 +by (rule upper_le.typedef_ideal_rep_contlub)
   24.64  
   24.65  lemma ideal_Rep_upper_pd: "upper_le.ideal (Rep_upper_pd xs)"
   24.66  by (rule Rep_upper_pd [unfolded mem_Collect_eq])
   24.67 @@ -132,18 +111,13 @@
   24.68  by (simp add: Abs_upper_pd_inverse upper_le.ideal_principal)
   24.69  
   24.70  interpretation upper_pd:
   24.71 -  ideal_completion upper_le pd_take upper_principal Rep_upper_pd
   24.72 +  ideal_completion upper_le upper_principal Rep_upper_pd
   24.73  apply unfold_locales
   24.74 -apply (rule pd_take_upper_le)
   24.75 -apply (rule pd_take_idem)
   24.76 -apply (erule pd_take_upper_mono)
   24.77 -apply (rule pd_take_upper_chain)
   24.78 -apply (rule finite_range_pd_take)
   24.79 -apply (rule pd_take_covers)
   24.80  apply (rule ideal_Rep_upper_pd)
   24.81  apply (erule Rep_upper_pd_lub)
   24.82  apply (rule Rep_upper_principal)
   24.83  apply (simp only: below_upper_pd_def)
   24.84 +apply (rule pd_basis_countable)
   24.85  done
   24.86  
   24.87  text {* Upper powerdomain is pointed *}
   24.88 @@ -151,42 +125,12 @@
   24.89  lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
   24.90  by (induct ys rule: upper_pd.principal_induct, simp, simp)
   24.91  
   24.92 -instance upper_pd :: (bifinite) pcpo
   24.93 +instance upper_pd :: (sfp) pcpo
   24.94  by intro_classes (fast intro: upper_pd_minimal)
   24.95  
   24.96  lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
   24.97  by (rule upper_pd_minimal [THEN UU_I, symmetric])
   24.98  
   24.99 -text {* Upper powerdomain is profinite *}
  24.100 -
  24.101 -instantiation upper_pd :: (profinite) profinite
  24.102 -begin
  24.103 -
  24.104 -definition
  24.105 -  approx_upper_pd_def: "approx = upper_pd.completion_approx"
  24.106 -
  24.107 -instance
  24.108 -apply (intro_classes, unfold approx_upper_pd_def)
  24.109 -apply (rule upper_pd.chain_completion_approx)
  24.110 -apply (rule upper_pd.lub_completion_approx)
  24.111 -apply (rule upper_pd.completion_approx_idem)
  24.112 -apply (rule upper_pd.finite_fixes_completion_approx)
  24.113 -done
  24.114 -
  24.115 -end
  24.116 -
  24.117 -instance upper_pd :: (bifinite) bifinite ..
  24.118 -
  24.119 -lemma approx_upper_principal [simp]:
  24.120 -  "approx n\<cdot>(upper_principal t) = upper_principal (pd_take n t)"
  24.121 -unfolding approx_upper_pd_def
  24.122 -by (rule upper_pd.completion_approx_principal)
  24.123 -
  24.124 -lemma approx_eq_upper_principal:
  24.125 -  "\<exists>t\<in>Rep_upper_pd xs. approx n\<cdot>xs = upper_principal (pd_take n t)"
  24.126 -unfolding approx_upper_pd_def
  24.127 -by (rule upper_pd.completion_approx_eq_principal)
  24.128 -
  24.129  
  24.130  subsection {* Monadic unit and plus *}
  24.131  
  24.132 @@ -222,16 +166,6 @@
  24.133  by (simp add: upper_pd.basis_fun_principal
  24.134      upper_pd.basis_fun_mono PDPlus_upper_mono)
  24.135  
  24.136 -lemma approx_upper_unit [simp]:
  24.137 -  "approx n\<cdot>{x}\<sharp> = {approx n\<cdot>x}\<sharp>"
  24.138 -apply (induct x rule: compact_basis.principal_induct, simp)
  24.139 -apply (simp add: approx_Rep_compact_basis)
  24.140 -done
  24.141 -
  24.142 -lemma approx_upper_plus [simp]:
  24.143 -  "approx n\<cdot>(xs +\<sharp> ys) = (approx n\<cdot>xs) +\<sharp> (approx n\<cdot>ys)"
  24.144 -by (induct xs ys rule: upper_pd.principal_induct2, simp, simp, simp)
  24.145 -
  24.146  interpretation upper_add: semilattice upper_add proof
  24.147    fix xs ys zs :: "'a upper_pd"
  24.148    show "(xs +\<sharp> ys) +\<sharp> zs = xs +\<sharp> (ys +\<sharp> zs)"
  24.149 @@ -307,7 +241,8 @@
  24.150  unfolding po_eq_conv by simp
  24.151  
  24.152  lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
  24.153 -unfolding inst_upper_pd_pcpo Rep_compact_bot [symmetric] by simp
  24.154 +using upper_unit_Rep_compact_basis [of compact_bot]
  24.155 +by (simp add: inst_upper_pd_pcpo)
  24.156  
  24.157  lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
  24.158  by (rule UU_I, rule upper_plus_below1)
  24.159 @@ -328,8 +263,14 @@
  24.160  apply auto
  24.161  done
  24.162  
  24.163 +lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
  24.164 +by (auto dest!: compact_basis.compact_imp_principal)
  24.165 +
  24.166  lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
  24.167 -unfolding profinite_compact_iff by simp
  24.168 +apply (safe elim!: compact_upper_unit)
  24.169 +apply (simp only: compact_def upper_unit_below_iff [symmetric])
  24.170 +apply (erule adm_subst [OF cont_Rep_CFun2])
  24.171 +done
  24.172  
  24.173  lemma compact_upper_plus [simp]:
  24.174    "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<sharp> ys)"
  24.175 @@ -424,16 +365,12 @@
  24.176  unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)
  24.177  
  24.178  
  24.179 -subsection {* Map and join *}
  24.180 +subsection {* Map *}
  24.181  
  24.182  definition
  24.183    upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
  24.184    "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"
  24.185  
  24.186 -definition
  24.187 -  upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
  24.188 -  "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
  24.189 -
  24.190  lemma upper_map_unit [simp]:
  24.191    "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
  24.192  unfolding upper_map_def by simp
  24.193 @@ -442,14 +379,6 @@
  24.194    "upper_map\<cdot>f\<cdot>(xs +\<sharp> ys) = upper_map\<cdot>f\<cdot>xs +\<sharp> upper_map\<cdot>f\<cdot>ys"
  24.195  unfolding upper_map_def by simp
  24.196  
  24.197 -lemma upper_join_unit [simp]:
  24.198 -  "upper_join\<cdot>{xs}\<sharp> = xs"
  24.199 -unfolding upper_join_def by simp
  24.200 -
  24.201 -lemma upper_join_plus [simp]:
  24.202 -  "upper_join\<cdot>(xss +\<sharp> yss) = upper_join\<cdot>xss +\<sharp> upper_join\<cdot>yss"
  24.203 -unfolding upper_join_def by simp
  24.204 -
  24.205  lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
  24.206  by (induct xs rule: upper_pd_induct, simp_all)
  24.207  
  24.208 @@ -460,22 +389,6 @@
  24.209    "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
  24.210  by (induct xs rule: upper_pd_induct, simp_all)
  24.211  
  24.212 -lemma upper_join_map_unit:
  24.213 -  "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
  24.214 -by (induct xs rule: upper_pd_induct, simp_all)
  24.215 -
  24.216 -lemma upper_join_map_join:
  24.217 -  "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
  24.218 -by (induct xsss rule: upper_pd_induct, simp_all)
  24.219 -
  24.220 -lemma upper_join_map_map:
  24.221 -  "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
  24.222 -   upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
  24.223 -by (induct xss rule: upper_pd_induct, simp_all)
  24.224 -
  24.225 -lemma upper_map_approx: "upper_map\<cdot>(approx n)\<cdot>xs = approx n\<cdot>xs"
  24.226 -by (induct xs rule: upper_pd_induct, simp_all)
  24.227 -
  24.228  lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
  24.229  apply default
  24.230  apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
  24.231 @@ -490,4 +403,134 @@
  24.232  apply (simp_all add: deflation.below monofun_cfun)
  24.233  done
  24.234  
  24.235 +(* FIXME: long proof! *)
  24.236 +lemma finite_deflation_upper_map:
  24.237 +  assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
  24.238 +proof (rule finite_deflation_intro)
  24.239 +  interpret d: finite_deflation d by fact
  24.240 +  have "deflation d" by fact
  24.241 +  thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
  24.242 +  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  24.243 +  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
  24.244 +    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  24.245 +  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  24.246 +  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
  24.247 +    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  24.248 +  hence *: "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  24.249 +  hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
  24.250 +    apply (rule rev_finite_subset)
  24.251 +    apply clarsimp
  24.252 +    apply (induct_tac xs rule: upper_pd.principal_induct)
  24.253 +    apply (simp add: adm_mem_finite *)
  24.254 +    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
  24.255 +    apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
  24.256 +    apply simp
  24.257 +    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
  24.258 +    apply clarsimp
  24.259 +    apply (rule imageI)
  24.260 +    apply (rule vimageI2)
  24.261 +    apply (simp add: Rep_PDUnit)
  24.262 +    apply (rule range_eqI)
  24.263 +    apply (erule sym)
  24.264 +    apply (rule exI)
  24.265 +    apply (rule Abs_compact_basis_inverse [symmetric])
  24.266 +    apply (simp add: d.compact)
  24.267 +    apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
  24.268 +    apply clarsimp
  24.269 +    apply (rule imageI)
  24.270 +    apply (rule vimageI2)
  24.271 +    apply (simp add: Rep_PDPlus)
  24.272 +    done
  24.273 +  thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
  24.274 +    by (rule finite_range_imp_finite_fixes)
  24.275 +qed
  24.276 +
  24.277 +subsection {* Upper powerdomain is an SFP domain *}
  24.278 +
  24.279 +definition
  24.280 +  upper_approx :: "nat \<Rightarrow> udom upper_pd \<rightarrow> udom upper_pd"
  24.281 +where
  24.282 +  "upper_approx = (\<lambda>i. upper_map\<cdot>(udom_approx i))"
  24.283 +
  24.284 +lemma upper_approx: "approx_chain upper_approx"
  24.285 +proof (rule approx_chain.intro)
  24.286 +  show "chain (\<lambda>i. upper_approx i)"
  24.287 +    unfolding upper_approx_def by simp
  24.288 +  show "(\<Squnion>i. upper_approx i) = ID"
  24.289 +    unfolding upper_approx_def
  24.290 +    by (simp add: lub_distribs upper_map_ID)
  24.291 +  show "\<And>i. finite_deflation (upper_approx i)"
  24.292 +    unfolding upper_approx_def
  24.293 +    by (intro finite_deflation_upper_map finite_deflation_udom_approx)
  24.294 +qed
  24.295 +
  24.296 +definition upper_sfp :: "sfp \<rightarrow> sfp"
  24.297 +where "upper_sfp = sfp_fun1 upper_approx upper_map"
  24.298 +
  24.299 +lemma cast_upper_sfp:
  24.300 +  "cast\<cdot>(upper_sfp\<cdot>A) =
  24.301 +    udom_emb upper_approx oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj upper_approx"
  24.302 +unfolding upper_sfp_def
  24.303 +apply (rule cast_sfp_fun1 [OF upper_approx])
  24.304 +apply (erule finite_deflation_upper_map)
  24.305 +done
  24.306 +
  24.307 +instantiation upper_pd :: (sfp) sfp
  24.308 +begin
  24.309 +
  24.310 +definition
  24.311 +  "emb = udom_emb upper_approx oo upper_map\<cdot>emb"
  24.312 +
  24.313 +definition
  24.314 +  "prj = upper_map\<cdot>prj oo udom_prj upper_approx"
  24.315 +
  24.316 +definition
  24.317 +  "sfp (t::'a upper_pd itself) = upper_sfp\<cdot>SFP('a)"
  24.318 +
  24.319 +instance proof
  24.320 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
  24.321 +    unfolding emb_upper_pd_def prj_upper_pd_def
  24.322 +    using ep_pair_udom [OF upper_approx]
  24.323 +    by (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj)
  24.324 +next
  24.325 +  show "cast\<cdot>SFP('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
  24.326 +    unfolding emb_upper_pd_def prj_upper_pd_def sfp_upper_pd_def cast_upper_sfp
  24.327 +    by (simp add: cast_SFP oo_def expand_cfun_eq upper_map_map)
  24.328 +qed
  24.329 +
  24.330  end
  24.331 +
  24.332 +text {* SFP of type constructor = type combinator *}
  24.333 +
  24.334 +lemma SFP_upper: "SFP('a upper_pd) = upper_sfp\<cdot>SFP('a)"
  24.335 +by (rule sfp_upper_pd_def)
  24.336 +
  24.337 +
  24.338 +subsection {* Join *}
  24.339 +
  24.340 +definition
  24.341 +  upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
  24.342 +  "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
  24.343 +
  24.344 +lemma upper_join_unit [simp]:
  24.345 +  "upper_join\<cdot>{xs}\<sharp> = xs"
  24.346 +unfolding upper_join_def by simp
  24.347 +
  24.348 +lemma upper_join_plus [simp]:
  24.349 +  "upper_join\<cdot>(xss +\<sharp> yss) = upper_join\<cdot>xss +\<sharp> upper_join\<cdot>yss"
  24.350 +unfolding upper_join_def by simp
  24.351 +
  24.352 +lemma upper_join_map_unit:
  24.353 +  "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
  24.354 +by (induct xs rule: upper_pd_induct, simp_all)
  24.355 +
  24.356 +lemma upper_join_map_join:
  24.357 +  "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
  24.358 +by (induct xsss rule: upper_pd_induct, simp_all)
  24.359 +
  24.360 +lemma upper_join_map_map:
  24.361 +  "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
  24.362 +   upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
  24.363 +by (induct xss rule: upper_pd_induct, simp_all)
  24.364 +
  24.365 +end
    25.1 --- a/src/HOLCF/ex/Domain_Proofs.thy	Tue Oct 05 17:53:00 2010 -0700
    25.2 +++ b/src/HOLCF/ex/Domain_Proofs.thy	Wed Oct 06 10:49:27 2010 -0700
    25.3 @@ -8,7 +8,7 @@
    25.4  imports HOLCF
    25.5  begin
    25.6  
    25.7 -default_sort rep
    25.8 +default_sort sfp
    25.9  
   25.10  (*
   25.11  
   25.12 @@ -28,50 +28,50 @@
   25.13  text {* Start with the one-step non-recursive version *}
   25.14  
   25.15  definition
   25.16 -  foo_bar_baz_deflF ::
   25.17 -    "TypeRep \<rightarrow> TypeRep \<times> TypeRep \<times> TypeRep \<rightarrow> TypeRep \<times> TypeRep \<times> TypeRep"
   25.18 +  foo_bar_baz_sfpF ::
   25.19 +    "sfp \<rightarrow> sfp \<times> sfp \<times> sfp \<rightarrow> sfp \<times> sfp \<times> sfp"
   25.20  where
   25.21 -  "foo_bar_baz_deflF = (\<Lambda> a. Abs_CFun (\<lambda>(t1, t2, t3). 
   25.22 -    ( ssum_defl\<cdot>REP(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>t2))
   25.23 -    , u_defl\<cdot>(cfun_defl\<cdot>t3\<cdot>REP(tr))
   25.24 -    , u_defl\<cdot>(cfun_defl\<cdot>(convex_defl\<cdot>t1)\<cdot>REP(tr)))))"
   25.25 +  "foo_bar_baz_sfpF = (\<Lambda> a. Abs_CFun (\<lambda>(t1, t2, t3). 
   25.26 +    ( ssum_sfp\<cdot>SFP(one)\<cdot>(sprod_sfp\<cdot>(u_sfp\<cdot>a)\<cdot>(u_sfp\<cdot>t2))
   25.27 +    , u_sfp\<cdot>(cfun_sfp\<cdot>t3\<cdot>SFP(tr))
   25.28 +    , u_sfp\<cdot>(cfun_sfp\<cdot>(convex_sfp\<cdot>t1)\<cdot>SFP(tr)))))"
   25.29  
   25.30 -lemma foo_bar_baz_deflF_beta:
   25.31 -  "foo_bar_baz_deflF\<cdot>a\<cdot>t =
   25.32 -    ( ssum_defl\<cdot>REP(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>(fst (snd t))))
   25.33 -    , u_defl\<cdot>(cfun_defl\<cdot>(snd (snd t))\<cdot>REP(tr))
   25.34 -    , u_defl\<cdot>(cfun_defl\<cdot>(convex_defl\<cdot>(fst t))\<cdot>REP(tr)))"
   25.35 -unfolding foo_bar_baz_deflF_def
   25.36 +lemma foo_bar_baz_sfpF_beta:
   25.37 +  "foo_bar_baz_sfpF\<cdot>a\<cdot>t =
   25.38 +    ( ssum_sfp\<cdot>SFP(one)\<cdot>(sprod_sfp\<cdot>(u_sfp\<cdot>a)\<cdot>(u_sfp\<cdot>(fst (snd t))))
   25.39 +    , u_sfp\<cdot>(cfun_sfp\<cdot>(snd (snd t))\<cdot>SFP(tr))
   25.40 +    , u_sfp\<cdot>(cfun_sfp\<cdot>(convex_sfp\<cdot>(fst t))\<cdot>SFP(tr)))"
   25.41 +unfolding foo_bar_baz_sfpF_def
   25.42  by (simp add: split_def)
   25.43  
   25.44  text {* Individual type combinators are projected from the fixed point. *}
   25.45  
   25.46 -definition foo_defl :: "TypeRep \<rightarrow> TypeRep"
   25.47 -where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
   25.48 +definition foo_sfp :: "sfp \<rightarrow> sfp"
   25.49 +where "foo_sfp = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_sfpF\<cdot>a)))"
   25.50  
   25.51 -definition bar_defl :: "TypeRep \<rightarrow> TypeRep"
   25.52 -where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
   25.53 +definition bar_sfp :: "sfp \<rightarrow> sfp"
   25.54 +where "bar_sfp = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_sfpF\<cdot>a))))"
   25.55  
   25.56 -definition baz_defl :: "TypeRep \<rightarrow> TypeRep"
   25.57 -where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
   25.58 +definition baz_sfp :: "sfp \<rightarrow> sfp"
   25.59 +where "baz_sfp = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_sfpF\<cdot>a))))"
   25.60  
   25.61  lemma defl_apply_thms:
   25.62 -  "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
   25.63 -  "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
   25.64 -  "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
   25.65 -unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all
   25.66 +  "foo_sfp\<cdot>a = fst (fix\<cdot>(foo_bar_baz_sfpF\<cdot>a))"
   25.67 +  "bar_sfp\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_sfpF\<cdot>a)))"
   25.68 +  "baz_sfp\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_sfpF\<cdot>a)))"
   25.69 +unfolding foo_sfp_def bar_sfp_def baz_sfp_def by simp_all
   25.70  
   25.71  text {* Unfold rules for each combinator. *}
   25.72  
   25.73 -lemma foo_defl_unfold:
   25.74 -  "foo_defl\<cdot>a = ssum_defl\<cdot>REP(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
   25.75 -unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
   25.76 +lemma foo_sfp_unfold:
   25.77 +  "foo_sfp\<cdot>a = ssum_sfp\<cdot>SFP(one)\<cdot>(sprod_sfp\<cdot>(u_sfp\<cdot>a)\<cdot>(u_sfp\<cdot>(bar_sfp\<cdot>a)))"
   25.78 +unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_sfpF_beta)
   25.79  
   25.80 -lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(cfun_defl\<cdot>(baz_defl\<cdot>a)\<cdot>REP(tr))"
   25.81 -unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
   25.82 +lemma bar_sfp_unfold: "bar_sfp\<cdot>a = u_sfp\<cdot>(cfun_sfp\<cdot>(baz_sfp\<cdot>a)\<cdot>SFP(tr))"
   25.83 +unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_sfpF_beta)
   25.84  
   25.85 -lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(cfun_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a))\<cdot>REP(tr))"
   25.86 -unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
   25.87 +lemma baz_sfp_unfold: "baz_sfp\<cdot>a = u_sfp\<cdot>(cfun_sfp\<cdot>(convex_sfp\<cdot>(foo_sfp\<cdot>a))\<cdot>SFP(tr))"
   25.88 +unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_sfpF_beta)
   25.89  
   25.90  text "The automation for the previous steps will be quite similar to
   25.91  how the fixrec package works."
   25.92 @@ -82,28 +82,28 @@
   25.93  
   25.94  text {* Use @{text pcpodef} with the appropriate type combinator. *}
   25.95  
   25.96 -pcpodef (open) 'a foo = "{x. x ::: foo_defl\<cdot>REP('a)}"
   25.97 -by (simp_all add: adm_in_deflation)
   25.98 +pcpodef (open) 'a foo = "{x. x ::: foo_sfp\<cdot>SFP('a)}"
   25.99 +by (simp_all add: adm_in_sfp)
  25.100  
  25.101 -pcpodef (open) 'a bar = "{x. x ::: bar_defl\<cdot>REP('a)}"
  25.102 -by (simp_all add: adm_in_deflation)
  25.103 +pcpodef (open) 'a bar = "{x. x ::: bar_sfp\<cdot>SFP('a)}"
  25.104 +by (simp_all add: adm_in_sfp)
  25.105  
  25.106 -pcpodef (open) 'a baz = "{x. x ::: baz_defl\<cdot>REP('a)}"
  25.107 -by (simp_all add: adm_in_deflation)
  25.108 +pcpodef (open) 'a baz = "{x. x ::: baz_sfp\<cdot>SFP('a)}"
  25.109 +by (simp_all add: adm_in_sfp)
  25.110  
  25.111  text {* Prove rep instance using lemma @{text typedef_rep_class}. *}
  25.112  
  25.113 -instantiation foo :: (rep) rep
  25.114 +instantiation foo :: (sfp) sfp
  25.115  begin
  25.116  
  25.117  definition emb_foo :: "'a foo \<rightarrow> udom"
  25.118  where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"
  25.119  
  25.120  definition prj_foo :: "udom \<rightarrow> 'a foo"
  25.121 -where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>REP('a))\<cdot>y))"
  25.122 +where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_sfp\<cdot>SFP('a))\<cdot>y))"
  25.123  
  25.124 -definition approx_foo :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
  25.125 -where "approx_foo \<equiv> repdef_approx Rep_foo Abs_foo (foo_defl\<cdot>REP('a))"
  25.126 +definition sfp_foo :: "'a foo itself \<Rightarrow> sfp"
  25.127 +where "sfp_foo \<equiv> \<lambda>a. foo_sfp\<cdot>SFP('a)"
  25.128  
  25.129  instance
  25.130  apply (rule typedef_rep_class)
  25.131 @@ -111,22 +111,22 @@
  25.132  apply (rule below_foo_def)
  25.133  apply (rule emb_foo_def)
  25.134  apply (rule prj_foo_def)
  25.135 -apply (rule approx_foo_def)
  25.136 +apply (rule sfp_foo_def)
  25.137  done
  25.138  
  25.139  end
  25.140  
  25.141 -instantiation bar :: (rep) rep
  25.142 +instantiation bar :: (sfp) sfp
  25.143  begin
  25.144  
  25.145  definition emb_bar :: "'a bar \<rightarrow> udom"
  25.146  where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"
  25.147  
  25.148  definition prj_bar :: "udom \<rightarrow> 'a bar"
  25.149 -where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>REP('a))\<cdot>y))"
  25.150 +where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_sfp\<cdot>SFP('a))\<cdot>y))"
  25.151  
  25.152 -definition approx_bar :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
  25.153 -where "approx_bar \<equiv> repdef_approx Rep_bar Abs_bar (bar_defl\<cdot>REP('a))"
  25.154 +definition sfp_bar :: "'a bar itself \<Rightarrow> sfp"
  25.155 +where "sfp_bar \<equiv> \<lambda>a. bar_sfp\<cdot>SFP('a)"
  25.156  
  25.157  instance
  25.158  apply (rule typedef_rep_class)
  25.159 @@ -134,22 +134,22 @@
  25.160  apply (rule below_bar_def)
  25.161  apply (rule emb_bar_def)
  25.162  apply (rule prj_bar_def)
  25.163 -apply (rule approx_bar_def)
  25.164 +apply (rule sfp_bar_def)
  25.165  done
  25.166  
  25.167  end
  25.168  
  25.169 -instantiation baz :: (rep) rep
  25.170 +instantiation baz :: (sfp) sfp
  25.171  begin
  25.172  
  25.173  definition emb_baz :: "'a baz \<rightarrow> udom"
  25.174  where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"
  25.175  
  25.176  definition prj_baz :: "udom \<rightarrow> 'a baz"
  25.177 -where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>REP('a))\<cdot>y))"
  25.178 +where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_sfp\<cdot>SFP('a))\<cdot>y))"
  25.179  
  25.180 -definition approx_baz :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
  25.181 -where "approx_baz \<equiv> repdef_approx Rep_baz Abs_baz (baz_defl\<cdot>REP('a))"
  25.182 +definition sfp_baz :: "'a baz itself \<Rightarrow> sfp"
  25.183 +where "sfp_baz \<equiv> \<lambda>a. baz_sfp\<cdot>SFP('a)"
  25.184  
  25.185  instance
  25.186  apply (rule typedef_rep_class)
  25.187 @@ -157,50 +157,44 @@
  25.188  apply (rule below_baz_def)
  25.189  apply (rule emb_baz_def)
  25.190  apply (rule prj_baz_def)
  25.191 -apply (rule approx_baz_def)
  25.192 +apply (rule sfp_baz_def)
  25.193  done
  25.194  
  25.195  end
  25.196  
  25.197 -text {* Prove REP rules using lemma @{text typedef_REP}. *}
  25.198 +text {* Prove SFP rules using lemma @{text typedef_SFP}. *}
  25.199  
  25.200 -lemma REP_foo: "REP('a foo) = foo_defl\<cdot>REP('a)"
  25.201 -apply (rule typedef_REP)
  25.202 -apply (rule type_definition_foo)
  25.203 -apply (rule below_foo_def)
  25.204 -apply (rule emb_foo_def)
  25.205 -apply (rule prj_foo_def)
  25.206 +lemma SFP_foo: "SFP('a foo) = foo_sfp\<cdot>SFP('a)"
  25.207 +apply (rule typedef_SFP)
  25.208 +apply (rule sfp_foo_def)
  25.209  done
  25.210  
  25.211 -lemma REP_bar: "REP('a bar) = bar_defl\<cdot>REP('a)"
  25.212 -apply (rule typedef_REP)
  25.213 -apply (rule type_definition_bar)
  25.214 -apply (rule below_bar_def)
  25.215 -apply (rule emb_bar_def)
  25.216 -apply (rule prj_bar_def)
  25.217 +lemma SFP_bar: "SFP('a bar) = bar_sfp\<cdot>SFP('a)"
  25.218 +apply (rule typedef_SFP)
  25.219 +apply (rule sfp_bar_def)
  25.220 +done
  25.221 +
  25.222 +lemma SFP_baz: "SFP('a baz) = baz_sfp\<cdot>SFP('a)"
  25.223 +apply (rule typedef_SFP)
  25.224 +apply (rule sfp_baz_def)
  25.225  done
  25.226  
  25.227 -lemma REP_baz: "REP('a baz) = baz_defl\<cdot>REP('a)"
  25.228 -apply (rule typedef_REP)
  25.229 -apply (rule type_definition_baz)
  25.230 -apply (rule below_baz_def)
  25.231 -apply (rule emb_baz_def)
  25.232 -apply (rule prj_baz_def)
  25.233 -done
  25.234 +text {* Prove SFP equations using type combinator unfold lemmas. *}
  25.235  
  25.236 -text {* Prove REP equations using type combinator unfold lemmas. *}
  25.237 +lemmas SFP_simps =
  25.238 +  SFP_ssum SFP_sprod SFP_u SFP_cfun
  25.239  
  25.240 -lemma REP_foo': "REP('a foo) = REP(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
  25.241 -unfolding REP_foo REP_bar REP_baz REP_simps
  25.242 -by (rule foo_defl_unfold)
  25.243 +lemma SFP_foo': "SFP('a foo) = SFP(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
  25.244 +unfolding SFP_foo SFP_bar SFP_baz SFP_simps
  25.245 +by (rule foo_sfp_unfold)
  25.246  
  25.247 -lemma REP_bar': "REP('a bar) = REP(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
  25.248 -unfolding REP_foo REP_bar REP_baz REP_simps
  25.249 -by (rule bar_defl_unfold)
  25.250 +lemma SFP_bar': "SFP('a bar) = SFP(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
  25.251 +unfolding SFP_foo SFP_bar SFP_baz SFP_simps
  25.252 +by (rule bar_sfp_unfold)
  25.253  
  25.254 -lemma REP_baz': "REP('a baz) = REP(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
  25.255 -unfolding REP_foo REP_bar REP_baz REP_simps REP_convex
  25.256 -by (rule baz_defl_unfold)
  25.257 +lemma SFP_baz': "SFP('a baz) = SFP(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
  25.258 +unfolding SFP_foo SFP_bar SFP_baz SFP_simps SFP_convex
  25.259 +by (rule baz_sfp_unfold)
  25.260  
  25.261  (********************************************************************)
  25.262  
  25.263 @@ -229,36 +223,36 @@
  25.264  text {* Prove isomorphism rules. *}
  25.265  
  25.266  lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
  25.267 -by (rule domain_abs_iso [OF REP_foo' foo_abs_def foo_rep_def])
  25.268 +by (rule domain_abs_iso [OF SFP_foo' foo_abs_def foo_rep_def])
  25.269  
  25.270  lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
  25.271 -by (rule domain_rep_iso [OF REP_foo' foo_abs_def foo_rep_def])
  25.272 +by (rule domain_rep_iso [OF SFP_foo' foo_abs_def foo_rep_def])
  25.273  
  25.274  lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
  25.275 -by (rule domain_abs_iso [OF REP_bar' bar_abs_def bar_rep_def])
  25.276 +by (rule domain_abs_iso [OF SFP_bar' bar_abs_def bar_rep_def])
  25.277  
  25.278  lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
  25.279 -by (rule domain_rep_iso [OF REP_bar' bar_abs_def bar_rep_def])
  25.280 +by (rule domain_rep_iso [OF SFP_bar' bar_abs_def bar_rep_def])
  25.281  
  25.282  lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
  25.283 -by (rule domain_abs_iso [OF REP_baz' baz_abs_def baz_rep_def])
  25.284 +by (rule domain_abs_iso [OF SFP_baz' baz_abs_def baz_rep_def])
  25.285  
  25.286  lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
  25.287 -by (rule domain_rep_iso [OF REP_baz' baz_abs_def baz_rep_def])
  25.288 +by (rule domain_rep_iso [OF SFP_baz' baz_abs_def baz_rep_def])
  25.289  
  25.290  text {* Prove isodefl rules using @{text isodefl_coerce}. *}
  25.291  
  25.292  lemma isodefl_foo_abs:
  25.293    "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
  25.294 -by (rule isodefl_abs_rep [OF REP_foo' foo_abs_def foo_rep_def])
  25.295 +by (rule isodefl_abs_rep [OF SFP_foo' foo_abs_def foo_rep_def])
  25.296  
  25.297  lemma isodefl_bar_abs:
  25.298    "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
  25.299 -by (rule isodefl_abs_rep [OF REP_bar' bar_abs_def bar_rep_def])
  25.300 +by (rule isodefl_abs_rep [OF SFP_bar' bar_abs_def bar_rep_def])
  25.301  
  25.302  lemma isodefl_baz_abs:
  25.303    "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
  25.304 -by (rule isodefl_abs_rep [OF REP_baz' baz_abs_def baz_rep_def])
  25.305 +by (rule isodefl_abs_rep [OF SFP_baz' baz_abs_def baz_rep_def])
  25.306  
  25.307  (********************************************************************)
  25.308  
  25.309 @@ -322,15 +316,15 @@
  25.310  lemma isodefl_foo_bar_baz:
  25.311    assumes isodefl_d: "isodefl d t"
  25.312    shows
  25.313 -  "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
  25.314 -  isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
  25.315 -  isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
  25.316 +  "isodefl (foo_map\<cdot>d) (foo_sfp\<cdot>t) \<and>
  25.317 +  isodefl (bar_map\<cdot>d) (bar_sfp\<cdot>t) \<and>
  25.318 +  isodefl (baz_map\<cdot>d) (baz_sfp\<cdot>t)"
  25.319  unfolding map_apply_thms defl_apply_thms
  25.320   apply (rule parallel_fix_ind)
  25.321     apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
  25.322    apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
  25.323   apply (simp only: foo_bar_baz_mapF_beta
  25.324 -                   foo_bar_baz_deflF_beta
  25.325 +                   foo_bar_baz_sfpF_beta
  25.326                     fst_conv snd_conv)
  25.327   apply (elim conjE)
  25.328   apply (intro
  25.329 @@ -338,7 +332,7 @@
  25.330    isodefl_foo_abs
  25.331    isodefl_bar_abs
  25.332    isodefl_baz_abs
  25.333 -  isodefl_ssum isodefl_sprod isodefl_ID_REP
  25.334 +  isodefl_ssum isodefl_sprod isodefl_ID_SFP
  25.335    isodefl_u isodefl_convex isodefl_cfun
  25.336    isodefl_d
  25.337   )
  25.338 @@ -349,27 +343,27 @@
  25.339  lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
  25.340  lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]
  25.341  
  25.342 -text {* Prove map ID lemmas, using isodefl_REP_imp_ID *}
  25.343 +text {* Prove map ID lemmas, using isodefl_SFP_imp_ID *}
  25.344  
  25.345  lemma foo_map_ID: "foo_map\<cdot>ID = ID"
  25.346 -apply (rule isodefl_REP_imp_ID)
  25.347 -apply (subst REP_foo)
  25.348 +apply (rule isodefl_SFP_imp_ID)
  25.349 +apply (subst SFP_foo)
  25.350  apply (rule isodefl_foo)
  25.351 -apply (rule isodefl_ID_REP)
  25.352 +apply (rule isodefl_ID_SFP)
  25.353  done
  25.354  
  25.355  lemma bar_map_ID: "bar_map\<cdot>ID = ID"
  25.356 -apply (rule isodefl_REP_imp_ID)
  25.357 -apply (subst REP_bar)
  25.358 +apply (rule isodefl_SFP_imp_ID)
  25.359 +apply (subst SFP_bar)
  25.360  apply (rule isodefl_bar)
  25.361 -apply (rule isodefl_ID_REP)
  25.362 +apply (rule isodefl_ID_SFP)
  25.363  done
  25.364  
  25.365  lemma baz_map_ID: "baz_map\<cdot>ID = ID"
  25.366 -apply (rule isodefl_REP_imp_ID)
  25.367 -apply (subst REP_baz)
  25.368 +apply (rule isodefl_SFP_imp_ID)
  25.369 +apply (subst SFP_baz)
  25.370  apply (rule isodefl_baz)
  25.371 -apply (rule isodefl_ID_REP)
  25.372 +apply (rule isodefl_ID_SFP)
  25.373  done
  25.374  
  25.375  (********************************************************************)
    26.1 --- a/src/HOLCF/ex/Powerdomain_ex.thy	Tue Oct 05 17:53:00 2010 -0700
    26.2 +++ b/src/HOLCF/ex/Powerdomain_ex.thy	Wed Oct 06 10:49:27 2010 -0700
    26.3 @@ -8,7 +8,7 @@
    26.4  imports HOLCF
    26.5  begin
    26.6  
    26.7 -default_sort bifinite
    26.8 +default_sort sfp
    26.9  
   26.10  subsection {* Monadic sorting example *}
   26.11