moved directory src/HOLCF to src/HOL/HOLCF;
authorhuffman
Sat, 27 Nov 2010 16:08:10 -0800
changeset 40774 0437dbc127b3
parent 40773 6c12f5e24e34
child 40775 ed7a4eadb2f6
moved directory src/HOLCF to src/HOL/HOLCF; added HOLCF theories to src/HOL/IsaMakefile;
src/HOL/HOLCF/Adm.thy
src/HOL/HOLCF/Algebraic.thy
src/HOL/HOLCF/Bifinite.thy
src/HOL/HOLCF/Cfun.thy
src/HOL/HOLCF/CompactBasis.thy
src/HOL/HOLCF/Completion.thy
src/HOL/HOLCF/Cont.thy
src/HOL/HOLCF/ConvexPD.thy
src/HOL/HOLCF/Cpodef.thy
src/HOL/HOLCF/Cprod.thy
src/HOL/HOLCF/Deflation.thy
src/HOL/HOLCF/Discrete.thy
src/HOL/HOLCF/Domain.thy
src/HOL/HOLCF/Domain_Aux.thy
src/HOL/HOLCF/FOCUS/Buffer.thy
src/HOL/HOLCF/FOCUS/Buffer_adm.thy
src/HOL/HOLCF/FOCUS/FOCUS.thy
src/HOL/HOLCF/FOCUS/Fstream.thy
src/HOL/HOLCF/FOCUS/Fstreams.thy
src/HOL/HOLCF/FOCUS/README.html
src/HOL/HOLCF/FOCUS/ROOT.ML
src/HOL/HOLCF/FOCUS/Stream_adm.thy
src/HOL/HOLCF/Fix.thy
src/HOL/HOLCF/Fixrec.thy
src/HOL/HOLCF/Fun_Cpo.thy
src/HOL/HOLCF/HOLCF.thy
src/HOL/HOLCF/IMP/Denotational.thy
src/HOL/HOLCF/IMP/HoareEx.thy
src/HOL/HOLCF/IMP/README.html
src/HOL/HOLCF/IMP/ROOT.ML
src/HOL/HOLCF/IMP/document/root.bib
src/HOL/HOLCF/IMP/document/root.tex
src/HOL/HOLCF/IOA/ABP/Abschannel.thy
src/HOL/HOLCF/IOA/ABP/Abschannel_finite.thy
src/HOL/HOLCF/IOA/ABP/Action.thy
src/HOL/HOLCF/IOA/ABP/Check.ML
src/HOL/HOLCF/IOA/ABP/Correctness.thy
src/HOL/HOLCF/IOA/ABP/Env.thy
src/HOL/HOLCF/IOA/ABP/Impl.thy
src/HOL/HOLCF/IOA/ABP/Impl_finite.thy
src/HOL/HOLCF/IOA/ABP/Lemmas.thy
src/HOL/HOLCF/IOA/ABP/Packet.thy
src/HOL/HOLCF/IOA/ABP/ROOT.ML
src/HOL/HOLCF/IOA/ABP/Read_me
src/HOL/HOLCF/IOA/ABP/Receiver.thy
src/HOL/HOLCF/IOA/ABP/Sender.thy
src/HOL/HOLCF/IOA/ABP/Spec.thy
src/HOL/HOLCF/IOA/NTP/Abschannel.thy
src/HOL/HOLCF/IOA/NTP/Action.thy
src/HOL/HOLCF/IOA/NTP/Correctness.thy
src/HOL/HOLCF/IOA/NTP/Impl.thy
src/HOL/HOLCF/IOA/NTP/Lemmas.thy
src/HOL/HOLCF/IOA/NTP/Multiset.thy
src/HOL/HOLCF/IOA/NTP/Packet.thy
src/HOL/HOLCF/IOA/NTP/ROOT.ML
src/HOL/HOLCF/IOA/NTP/Read_me
src/HOL/HOLCF/IOA/NTP/Receiver.thy
src/HOL/HOLCF/IOA/NTP/Sender.thy
src/HOL/HOLCF/IOA/NTP/Spec.thy
src/HOL/HOLCF/IOA/README.html
src/HOL/HOLCF/IOA/ROOT.ML
src/HOL/HOLCF/IOA/Storage/Action.thy
src/HOL/HOLCF/IOA/Storage/Correctness.thy
src/HOL/HOLCF/IOA/Storage/Impl.thy
src/HOL/HOLCF/IOA/Storage/ROOT.ML
src/HOL/HOLCF/IOA/Storage/Spec.thy
src/HOL/HOLCF/IOA/ex/ROOT.ML
src/HOL/HOLCF/IOA/ex/TrivEx.thy
src/HOL/HOLCF/IOA/ex/TrivEx2.thy
src/HOL/HOLCF/IOA/meta_theory/Abstraction.thy
src/HOL/HOLCF/IOA/meta_theory/Asig.thy
src/HOL/HOLCF/IOA/meta_theory/Automata.thy
src/HOL/HOLCF/IOA/meta_theory/CompoExecs.thy
src/HOL/HOLCF/IOA/meta_theory/CompoScheds.thy
src/HOL/HOLCF/IOA/meta_theory/CompoTraces.thy
src/HOL/HOLCF/IOA/meta_theory/Compositionality.thy
src/HOL/HOLCF/IOA/meta_theory/Deadlock.thy
src/HOL/HOLCF/IOA/meta_theory/IOA.thy
src/HOL/HOLCF/IOA/meta_theory/LiveIOA.thy
src/HOL/HOLCF/IOA/meta_theory/Pred.thy
src/HOL/HOLCF/IOA/meta_theory/RefCorrectness.thy
src/HOL/HOLCF/IOA/meta_theory/RefMappings.thy
src/HOL/HOLCF/IOA/meta_theory/Seq.thy
src/HOL/HOLCF/IOA/meta_theory/Sequence.thy
src/HOL/HOLCF/IOA/meta_theory/ShortExecutions.thy
src/HOL/HOLCF/IOA/meta_theory/SimCorrectness.thy
src/HOL/HOLCF/IOA/meta_theory/Simulations.thy
src/HOL/HOLCF/IOA/meta_theory/TL.thy
src/HOL/HOLCF/IOA/meta_theory/TLS.thy
src/HOL/HOLCF/IOA/meta_theory/Traces.thy
src/HOL/HOLCF/IsaMakefile
src/HOL/HOLCF/Library/Defl_Bifinite.thy
src/HOL/HOLCF/Library/HOLCF_Library.thy
src/HOL/HOLCF/Library/List_Cpo.thy
src/HOL/HOLCF/Library/ROOT.ML
src/HOL/HOLCF/Library/Stream.thy
src/HOL/HOLCF/Library/Sum_Cpo.thy
src/HOL/HOLCF/Lift.thy
src/HOL/HOLCF/LowerPD.thy
src/HOL/HOLCF/Map_Functions.thy
src/HOL/HOLCF/One.thy
src/HOL/HOLCF/Pcpo.thy
src/HOL/HOLCF/Plain_HOLCF.thy
src/HOL/HOLCF/Porder.thy
src/HOL/HOLCF/Powerdomains.thy
src/HOL/HOLCF/Product_Cpo.thy
src/HOL/HOLCF/README.html
src/HOL/HOLCF/ROOT.ML
src/HOL/HOLCF/Sfun.thy
src/HOL/HOLCF/Sprod.thy
src/HOL/HOLCF/Ssum.thy
src/HOL/HOLCF/Tools/Domain/domain.ML
src/HOL/HOLCF/Tools/Domain/domain_axioms.ML
src/HOL/HOLCF/Tools/Domain/domain_constructors.ML
src/HOL/HOLCF/Tools/Domain/domain_induction.ML
src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML
src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML
src/HOL/HOLCF/Tools/cont_consts.ML
src/HOL/HOLCF/Tools/cont_proc.ML
src/HOL/HOLCF/Tools/cpodef.ML
src/HOL/HOLCF/Tools/domaindef.ML
src/HOL/HOLCF/Tools/fixrec.ML
src/HOL/HOLCF/Tools/holcf_library.ML
src/HOL/HOLCF/Tr.thy
src/HOL/HOLCF/Tutorial/Domain_ex.thy
src/HOL/HOLCF/Tutorial/Fixrec_ex.thy
src/HOL/HOLCF/Tutorial/New_Domain.thy
src/HOL/HOLCF/Tutorial/ROOT.ML
src/HOL/HOLCF/Tutorial/document/root.tex
src/HOL/HOLCF/Universal.thy
src/HOL/HOLCF/Up.thy
src/HOL/HOLCF/UpperPD.thy
src/HOL/HOLCF/document/root.tex
src/HOL/HOLCF/ex/Dagstuhl.thy
src/HOL/HOLCF/ex/Dnat.thy
src/HOL/HOLCF/ex/Domain_Proofs.thy
src/HOL/HOLCF/ex/Fix2.thy
src/HOL/HOLCF/ex/Focus_ex.thy
src/HOL/HOLCF/ex/Hoare.thy
src/HOL/HOLCF/ex/Letrec.thy
src/HOL/HOLCF/ex/Loop.thy
src/HOL/HOLCF/ex/Pattern_Match.thy
src/HOL/HOLCF/ex/Powerdomain_ex.thy
src/HOL/HOLCF/ex/ROOT.ML
src/HOL/HOLCF/ex/hoare.txt
src/HOL/IsaMakefile
src/HOLCF/Adm.thy
src/HOLCF/Algebraic.thy
src/HOLCF/Bifinite.thy
src/HOLCF/Cfun.thy
src/HOLCF/CompactBasis.thy
src/HOLCF/Completion.thy
src/HOLCF/Cont.thy
src/HOLCF/ConvexPD.thy
src/HOLCF/Cpodef.thy
src/HOLCF/Cprod.thy
src/HOLCF/Deflation.thy
src/HOLCF/Discrete.thy
src/HOLCF/Domain.thy
src/HOLCF/Domain_Aux.thy
src/HOLCF/FOCUS/Buffer.thy
src/HOLCF/FOCUS/Buffer_adm.thy
src/HOLCF/FOCUS/FOCUS.thy
src/HOLCF/FOCUS/Fstream.thy
src/HOLCF/FOCUS/Fstreams.thy
src/HOLCF/FOCUS/README.html
src/HOLCF/FOCUS/ROOT.ML
src/HOLCF/FOCUS/Stream_adm.thy
src/HOLCF/Fix.thy
src/HOLCF/Fixrec.thy
src/HOLCF/Fun_Cpo.thy
src/HOLCF/HOLCF.thy
src/HOLCF/IMP/Denotational.thy
src/HOLCF/IMP/HoareEx.thy
src/HOLCF/IMP/README.html
src/HOLCF/IMP/ROOT.ML
src/HOLCF/IMP/document/root.bib
src/HOLCF/IMP/document/root.tex
src/HOLCF/IOA/ABP/Abschannel.thy
src/HOLCF/IOA/ABP/Abschannel_finite.thy
src/HOLCF/IOA/ABP/Action.thy
src/HOLCF/IOA/ABP/Check.ML
src/HOLCF/IOA/ABP/Correctness.thy
src/HOLCF/IOA/ABP/Env.thy
src/HOLCF/IOA/ABP/Impl.thy
src/HOLCF/IOA/ABP/Impl_finite.thy
src/HOLCF/IOA/ABP/Lemmas.thy
src/HOLCF/IOA/ABP/Packet.thy
src/HOLCF/IOA/ABP/ROOT.ML
src/HOLCF/IOA/ABP/Read_me
src/HOLCF/IOA/ABP/Receiver.thy
src/HOLCF/IOA/ABP/Sender.thy
src/HOLCF/IOA/ABP/Spec.thy
src/HOLCF/IOA/NTP/Abschannel.thy
src/HOLCF/IOA/NTP/Action.thy
src/HOLCF/IOA/NTP/Correctness.thy
src/HOLCF/IOA/NTP/Impl.thy
src/HOLCF/IOA/NTP/Lemmas.thy
src/HOLCF/IOA/NTP/Multiset.thy
src/HOLCF/IOA/NTP/Packet.thy
src/HOLCF/IOA/NTP/ROOT.ML
src/HOLCF/IOA/NTP/Read_me
src/HOLCF/IOA/NTP/Receiver.thy
src/HOLCF/IOA/NTP/Sender.thy
src/HOLCF/IOA/NTP/Spec.thy
src/HOLCF/IOA/README.html
src/HOLCF/IOA/ROOT.ML
src/HOLCF/IOA/Storage/Action.thy
src/HOLCF/IOA/Storage/Correctness.thy
src/HOLCF/IOA/Storage/Impl.thy
src/HOLCF/IOA/Storage/ROOT.ML
src/HOLCF/IOA/Storage/Spec.thy
src/HOLCF/IOA/ex/ROOT.ML
src/HOLCF/IOA/ex/TrivEx.thy
src/HOLCF/IOA/ex/TrivEx2.thy
src/HOLCF/IOA/meta_theory/Abstraction.thy
src/HOLCF/IOA/meta_theory/Asig.thy
src/HOLCF/IOA/meta_theory/Automata.thy
src/HOLCF/IOA/meta_theory/CompoExecs.thy
src/HOLCF/IOA/meta_theory/CompoScheds.thy
src/HOLCF/IOA/meta_theory/CompoTraces.thy
src/HOLCF/IOA/meta_theory/Compositionality.thy
src/HOLCF/IOA/meta_theory/Deadlock.thy
src/HOLCF/IOA/meta_theory/IOA.thy
src/HOLCF/IOA/meta_theory/LiveIOA.thy
src/HOLCF/IOA/meta_theory/Pred.thy
src/HOLCF/IOA/meta_theory/RefCorrectness.thy
src/HOLCF/IOA/meta_theory/RefMappings.thy
src/HOLCF/IOA/meta_theory/Seq.thy
src/HOLCF/IOA/meta_theory/Sequence.thy
src/HOLCF/IOA/meta_theory/ShortExecutions.thy
src/HOLCF/IOA/meta_theory/SimCorrectness.thy
src/HOLCF/IOA/meta_theory/Simulations.thy
src/HOLCF/IOA/meta_theory/TL.thy
src/HOLCF/IOA/meta_theory/TLS.thy
src/HOLCF/IOA/meta_theory/Traces.thy
src/HOLCF/IsaMakefile
src/HOLCF/Library/Defl_Bifinite.thy
src/HOLCF/Library/HOLCF_Library.thy
src/HOLCF/Library/List_Cpo.thy
src/HOLCF/Library/ROOT.ML
src/HOLCF/Library/Stream.thy
src/HOLCF/Library/Sum_Cpo.thy
src/HOLCF/Lift.thy
src/HOLCF/LowerPD.thy
src/HOLCF/Map_Functions.thy
src/HOLCF/One.thy
src/HOLCF/Pcpo.thy
src/HOLCF/Plain_HOLCF.thy
src/HOLCF/Porder.thy
src/HOLCF/Powerdomains.thy
src/HOLCF/Product_Cpo.thy
src/HOLCF/README.html
src/HOLCF/ROOT.ML
src/HOLCF/Sfun.thy
src/HOLCF/Sprod.thy
src/HOLCF/Ssum.thy
src/HOLCF/Tools/Domain/domain.ML
src/HOLCF/Tools/Domain/domain_axioms.ML
src/HOLCF/Tools/Domain/domain_constructors.ML
src/HOLCF/Tools/Domain/domain_induction.ML
src/HOLCF/Tools/Domain/domain_isomorphism.ML
src/HOLCF/Tools/Domain/domain_take_proofs.ML
src/HOLCF/Tools/cont_consts.ML
src/HOLCF/Tools/cont_proc.ML
src/HOLCF/Tools/cpodef.ML
src/HOLCF/Tools/domaindef.ML
src/HOLCF/Tools/fixrec.ML
src/HOLCF/Tools/holcf_library.ML
src/HOLCF/Tr.thy
src/HOLCF/Tutorial/Domain_ex.thy
src/HOLCF/Tutorial/Fixrec_ex.thy
src/HOLCF/Tutorial/New_Domain.thy
src/HOLCF/Tutorial/ROOT.ML
src/HOLCF/Tutorial/document/root.tex
src/HOLCF/Universal.thy
src/HOLCF/Up.thy
src/HOLCF/UpperPD.thy
src/HOLCF/document/root.tex
src/HOLCF/ex/Dagstuhl.thy
src/HOLCF/ex/Dnat.thy
src/HOLCF/ex/Domain_Proofs.thy
src/HOLCF/ex/Fix2.thy
src/HOLCF/ex/Focus_ex.thy
src/HOLCF/ex/Hoare.thy
src/HOLCF/ex/Letrec.thy
src/HOLCF/ex/Loop.thy
src/HOLCF/ex/Pattern_Match.thy
src/HOLCF/ex/Powerdomain_ex.thy
src/HOLCF/ex/ROOT.ML
src/HOLCF/ex/hoare.txt
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Adm.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,193 @@
+(*  Title:      HOLCF/Adm.thy
+    Author:     Franz Regensburger and Brian Huffman
+*)
+
+header {* Admissibility and compactness *}
+
+theory Adm
+imports Cont
+begin
+
+default_sort cpo
+
+subsection {* Definitions *}
+
+definition
+  adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool" where
+  "adm P = (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"
+
+lemma admI:
+   "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
+unfolding adm_def by fast
+
+lemma admD: "\<lbrakk>adm P; chain Y; \<And>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)"
+unfolding adm_def by fast
+
+lemma admD2: "\<lbrakk>adm (\<lambda>x. \<not> P x); chain Y; P (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. P (Y i)"
+unfolding adm_def by fast
+
+lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
+by (rule admI, erule spec)
+
+subsection {* Admissibility on chain-finite types *}
+
+text {* For chain-finite (easy) types every formula is admissible. *}
+
+lemma adm_chfin [simp]: "adm (P::'a::chfin \<Rightarrow> bool)"
+by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)
+
+subsection {* Admissibility of special formulae and propagation *}
+
+lemma adm_const [simp]: "adm (\<lambda>x. t)"
+by (rule admI, simp)
+
+lemma adm_conj [simp]:
+  "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
+by (fast intro: admI elim: admD)
+
+lemma adm_all [simp]:
+  "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
+by (fast intro: admI elim: admD)
+
+lemma adm_ball [simp]:
+  "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
+by (fast intro: admI elim: admD)
+
+text {* Admissibility for disjunction is hard to prove. It requires 2 lemmas. *}
+
+lemma adm_disj_lemma1:
+  assumes adm: "adm P"
+  assumes chain: "chain Y"
+  assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
+  shows "P (\<Squnion>i. Y i)"
+proof -
+  def f \<equiv> "\<lambda>i. LEAST j. i \<le> j \<and> P (Y j)"
+  have chain': "chain (\<lambda>i. Y (f i))"
+    unfolding f_def
+    apply (rule chainI)
+    apply (rule chain_mono [OF chain])
+    apply (rule Least_le)
+    apply (rule LeastI2_ex)
+    apply (simp_all add: P)
+    done
+  have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
+    using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
+  have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
+    apply (rule below_antisym)
+    apply (rule lub_mono [OF chain chain'])
+    apply (rule chain_mono [OF chain f1])
+    apply (rule lub_range_mono [OF _ chain chain'])
+    apply clarsimp
+    done
+  show "P (\<Squnion>i. Y i)"
+    unfolding lub_eq using adm chain' f2 by (rule admD)
+qed
+
+lemma adm_disj_lemma2:
+  "\<forall>n::nat. P n \<or> Q n \<Longrightarrow> (\<forall>i. \<exists>j\<ge>i. P j) \<or> (\<forall>i. \<exists>j\<ge>i. Q j)"
+apply (erule contrapos_pp)
+apply (clarsimp, rename_tac a b)
+apply (rule_tac x="max a b" in exI)
+apply simp
+done
+
+lemma adm_disj [simp]:
+  "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
+apply (rule admI)
+apply (erule adm_disj_lemma2 [THEN disjE])
+apply (erule (2) adm_disj_lemma1 [THEN disjI1])
+apply (erule (2) adm_disj_lemma1 [THEN disjI2])
+done
+
+lemma adm_imp [simp]:
+  "\<lbrakk>adm (\<lambda>x. \<not> P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
+by (subst imp_conv_disj, rule adm_disj)
+
+lemma adm_iff [simp]:
+  "\<lbrakk>adm (\<lambda>x. P x \<longrightarrow> Q x); adm (\<lambda>x. Q x \<longrightarrow> P x)\<rbrakk>  
+    \<Longrightarrow> adm (\<lambda>x. P x = Q x)"
+by (subst iff_conv_conj_imp, rule adm_conj)
+
+text {* admissibility and continuity *}
+
+lemma adm_below [simp]:
+  "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
+by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)
+
+lemma adm_eq [simp]:
+  "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x = v x)"
+by (simp add: po_eq_conv)
+
+lemma adm_subst: "\<lbrakk>cont (\<lambda>x. t x); adm P\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P (t x))"
+by (simp add: adm_def cont2contlubE ch2ch_cont)
+
+lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
+by (rule admI, simp add: cont2contlubE ch2ch_cont lub_below_iff)
+
+subsection {* Compactness *}
+
+definition
+  compact :: "'a::cpo \<Rightarrow> bool" where
+  "compact k = adm (\<lambda>x. \<not> k \<sqsubseteq> x)"
+
+lemma compactI: "adm (\<lambda>x. \<not> k \<sqsubseteq> x) \<Longrightarrow> compact k"
+unfolding compact_def .
+
+lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> x)"
+unfolding compact_def .
+
+lemma compactI2:
+  "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
+unfolding compact_def adm_def by fast
+
+lemma compactD2:
+  "\<lbrakk>compact x; chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
+unfolding compact_def adm_def by fast
+
+lemma compact_below_lub_iff:
+  "\<lbrakk>compact x; chain Y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
+by (fast intro: compactD2 elim: below_lub)
+
+lemma compact_chfin [simp]: "compact (x::'a::chfin)"
+by (rule compactI [OF adm_chfin])
+
+lemma compact_imp_max_in_chain:
+  "\<lbrakk>chain Y; compact (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. max_in_chain i Y"
+apply (drule (1) compactD2, simp)
+apply (erule exE, rule_tac x=i in exI)
+apply (rule max_in_chainI)
+apply (rule below_antisym)
+apply (erule (1) chain_mono)
+apply (erule (1) below_trans [OF is_ub_thelub])
+done
+
+text {* admissibility and compactness *}
+
+lemma adm_compact_not_below [simp]:
+  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
+unfolding compact_def by (rule adm_subst)
+
+lemma adm_neq_compact [simp]:
+  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
+by (simp add: po_eq_conv)
+
+lemma adm_compact_neq [simp]:
+  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
+by (simp add: po_eq_conv)
+
+lemma compact_UU [simp, intro]: "compact \<bottom>"
+by (rule compactI, simp)
+
+text {* Any upward-closed predicate is admissible. *}
+
+lemma adm_upward:
+  assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
+  shows "adm P"
+by (rule admI, drule spec, erule P, erule is_ub_thelub)
+
+lemmas adm_lemmas =
+  adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
+  adm_below adm_eq adm_not_below
+  adm_compact_not_below adm_compact_neq adm_neq_compact
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Algebraic.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,214 @@
+(*  Title:      HOLCF/Algebraic.thy
+    Author:     Brian Huffman
+*)
+
+header {* Algebraic deflations *}
+
+theory Algebraic
+imports Universal Map_Functions
+begin
+
+subsection {* Type constructor for finite deflations *}
+
+typedef (open) fin_defl = "{d::udom \<rightarrow> udom. finite_deflation d}"
+by (fast intro: finite_deflation_UU)
+
+instantiation fin_defl :: below
+begin
+
+definition below_fin_defl_def:
+    "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"
+
+instance ..
+end
+
+instance fin_defl :: po
+using type_definition_fin_defl below_fin_defl_def
+by (rule typedef_po)
+
+lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
+using Rep_fin_defl by simp
+
+lemma deflation_Rep_fin_defl: "deflation (Rep_fin_defl d)"
+using finite_deflation_Rep_fin_defl
+by (rule finite_deflation_imp_deflation)
+
+interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
+by (rule finite_deflation_Rep_fin_defl)
+
+lemma fin_defl_belowI:
+  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
+unfolding below_fin_defl_def
+by (rule Rep_fin_defl.belowI)
+
+lemma fin_defl_belowD:
+  "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
+unfolding below_fin_defl_def
+by (rule Rep_fin_defl.belowD)
+
+lemma fin_defl_eqI:
+  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
+apply (rule below_antisym)
+apply (rule fin_defl_belowI, simp)
+apply (rule fin_defl_belowI, simp)
+done
+
+lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
+unfolding below_fin_defl_def .
+
+lemma Abs_fin_defl_mono:
+  "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
+    \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
+unfolding below_fin_defl_def
+by (simp add: Abs_fin_defl_inverse)
+
+lemma (in finite_deflation) compact_belowI:
+  assumes "\<And>x. compact x \<Longrightarrow> d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
+by (rule belowI, rule assms, erule subst, rule compact)
+
+lemma compact_Rep_fin_defl [simp]: "compact (Rep_fin_defl a)"
+using finite_deflation_Rep_fin_defl
+by (rule finite_deflation_imp_compact)
+
+subsection {* Defining algebraic deflations by ideal completion *}
+
+typedef (open) defl = "{S::fin_defl set. below.ideal S}"
+by (fast intro: below.ideal_principal)
+
+instantiation defl :: below
+begin
+
+definition
+  "x \<sqsubseteq> y \<longleftrightarrow> Rep_defl x \<subseteq> Rep_defl y"
+
+instance ..
+end
+
+instance defl :: po
+using type_definition_defl below_defl_def
+by (rule below.typedef_ideal_po)
+
+instance defl :: cpo
+using type_definition_defl below_defl_def
+by (rule below.typedef_ideal_cpo)
+
+definition
+  defl_principal :: "fin_defl \<Rightarrow> defl" where
+  "defl_principal t = Abs_defl {u. u \<sqsubseteq> t}"
+
+lemma fin_defl_countable: "\<exists>f::fin_defl \<Rightarrow> nat. inj f"
+proof
+  have *: "\<And>d. finite (approx_chain.place udom_approx `
+               Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x})"
+    apply (rule finite_imageI)
+    apply (rule finite_vimageI)
+    apply (rule Rep_fin_defl.finite_fixes)
+    apply (simp add: inj_on_def Rep_compact_basis_inject)
+    done
+  have range_eq: "range Rep_compact_basis = {x. compact x}"
+    using type_definition_compact_basis by (rule type_definition.Rep_range)
+  show "inj (\<lambda>d. set_encode
+    (approx_chain.place udom_approx ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x}))"
+    apply (rule inj_onI)
+    apply (simp only: set_encode_eq *)
+    apply (simp only: inj_image_eq_iff approx_chain.inj_place [OF udom_approx])
+    apply (drule_tac f="image Rep_compact_basis" in arg_cong)
+    apply (simp del: vimage_Collect_eq add: range_eq set_eq_iff)
+    apply (rule Rep_fin_defl_inject [THEN iffD1])
+    apply (rule below_antisym)
+    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
+    apply (drule_tac x=z in spec, simp)
+    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
+    apply (drule_tac x=z in spec, simp)
+    done
+qed
+
+interpretation defl: ideal_completion below defl_principal Rep_defl
+using type_definition_defl below_defl_def
+using defl_principal_def fin_defl_countable
+by (rule below.typedef_ideal_completion)
+
+text {* Algebraic deflations are pointed *}
+
+lemma defl_minimal: "defl_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
+apply (induct x rule: defl.principal_induct, simp)
+apply (rule defl.principal_mono)
+apply (simp add: below_fin_defl_def)
+apply (simp add: Abs_fin_defl_inverse finite_deflation_UU)
+done
+
+instance defl :: pcpo
+by intro_classes (fast intro: defl_minimal)
+
+lemma inst_defl_pcpo: "\<bottom> = defl_principal (Abs_fin_defl \<bottom>)"
+by (rule defl_minimal [THEN UU_I, symmetric])
+
+subsection {* Applying algebraic deflations *}
+
+definition
+  cast :: "defl \<rightarrow> udom \<rightarrow> udom"
+where
+  "cast = defl.basis_fun Rep_fin_defl"
+
+lemma cast_defl_principal:
+  "cast\<cdot>(defl_principal a) = Rep_fin_defl a"
+unfolding cast_def
+apply (rule defl.basis_fun_principal)
+apply (simp only: below_fin_defl_def)
+done
+
+lemma deflation_cast: "deflation (cast\<cdot>d)"
+apply (induct d rule: defl.principal_induct)
+apply (rule adm_subst [OF _ adm_deflation], simp)
+apply (simp add: cast_defl_principal)
+apply (rule finite_deflation_imp_deflation)
+apply (rule finite_deflation_Rep_fin_defl)
+done
+
+lemma finite_deflation_cast:
+  "compact d \<Longrightarrow> finite_deflation (cast\<cdot>d)"
+apply (drule defl.compact_imp_principal, clarify)
+apply (simp add: cast_defl_principal)
+apply (rule finite_deflation_Rep_fin_defl)
+done
+
+interpretation cast: deflation "cast\<cdot>d"
+by (rule deflation_cast)
+
+declare cast.idem [simp]
+
+lemma compact_cast [simp]: "compact d \<Longrightarrow> compact (cast\<cdot>d)"
+apply (rule finite_deflation_imp_compact)
+apply (erule finite_deflation_cast)
+done
+
+lemma cast_below_cast: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
+apply (induct A rule: defl.principal_induct, simp)
+apply (induct B rule: defl.principal_induct, simp)
+apply (simp add: cast_defl_principal below_fin_defl_def)
+done
+
+lemma compact_cast_iff: "compact (cast\<cdot>d) \<longleftrightarrow> compact d"
+apply (rule iffI)
+apply (simp only: compact_def cast_below_cast [symmetric])
+apply (erule adm_subst [OF cont_Rep_cfun2])
+apply (erule compact_cast)
+done
+
+lemma cast_below_imp_below: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<Longrightarrow> A \<sqsubseteq> B"
+by (simp only: cast_below_cast)
+
+lemma cast_eq_imp_eq: "cast\<cdot>A = cast\<cdot>B \<Longrightarrow> A = B"
+by (simp add: below_antisym cast_below_imp_below)
+
+lemma cast_strict1 [simp]: "cast\<cdot>\<bottom> = \<bottom>"
+apply (subst inst_defl_pcpo)
+apply (subst cast_defl_principal)
+apply (rule Abs_fin_defl_inverse)
+apply (simp add: finite_deflation_UU)
+done
+
+lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
+by (rule cast.below [THEN UU_I])
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Bifinite.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,800 @@
+(*  Title:      HOLCF/Bifinite.thy
+    Author:     Brian Huffman
+*)
+
+header {* Bifinite domains *}
+
+theory Bifinite
+imports Algebraic Map_Functions Countable
+begin
+
+subsection {* Class of bifinite domains *}
+
+text {*
+  We define a ``domain'' as a pcpo that is isomorphic to some
+  algebraic deflation over the universal domain; this is equivalent
+  to being omega-bifinite.
+
+  A predomain is a cpo that, when lifted, becomes a domain.
+*}
+
+class predomain = cpo +
+  fixes liftdefl :: "('a::cpo) itself \<Rightarrow> defl"
+  fixes liftemb :: "'a\<^sub>\<bottom> \<rightarrow> udom"
+  fixes liftprj :: "udom \<rightarrow> 'a\<^sub>\<bottom>"
+  assumes predomain_ep: "ep_pair liftemb liftprj"
+  assumes cast_liftdefl: "cast\<cdot>(liftdefl TYPE('a::cpo)) = liftemb oo liftprj"
+
+syntax "_LIFTDEFL" :: "type \<Rightarrow> logic"  ("(1LIFTDEFL/(1'(_')))")
+translations "LIFTDEFL('t)" \<rightleftharpoons> "CONST liftdefl TYPE('t)"
+
+class "domain" = predomain + pcpo +
+  fixes emb :: "'a::cpo \<rightarrow> udom"
+  fixes prj :: "udom \<rightarrow> 'a::cpo"
+  fixes defl :: "'a itself \<Rightarrow> defl"
+  assumes ep_pair_emb_prj: "ep_pair emb prj"
+  assumes cast_DEFL: "cast\<cdot>(defl TYPE('a)) = emb oo prj"
+
+syntax "_DEFL" :: "type \<Rightarrow> defl"  ("(1DEFL/(1'(_')))")
+translations "DEFL('t)" \<rightleftharpoons> "CONST defl TYPE('t)"
+
+interpretation "domain": pcpo_ep_pair emb prj
+  unfolding pcpo_ep_pair_def
+  by (rule ep_pair_emb_prj)
+
+lemmas emb_inverse = domain.e_inverse
+lemmas emb_prj_below = domain.e_p_below
+lemmas emb_eq_iff = domain.e_eq_iff
+lemmas emb_strict = domain.e_strict
+lemmas prj_strict = domain.p_strict
+
+subsection {* Domains have a countable compact basis *}
+
+text {*
+  Eventually it should be possible to generalize this to an unpointed
+  variant of the domain class.
+*}
+
+interpretation compact_basis:
+  ideal_completion below Rep_compact_basis "approximants::'a::domain \<Rightarrow> _"
+proof -
+  obtain Y where Y: "\<forall>i. Y i \<sqsubseteq> Y (Suc i)"
+  and DEFL: "DEFL('a) = (\<Squnion>i. defl_principal (Y i))"
+    by (rule defl.obtain_principal_chain)
+  def approx \<equiv> "\<lambda>i. (prj oo cast\<cdot>(defl_principal (Y i)) oo emb) :: 'a \<rightarrow> 'a"
+  interpret defl_approx: approx_chain approx
+  proof (rule approx_chain.intro)
+    show "chain (\<lambda>i. approx i)"
+      unfolding approx_def by (simp add: Y)
+    show "(\<Squnion>i. approx i) = ID"
+      unfolding approx_def
+      by (simp add: lub_distribs Y DEFL [symmetric] cast_DEFL cfun_eq_iff)
+    show "\<And>i. finite_deflation (approx i)"
+      unfolding approx_def
+      apply (rule domain.finite_deflation_p_d_e)
+      apply (rule finite_deflation_cast)
+      apply (rule defl.compact_principal)
+      apply (rule below_trans [OF monofun_cfun_fun])
+      apply (rule is_ub_thelub, simp add: Y)
+      apply (simp add: lub_distribs Y DEFL [symmetric] cast_DEFL)
+      done
+  qed
+  (* FIXME: why does show ?thesis fail here? *)
+  show "ideal_completion below Rep_compact_basis (approximants::'a \<Rightarrow> _)" ..
+qed
+
+subsection {* Chains of approx functions *}
+
+definition u_approx :: "nat \<Rightarrow> udom\<^sub>\<bottom> \<rightarrow> udom\<^sub>\<bottom>"
+  where "u_approx = (\<lambda>i. u_map\<cdot>(udom_approx i))"
+
+definition sfun_approx :: "nat \<Rightarrow> (udom \<rightarrow>! udom) \<rightarrow> (udom \<rightarrow>! udom)"
+  where "sfun_approx = (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
+
+definition prod_approx :: "nat \<Rightarrow> udom \<times> udom \<rightarrow> udom \<times> udom"
+  where "prod_approx = (\<lambda>i. cprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
+
+definition sprod_approx :: "nat \<Rightarrow> udom \<otimes> udom \<rightarrow> udom \<otimes> udom"
+  where "sprod_approx = (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
+
+definition ssum_approx :: "nat \<Rightarrow> udom \<oplus> udom \<rightarrow> udom \<oplus> udom"
+  where "ssum_approx = (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
+
+lemma approx_chain_lemma1:
+  assumes "m\<cdot>ID = ID"
+  assumes "\<And>d. finite_deflation d \<Longrightarrow> finite_deflation (m\<cdot>d)"
+  shows "approx_chain (\<lambda>i. m\<cdot>(udom_approx i))"
+by (rule approx_chain.intro)
+   (simp_all add: lub_distribs finite_deflation_udom_approx assms)
+
+lemma approx_chain_lemma2:
+  assumes "m\<cdot>ID\<cdot>ID = ID"
+  assumes "\<And>a b. \<lbrakk>finite_deflation a; finite_deflation b\<rbrakk>
+    \<Longrightarrow> finite_deflation (m\<cdot>a\<cdot>b)"
+  shows "approx_chain (\<lambda>i. m\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
+by (rule approx_chain.intro)
+   (simp_all add: lub_distribs finite_deflation_udom_approx assms)
+
+lemma u_approx: "approx_chain u_approx"
+using u_map_ID finite_deflation_u_map
+unfolding u_approx_def by (rule approx_chain_lemma1)
+
+lemma sfun_approx: "approx_chain sfun_approx"
+using sfun_map_ID finite_deflation_sfun_map
+unfolding sfun_approx_def by (rule approx_chain_lemma2)
+
+lemma prod_approx: "approx_chain prod_approx"
+using cprod_map_ID finite_deflation_cprod_map
+unfolding prod_approx_def by (rule approx_chain_lemma2)
+
+lemma sprod_approx: "approx_chain sprod_approx"
+using sprod_map_ID finite_deflation_sprod_map
+unfolding sprod_approx_def by (rule approx_chain_lemma2)
+
+lemma ssum_approx: "approx_chain ssum_approx"
+using ssum_map_ID finite_deflation_ssum_map
+unfolding ssum_approx_def by (rule approx_chain_lemma2)
+
+subsection {* Type combinators *}
+
+definition
+  defl_fun1 ::
+    "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a)) \<Rightarrow> (defl \<rightarrow> defl)"
+where
+  "defl_fun1 approx f =
+    defl.basis_fun (\<lambda>a.
+      defl_principal (Abs_fin_defl
+        (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)))"
+
+definition
+  defl_fun2 ::
+    "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a))
+      \<Rightarrow> (defl \<rightarrow> defl \<rightarrow> defl)"
+where
+  "defl_fun2 approx f =
+    defl.basis_fun (\<lambda>a.
+      defl.basis_fun (\<lambda>b.
+        defl_principal (Abs_fin_defl
+          (udom_emb approx oo
+            f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx))))"
+
+lemma cast_defl_fun1:
+  assumes approx: "approx_chain approx"
+  assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
+  shows "cast\<cdot>(defl_fun1 approx f\<cdot>A) = udom_emb approx oo f\<cdot>(cast\<cdot>A) oo udom_prj approx"
+proof -
+  have 1: "\<And>a. finite_deflation
+        (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)"
+    apply (rule ep_pair.finite_deflation_e_d_p)
+    apply (rule approx_chain.ep_pair_udom [OF approx])
+    apply (rule f, rule finite_deflation_Rep_fin_defl)
+    done
+  show ?thesis
+    by (induct A rule: defl.principal_induct, simp)
+       (simp only: defl_fun1_def
+                   defl.basis_fun_principal
+                   defl.basis_fun_mono
+                   defl.principal_mono
+                   Abs_fin_defl_mono [OF 1 1]
+                   monofun_cfun below_refl
+                   Rep_fin_defl_mono
+                   cast_defl_principal
+                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
+qed
+
+lemma cast_defl_fun2:
+  assumes approx: "approx_chain approx"
+  assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
+                finite_deflation (f\<cdot>a\<cdot>b)"
+  shows "cast\<cdot>(defl_fun2 approx f\<cdot>A\<cdot>B) =
+    udom_emb approx oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj approx"
+proof -
+  have 1: "\<And>a b. finite_deflation (udom_emb approx oo
+      f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx)"
+    apply (rule ep_pair.finite_deflation_e_d_p)
+    apply (rule ep_pair_udom [OF approx])
+    apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
+    done
+  show ?thesis
+    by (induct A B rule: defl.principal_induct2, simp, simp)
+       (simp only: defl_fun2_def
+                   defl.basis_fun_principal
+                   defl.basis_fun_mono
+                   defl.principal_mono
+                   Abs_fin_defl_mono [OF 1 1]
+                   monofun_cfun below_refl
+                   Rep_fin_defl_mono
+                   cast_defl_principal
+                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
+qed
+
+definition u_defl :: "defl \<rightarrow> defl"
+  where "u_defl = defl_fun1 u_approx u_map"
+
+definition sfun_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
+  where "sfun_defl = defl_fun2 sfun_approx sfun_map"
+
+definition prod_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
+  where "prod_defl = defl_fun2 prod_approx cprod_map"
+
+definition sprod_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
+  where "sprod_defl = defl_fun2 sprod_approx sprod_map"
+
+definition ssum_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
+where "ssum_defl = defl_fun2 ssum_approx ssum_map"
+
+lemma cast_u_defl:
+  "cast\<cdot>(u_defl\<cdot>A) =
+    udom_emb u_approx oo u_map\<cdot>(cast\<cdot>A) oo udom_prj u_approx"
+using u_approx finite_deflation_u_map
+unfolding u_defl_def by (rule cast_defl_fun1)
+
+lemma cast_sfun_defl:
+  "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) =
+    udom_emb sfun_approx oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj sfun_approx"
+using sfun_approx finite_deflation_sfun_map
+unfolding sfun_defl_def by (rule cast_defl_fun2)
+
+lemma cast_prod_defl:
+  "cast\<cdot>(prod_defl\<cdot>A\<cdot>B) = udom_emb prod_approx oo
+    cprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj prod_approx"
+using prod_approx finite_deflation_cprod_map
+unfolding prod_defl_def by (rule cast_defl_fun2)
+
+lemma cast_sprod_defl:
+  "cast\<cdot>(sprod_defl\<cdot>A\<cdot>B) =
+    udom_emb sprod_approx oo
+      sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo
+        udom_prj sprod_approx"
+using sprod_approx finite_deflation_sprod_map
+unfolding sprod_defl_def by (rule cast_defl_fun2)
+
+lemma cast_ssum_defl:
+  "cast\<cdot>(ssum_defl\<cdot>A\<cdot>B) =
+    udom_emb ssum_approx oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj ssum_approx"
+using ssum_approx finite_deflation_ssum_map
+unfolding ssum_defl_def by (rule cast_defl_fun2)
+
+subsection {* Lemma for proving domain instances *}
+
+text {*
+  A class of domains where @{const liftemb}, @{const liftprj},
+  and @{const liftdefl} are all defined in the standard way.
+*}
+
+class liftdomain = "domain" +
+  assumes liftemb_eq: "liftemb = udom_emb u_approx oo u_map\<cdot>emb"
+  assumes liftprj_eq: "liftprj = u_map\<cdot>prj oo udom_prj u_approx"
+  assumes liftdefl_eq: "liftdefl TYPE('a::cpo) = u_defl\<cdot>DEFL('a)"
+
+text {* Temporarily relax type constraints. *}
+
+setup {*
+  fold Sign.add_const_constraint
+  [ (@{const_name defl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
+  , (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"})
+  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"})
+  , (@{const_name liftdefl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
+  , (@{const_name liftemb}, SOME @{typ "'a::pcpo u \<rightarrow> udom"})
+  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::pcpo u"}) ]
+*}
+
+lemma liftdomain_class_intro:
+  assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+  assumes liftprj: "(liftprj :: udom \<rightarrow> 'a u) = u_map\<cdot>prj oo udom_prj u_approx"
+  assumes liftdefl: "liftdefl TYPE('a) = u_defl\<cdot>DEFL('a)"
+  assumes ep_pair: "ep_pair emb (prj :: udom \<rightarrow> 'a)"
+  assumes cast_defl: "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
+  shows "OFCLASS('a, liftdomain_class)"
+proof
+  show "ep_pair liftemb (liftprj :: udom \<rightarrow> 'a u)"
+    unfolding liftemb liftprj
+    by (intro ep_pair_comp ep_pair_u_map ep_pair ep_pair_udom u_approx)
+  show "cast\<cdot>LIFTDEFL('a) = liftemb oo (liftprj :: udom \<rightarrow> 'a u)"
+    unfolding liftemb liftprj liftdefl
+    by (simp add: cfcomp1 cast_u_defl cast_defl u_map_map)
+next
+qed fact+
+
+text {* Restore original type constraints. *}
+
+setup {*
+  fold Sign.add_const_constraint
+  [ (@{const_name defl}, SOME @{typ "'a::domain itself \<Rightarrow> defl"})
+  , (@{const_name emb}, SOME @{typ "'a::domain \<rightarrow> udom"})
+  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::domain"})
+  , (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> defl"})
+  , (@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom"})
+  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::predomain u"}) ]
+*}
+
+subsection {* Class instance proofs *}
+
+subsubsection {* Universal domain *}
+
+instantiation udom :: liftdomain
+begin
+
+definition [simp]:
+  "emb = (ID :: udom \<rightarrow> udom)"
+
+definition [simp]:
+  "prj = (ID :: udom \<rightarrow> udom)"
+
+definition
+  "defl (t::udom itself) = (\<Squnion>i. defl_principal (Abs_fin_defl (udom_approx i)))"
+
+definition
+  "(liftemb :: udom u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> udom u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::udom itself) = u_defl\<cdot>DEFL(udom)"
+
+instance
+using liftemb_udom_def liftprj_udom_def liftdefl_udom_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> udom)"
+    by (simp add: ep_pair.intro)
+  show "cast\<cdot>DEFL(udom) = emb oo (prj :: udom \<rightarrow> udom)"
+    unfolding defl_udom_def
+    apply (subst contlub_cfun_arg)
+    apply (rule chainI)
+    apply (rule defl.principal_mono)
+    apply (simp add: below_fin_defl_def)
+    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
+    apply (rule chainE)
+    apply (rule chain_udom_approx)
+    apply (subst cast_defl_principal)
+    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
+    done
+qed
+
+end
+
+subsubsection {* Lifted cpo *}
+
+instantiation u :: (predomain) liftdomain
+begin
+
+definition
+  "emb = liftemb"
+
+definition
+  "prj = liftprj"
+
+definition
+  "defl (t::'a u itself) = LIFTDEFL('a)"
+
+definition
+  "(liftemb :: 'a u u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a u u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::'a u itself) = u_defl\<cdot>DEFL('a u)"
+
+instance
+using liftemb_u_def liftprj_u_def liftdefl_u_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a u)"
+    unfolding emb_u_def prj_u_def
+    by (rule predomain_ep)
+  show "cast\<cdot>DEFL('a u) = emb oo (prj :: udom \<rightarrow> 'a u)"
+    unfolding emb_u_def prj_u_def defl_u_def
+    by (rule cast_liftdefl)
+qed
+
+end
+
+lemma DEFL_u: "DEFL('a::predomain u) = LIFTDEFL('a)"
+by (rule defl_u_def)
+
+subsubsection {* Strict function space *}
+
+instantiation sfun :: ("domain", "domain") liftdomain
+begin
+
+definition
+  "emb = udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb"
+
+definition
+  "prj = sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx"
+
+definition
+  "defl (t::('a \<rightarrow>! 'b) itself) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+
+definition
+  "(liftemb :: ('a \<rightarrow>! 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> ('a \<rightarrow>! 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::('a \<rightarrow>! 'b) itself) = u_defl\<cdot>DEFL('a \<rightarrow>! 'b)"
+
+instance
+using liftemb_sfun_def liftprj_sfun_def liftdefl_sfun_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
+    unfolding emb_sfun_def prj_sfun_def
+    using ep_pair_udom [OF sfun_approx]
+    by (intro ep_pair_comp ep_pair_sfun_map ep_pair_emb_prj)
+  show "cast\<cdot>DEFL('a \<rightarrow>! 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
+    unfolding emb_sfun_def prj_sfun_def defl_sfun_def cast_sfun_defl
+    by (simp add: cast_DEFL oo_def sfun_eq_iff sfun_map_map)
+qed
+
+end
+
+lemma DEFL_sfun:
+  "DEFL('a::domain \<rightarrow>! 'b::domain) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+by (rule defl_sfun_def)
+
+subsubsection {* Continuous function space *}
+
+text {*
+  Types @{typ "'a \<rightarrow> 'b"} and @{typ "'a u \<rightarrow>! 'b"} are isomorphic.
+*}
+
+definition
+  "encode_cfun = (\<Lambda> f. sfun_abs\<cdot>(fup\<cdot>f))"
+
+definition
+  "decode_cfun = (\<Lambda> g x. sfun_rep\<cdot>g\<cdot>(up\<cdot>x))"
+
+lemma decode_encode_cfun [simp]: "decode_cfun\<cdot>(encode_cfun\<cdot>x) = x"
+unfolding encode_cfun_def decode_cfun_def
+by (simp add: eta_cfun)
+
+lemma encode_decode_cfun [simp]: "encode_cfun\<cdot>(decode_cfun\<cdot>y) = y"
+unfolding encode_cfun_def decode_cfun_def
+apply (simp add: sfun_eq_iff strictify_cancel)
+apply (rule cfun_eqI, case_tac x, simp_all)
+done
+
+instantiation cfun :: (predomain, "domain") liftdomain
+begin
+
+definition
+  "emb = (udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb) oo encode_cfun"
+
+definition
+  "prj = decode_cfun oo (sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx)"
+
+definition
+  "defl (t::('a \<rightarrow> 'b) itself) = sfun_defl\<cdot>DEFL('a u)\<cdot>DEFL('b)"
+
+definition
+  "(liftemb :: ('a \<rightarrow> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> ('a \<rightarrow> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::('a \<rightarrow> 'b) itself) = u_defl\<cdot>DEFL('a \<rightarrow> 'b)"
+
+instance
+using liftemb_cfun_def liftprj_cfun_def liftdefl_cfun_def
+proof (rule liftdomain_class_intro)
+  have "ep_pair encode_cfun decode_cfun"
+    by (rule ep_pair.intro, simp_all)
+  thus "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
+    unfolding emb_cfun_def prj_cfun_def
+    apply (rule ep_pair_comp)
+    apply (rule ep_pair_comp)
+    apply (intro ep_pair_sfun_map ep_pair_emb_prj)
+    apply (rule ep_pair_udom [OF sfun_approx])
+    done
+  show "cast\<cdot>DEFL('a \<rightarrow> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
+    unfolding emb_cfun_def prj_cfun_def defl_cfun_def cast_sfun_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff sfun_map_map)
+qed
+
+end
+
+lemma DEFL_cfun:
+  "DEFL('a::predomain \<rightarrow> 'b::domain) = sfun_defl\<cdot>DEFL('a u)\<cdot>DEFL('b)"
+by (rule defl_cfun_def)
+
+subsubsection {* Cartesian product *}
+
+text {*
+  Types @{typ "('a * 'b) u"} and @{typ "'a u \<otimes> 'b u"} are isomorphic.
+*}
+
+definition
+  "encode_prod_u = (\<Lambda>(up\<cdot>(x, y)). (:up\<cdot>x, up\<cdot>y:))"
+
+definition
+  "decode_prod_u = (\<Lambda>(:up\<cdot>x, up\<cdot>y:). up\<cdot>(x, y))"
+
+lemma decode_encode_prod_u [simp]: "decode_prod_u\<cdot>(encode_prod_u\<cdot>x) = x"
+unfolding encode_prod_u_def decode_prod_u_def
+by (case_tac x, simp, rename_tac y, case_tac y, simp)
+
+lemma encode_decode_prod_u [simp]: "encode_prod_u\<cdot>(decode_prod_u\<cdot>y) = y"
+unfolding encode_prod_u_def decode_prod_u_def
+apply (case_tac y, simp, rename_tac a b)
+apply (case_tac a, simp, case_tac b, simp, simp)
+done
+
+instantiation prod :: (predomain, predomain) predomain
+begin
+
+definition
+  "liftemb =
+    (udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb) oo encode_prod_u"
+
+definition
+  "liftprj =
+    decode_prod_u oo (sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx)"
+
+definition
+  "liftdefl (t::('a \<times> 'b) itself) = sprod_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
+
+instance proof
+  have "ep_pair encode_prod_u decode_prod_u"
+    by (rule ep_pair.intro, simp_all)
+  thus "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a \<times> 'b) u)"
+    unfolding liftemb_prod_def liftprj_prod_def
+    apply (rule ep_pair_comp)
+    apply (rule ep_pair_comp)
+    apply (intro ep_pair_sprod_map ep_pair_emb_prj)
+    apply (rule ep_pair_udom [OF sprod_approx])
+    done
+  show "cast\<cdot>LIFTDEFL('a \<times> 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a \<times> 'b) u)"
+    unfolding liftemb_prod_def liftprj_prod_def liftdefl_prod_def
+    by (simp add: cast_sprod_defl cast_DEFL cfcomp1 sprod_map_map)
+qed
+
+end
+
+instantiation prod :: ("domain", "domain") "domain"
+begin
+
+definition
+  "emb = udom_emb prod_approx oo cprod_map\<cdot>emb\<cdot>emb"
+
+definition
+  "prj = cprod_map\<cdot>prj\<cdot>prj oo udom_prj prod_approx"
+
+definition
+  "defl (t::('a \<times> 'b) itself) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+
+instance proof
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<times> 'b)"
+    unfolding emb_prod_def prj_prod_def
+    using ep_pair_udom [OF prod_approx]
+    by (intro ep_pair_comp ep_pair_cprod_map ep_pair_emb_prj)
+next
+  show "cast\<cdot>DEFL('a \<times> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<times> 'b)"
+    unfolding emb_prod_def prj_prod_def defl_prod_def cast_prod_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff cprod_map_map)
+qed
+
+end
+
+lemma DEFL_prod:
+  "DEFL('a::domain \<times> 'b::domain) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+by (rule defl_prod_def)
+
+lemma LIFTDEFL_prod:
+  "LIFTDEFL('a::predomain \<times> 'b::predomain) = sprod_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
+by (rule liftdefl_prod_def)
+
+subsubsection {* Strict product *}
+
+instantiation sprod :: ("domain", "domain") liftdomain
+begin
+
+definition
+  "emb = udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb"
+
+definition
+  "prj = sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx"
+
+definition
+  "defl (t::('a \<otimes> 'b) itself) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+
+definition
+  "(liftemb :: ('a \<otimes> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> ('a \<otimes> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::('a \<otimes> 'b) itself) = u_defl\<cdot>DEFL('a \<otimes> 'b)"
+
+instance
+using liftemb_sprod_def liftprj_sprod_def liftdefl_sprod_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
+    unfolding emb_sprod_def prj_sprod_def
+    using ep_pair_udom [OF sprod_approx]
+    by (intro ep_pair_comp ep_pair_sprod_map ep_pair_emb_prj)
+next
+  show "cast\<cdot>DEFL('a \<otimes> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
+    unfolding emb_sprod_def prj_sprod_def defl_sprod_def cast_sprod_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff sprod_map_map)
+qed
+
+end
+
+lemma DEFL_sprod:
+  "DEFL('a::domain \<otimes> 'b::domain) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+by (rule defl_sprod_def)
+
+subsubsection {* Discrete cpo *}
+
+definition discr_approx :: "nat \<Rightarrow> 'a::countable discr u \<rightarrow> 'a discr u"
+  where "discr_approx = (\<lambda>i. \<Lambda>(up\<cdot>x). if to_nat (undiscr x) < i then up\<cdot>x else \<bottom>)"
+
+lemma chain_discr_approx [simp]: "chain discr_approx"
+unfolding discr_approx_def
+by (rule chainI, simp add: monofun_cfun monofun_LAM)
+
+lemma lub_discr_approx [simp]: "(\<Squnion>i. discr_approx i) = ID"
+apply (rule cfun_eqI)
+apply (simp add: contlub_cfun_fun)
+apply (simp add: discr_approx_def)
+apply (case_tac x, simp)
+apply (rule lub_eqI)
+apply (rule is_lubI)
+apply (rule ub_rangeI, simp)
+apply (drule ub_rangeD)
+apply (erule rev_below_trans)
+apply simp
+apply (rule lessI)
+done
+
+lemma inj_on_undiscr [simp]: "inj_on undiscr A"
+using Discr_undiscr by (rule inj_on_inverseI)
+
+lemma finite_deflation_discr_approx: "finite_deflation (discr_approx i)"
+proof
+  fix x :: "'a discr u"
+  show "discr_approx i\<cdot>x \<sqsubseteq> x"
+    unfolding discr_approx_def
+    by (cases x, simp, simp)
+  show "discr_approx i\<cdot>(discr_approx i\<cdot>x) = discr_approx i\<cdot>x"
+    unfolding discr_approx_def
+    by (cases x, simp, simp)
+  show "finite {x::'a discr u. discr_approx i\<cdot>x = x}"
+  proof (rule finite_subset)
+    let ?S = "insert (\<bottom>::'a discr u) ((\<lambda>x. up\<cdot>x) ` undiscr -` to_nat -` {..<i})"
+    show "{x::'a discr u. discr_approx i\<cdot>x = x} \<subseteq> ?S"
+      unfolding discr_approx_def
+      by (rule subsetI, case_tac x, simp, simp split: split_if_asm)
+    show "finite ?S"
+      by (simp add: finite_vimageI)
+  qed
+qed
+
+lemma discr_approx: "approx_chain discr_approx"
+using chain_discr_approx lub_discr_approx finite_deflation_discr_approx
+by (rule approx_chain.intro)
+
+instantiation discr :: (countable) predomain
+begin
+
+definition
+  "liftemb = udom_emb discr_approx"
+
+definition
+  "liftprj = udom_prj discr_approx"
+
+definition
+  "liftdefl (t::'a discr itself) =
+    (\<Squnion>i. defl_principal (Abs_fin_defl (liftemb oo discr_approx i oo liftprj)))"
+
+instance proof
+  show "ep_pair liftemb (liftprj :: udom \<rightarrow> 'a discr u)"
+    unfolding liftemb_discr_def liftprj_discr_def
+    by (rule ep_pair_udom [OF discr_approx])
+  show "cast\<cdot>LIFTDEFL('a discr) = liftemb oo (liftprj :: udom \<rightarrow> 'a discr u)"
+    unfolding liftemb_discr_def liftprj_discr_def liftdefl_discr_def
+    apply (subst contlub_cfun_arg)
+    apply (rule chainI)
+    apply (rule defl.principal_mono)
+    apply (simp add: below_fin_defl_def)
+    apply (simp add: Abs_fin_defl_inverse
+        ep_pair.finite_deflation_e_d_p [OF ep_pair_udom [OF discr_approx]]
+        approx_chain.finite_deflation_approx [OF discr_approx])
+    apply (intro monofun_cfun below_refl)
+    apply (rule chainE)
+    apply (rule chain_discr_approx)
+    apply (subst cast_defl_principal)
+    apply (simp add: Abs_fin_defl_inverse
+        ep_pair.finite_deflation_e_d_p [OF ep_pair_udom [OF discr_approx]]
+        approx_chain.finite_deflation_approx [OF discr_approx])
+    apply (simp add: lub_distribs)
+    done
+qed
+
+end
+
+subsubsection {* Strict sum *}
+
+instantiation ssum :: ("domain", "domain") liftdomain
+begin
+
+definition
+  "emb = udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb"
+
+definition
+  "prj = ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx"
+
+definition
+  "defl (t::('a \<oplus> 'b) itself) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+
+definition
+  "(liftemb :: ('a \<oplus> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> ('a \<oplus> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::('a \<oplus> 'b) itself) = u_defl\<cdot>DEFL('a \<oplus> 'b)"
+
+instance
+using liftemb_ssum_def liftprj_ssum_def liftdefl_ssum_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
+    unfolding emb_ssum_def prj_ssum_def
+    using ep_pair_udom [OF ssum_approx]
+    by (intro ep_pair_comp ep_pair_ssum_map ep_pair_emb_prj)
+  show "cast\<cdot>DEFL('a \<oplus> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
+    unfolding emb_ssum_def prj_ssum_def defl_ssum_def cast_ssum_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff ssum_map_map)
+qed
+
+end
+
+lemma DEFL_ssum:
+  "DEFL('a::domain \<oplus> 'b::domain) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
+by (rule defl_ssum_def)
+
+subsubsection {* Lifted HOL type *}
+
+instantiation lift :: (countable) liftdomain
+begin
+
+definition
+  "emb = emb oo (\<Lambda> x. Rep_lift x)"
+
+definition
+  "prj = (\<Lambda> y. Abs_lift y) oo prj"
+
+definition
+  "defl (t::'a lift itself) = DEFL('a discr u)"
+
+definition
+  "(liftemb :: 'a lift u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a lift u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::'a lift itself) = u_defl\<cdot>DEFL('a lift)"
+
+instance
+using liftemb_lift_def liftprj_lift_def liftdefl_lift_def
+proof (rule liftdomain_class_intro)
+  note [simp] = cont_Rep_lift cont_Abs_lift Rep_lift_inverse Abs_lift_inverse
+  have "ep_pair (\<Lambda>(x::'a lift). Rep_lift x) (\<Lambda> y. Abs_lift y)"
+    by (simp add: ep_pair_def)
+  thus "ep_pair emb (prj :: udom \<rightarrow> 'a lift)"
+    unfolding emb_lift_def prj_lift_def
+    using ep_pair_emb_prj by (rule ep_pair_comp)
+  show "cast\<cdot>DEFL('a lift) = emb oo (prj :: udom \<rightarrow> 'a lift)"
+    unfolding emb_lift_def prj_lift_def defl_lift_def cast_DEFL
+    by (simp add: cfcomp1)
+qed
+
+end
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Cfun.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,543 @@
+(*  Title:      HOLCF/Cfun.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* The type of continuous functions *}
+
+theory Cfun
+imports Cpodef Fun_Cpo Product_Cpo
+begin
+
+default_sort cpo
+
+subsection {* Definition of continuous function type *}
+
+cpodef ('a, 'b) cfun (infixr "->" 0) = "{f::'a => 'b. cont f}"
+by (auto intro: cont_const adm_cont)
+
+type_notation (xsymbols)
+  cfun  ("(_ \<rightarrow>/ _)" [1, 0] 0)
+
+notation
+  Rep_cfun  ("(_$/_)" [999,1000] 999)
+
+notation (xsymbols)
+  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)
+
+notation (HTML output)
+  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)
+
+subsection {* Syntax for continuous lambda abstraction *}
+
+syntax "_cabs" :: "'a"
+
+parse_translation {*
+(* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
+  [mk_binder_tr (@{syntax_const "_cabs"}, @{const_syntax Abs_cfun})];
+*}
+
+text {* To avoid eta-contraction of body: *}
+typed_print_translation {*
+  let
+    fun cabs_tr' _ _ [Abs abs] = let
+          val (x,t) = atomic_abs_tr' abs
+        in Syntax.const @{syntax_const "_cabs"} $ x $ t end
+
+      | cabs_tr' _ T [t] = let
+          val xT = domain_type (domain_type T);
+          val abs' = ("x",xT,(incr_boundvars 1 t)$Bound 0);
+          val (x,t') = atomic_abs_tr' abs';
+        in Syntax.const @{syntax_const "_cabs"} $ x $ t' end;
+
+  in [(@{const_syntax Abs_cfun}, cabs_tr')] end;
+*}
+
+text {* Syntax for nested abstractions *}
+
+syntax
+  "_Lambda" :: "[cargs, 'a] \<Rightarrow> logic"  ("(3LAM _./ _)" [1000, 10] 10)
+
+syntax (xsymbols)
+  "_Lambda" :: "[cargs, 'a] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)
+
+parse_ast_translation {*
+(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
+(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
+  let
+    fun Lambda_ast_tr [pats, body] =
+          Syntax.fold_ast_p @{syntax_const "_cabs"}
+            (Syntax.unfold_ast @{syntax_const "_cargs"} pats, body)
+      | Lambda_ast_tr asts = raise Syntax.AST ("Lambda_ast_tr", asts);
+  in [(@{syntax_const "_Lambda"}, Lambda_ast_tr)] end;
+*}
+
+print_ast_translation {*
+(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
+(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
+  let
+    fun cabs_ast_tr' asts =
+      (case Syntax.unfold_ast_p @{syntax_const "_cabs"}
+          (Syntax.Appl (Syntax.Constant @{syntax_const "_cabs"} :: asts)) of
+        ([], _) => raise Syntax.AST ("cabs_ast_tr'", asts)
+      | (xs, body) => Syntax.Appl
+          [Syntax.Constant @{syntax_const "_Lambda"},
+           Syntax.fold_ast @{syntax_const "_cargs"} xs, body]);
+  in [(@{syntax_const "_cabs"}, cabs_ast_tr')] end
+*}
+
+text {* Dummy patterns for continuous abstraction *}
+translations
+  "\<Lambda> _. t" => "CONST Abs_cfun (\<lambda> _. t)"
+
+subsection {* Continuous function space is pointed *}
+
+lemma UU_cfun: "\<bottom> \<in> cfun"
+by (simp add: cfun_def inst_fun_pcpo)
+
+instance cfun :: (cpo, discrete_cpo) discrete_cpo
+by intro_classes (simp add: below_cfun_def Rep_cfun_inject)
+
+instance cfun :: (cpo, pcpo) pcpo
+by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def UU_cfun])
+
+lemmas Rep_cfun_strict =
+  typedef_Rep_strict [OF type_definition_cfun below_cfun_def UU_cfun]
+
+lemmas Abs_cfun_strict =
+  typedef_Abs_strict [OF type_definition_cfun below_cfun_def UU_cfun]
+
+text {* function application is strict in its first argument *}
+
+lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
+by (simp add: Rep_cfun_strict)
+
+lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
+by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)
+
+text {* for compatibility with old HOLCF-Version *}
+lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
+by simp
+
+subsection {* Basic properties of continuous functions *}
+
+text {* Beta-equality for continuous functions *}
+
+lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
+by (simp add: Abs_cfun_inverse cfun_def)
+
+lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
+by (simp add: Abs_cfun_inverse2)
+
+text {* Beta-reduction simproc *}
+
+text {*
+  Given the term @{term "(\<Lambda> x. f x)\<cdot>y"}, the procedure tries to
+  construct the theorem @{term "(\<Lambda> x. f x)\<cdot>y == f y"}.  If this
+  theorem cannot be completely solved by the cont2cont rules, then
+  the procedure returns the ordinary conditional @{text beta_cfun}
+  rule.
+
+  The simproc does not solve any more goals that would be solved by
+  using @{text beta_cfun} as a simp rule.  The advantage of the
+  simproc is that it can avoid deeply-nested calls to the simplifier
+  that would otherwise be caused by large continuity side conditions.
+*}
+
+simproc_setup beta_cfun_proc ("Abs_cfun f\<cdot>x") = {*
+  fn phi => fn ss => fn ct =>
+    let
+      val dest = Thm.dest_comb;
+      val (f, x) = (apfst (snd o dest o snd o dest) o dest) ct;
+      val [T, U] = Thm.dest_ctyp (ctyp_of_term f);
+      val tr = instantiate' [SOME T, SOME U] [SOME f, SOME x]
+          (mk_meta_eq @{thm beta_cfun});
+      val rules = Cont2ContData.get (Simplifier.the_context ss);
+      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
+    in SOME (perhaps (SINGLE (tac 1)) tr) end
+*}
+
+text {* Eta-equality for continuous functions *}
+
+lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
+by (rule Rep_cfun_inverse)
+
+text {* Extensionality for continuous functions *}
+
+lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
+by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)
+
+lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
+by (simp add: cfun_eq_iff)
+
+text {* Extensionality wrt. ordering for continuous functions *}
+
+lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)" 
+by (simp add: below_cfun_def fun_below_iff)
+
+lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
+by (simp add: cfun_below_iff)
+
+text {* Congruence for continuous function application *}
+
+lemma cfun_cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f\<cdot>x = g\<cdot>y"
+by simp
+
+lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
+by simp
+
+lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
+by simp
+
+subsection {* Continuity of application *}
+
+lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
+by (rule cont_Rep_cfun [THEN cont2cont_fun])
+
+lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
+apply (cut_tac x=f in Rep_cfun)
+apply (simp add: cfun_def)
+done
+
+lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]
+
+lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono, standard]
+lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono, standard]
+
+text {* contlub, cont properties of @{term Rep_cfun} in each argument *}
+
+lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
+by (rule cont_Rep_cfun2 [THEN cont2contlubE])
+
+lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
+by (rule cont_Rep_cfun1 [THEN cont2contlubE])
+
+text {* monotonicity of application *}
+
+lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
+by (simp add: cfun_below_iff)
+
+lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
+by (rule monofun_Rep_cfun2 [THEN monofunE])
+
+lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
+by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])
+
+text {* ch2ch - rules for the type @{typ "'a -> 'b"} *}
+
+lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
+by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])
+
+lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
+by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])
+
+lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
+by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])
+
+lemma ch2ch_Rep_cfun [simp]:
+  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
+by (simp add: chain_def monofun_cfun)
+
+lemma ch2ch_LAM [simp]:
+  "\<lbrakk>\<And>x. chain (\<lambda>i. S i x); \<And>i. cont (\<lambda>x. S i x)\<rbrakk> \<Longrightarrow> chain (\<lambda>i. \<Lambda> x. S i x)"
+by (simp add: chain_def cfun_below_iff)
+
+text {* contlub, cont properties of @{term Rep_cfun} in both arguments *}
+
+lemma contlub_cfun: 
+  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. F i\<cdot>(Y i))"
+by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)
+
+lemma cont_cfun: 
+  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> range (\<lambda>i. F i\<cdot>(Y i)) <<| (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i)"
+apply (rule thelubE)
+apply (simp only: ch2ch_Rep_cfun)
+apply (simp only: contlub_cfun)
+done
+
+lemma contlub_LAM:
+  "\<lbrakk>\<And>x. chain (\<lambda>i. F i x); \<And>i. cont (\<lambda>x. F i x)\<rbrakk>
+    \<Longrightarrow> (\<Lambda> x. \<Squnion>i. F i x) = (\<Squnion>i. \<Lambda> x. F i x)"
+apply (simp add: lub_cfun)
+apply (simp add: Abs_cfun_inverse2)
+apply (simp add: thelub_fun ch2ch_lambda)
+done
+
+lemmas lub_distribs = 
+  contlub_cfun [symmetric]
+  contlub_LAM [symmetric]
+
+text {* strictness *}
+
+lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
+apply (rule UU_I)
+apply (erule subst)
+apply (rule minimal [THEN monofun_cfun_arg])
+done
+
+text {* type @{typ "'a -> 'b"} is chain complete *}
+
+lemma lub_cfun: "chain F \<Longrightarrow> range F <<| (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
+by (simp only: contlub_cfun_fun [symmetric] eta_cfun thelubE)
+
+lemma thelub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
+by (rule lub_cfun [THEN lub_eqI])
+
+subsection {* Continuity simplification procedure *}
+
+text {* cont2cont lemma for @{term Rep_cfun} *}
+
+lemma cont2cont_APP [simp, cont2cont]:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes t: "cont (\<lambda>x. t x)"
+  shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
+proof -
+  have 1: "\<And>y. cont (\<lambda>x. (f x)\<cdot>y)"
+    using cont_Rep_cfun1 f by (rule cont_compose)
+  show "cont (\<lambda>x. (f x)\<cdot>(t x))"
+    using t cont_Rep_cfun2 1 by (rule cont_apply)
+qed
+
+text {*
+  Two specific lemmas for the combination of LCF and HOL terms.
+  These lemmas are needed in theories that use types like @{typ "'a \<rightarrow> 'b \<Rightarrow> 'c"}.
+*}
+
+lemma cont_APP_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
+by (rule cont2cont_APP [THEN cont2cont_fun])
+
+lemma cont_APP_app_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
+by (rule cont_APP_app [THEN cont2cont_fun])
+
+
+text {* cont2mono Lemma for @{term "%x. LAM y. c1(x)(y)"} *}
+
+lemma cont2mono_LAM:
+  "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
+    \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
+  unfolding monofun_def cfun_below_iff by simp
+
+text {* cont2cont Lemma for @{term "%x. LAM y. f x y"} *}
+
+text {*
+  Not suitable as a cont2cont rule, because on nested lambdas
+  it causes exponential blow-up in the number of subgoals.
+*}
+
+lemma cont2cont_LAM:
+  assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
+  assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
+  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
+proof (rule cont_Abs_cfun)
+  fix x
+  from f1 show "f x \<in> cfun" by (simp add: cfun_def)
+  from f2 show "cont f" by (rule cont2cont_lambda)
+qed
+
+text {*
+  This version does work as a cont2cont rule, since it
+  has only a single subgoal.
+*}
+
+lemma cont2cont_LAM' [simp, cont2cont]:
+  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
+  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
+  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
+using assms by (simp add: cont2cont_LAM prod_cont_iff)
+
+lemma cont2cont_LAM_discrete [simp, cont2cont]:
+  "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
+by (simp add: cont2cont_LAM)
+
+subsection {* Miscellaneous *}
+
+text {* Monotonicity of @{term Abs_cfun} *}
+
+lemma monofun_LAM:
+  "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
+by (simp add: cfun_below_iff)
+
+text {* some lemmata for functions with flat/chfin domain/range types *}
+
+lemma chfin_Rep_cfunR: "chain (Y::nat => 'a::cpo->'b::chfin)  
+      ==> !s. ? n. (LUB i. Y i)$s = Y n$s"
+apply (rule allI)
+apply (subst contlub_cfun_fun)
+apply assumption
+apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
+done
+
+lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
+by (rule adm_subst, simp, rule adm_chfin)
+
+subsection {* Continuous injection-retraction pairs *}
+
+text {* Continuous retractions are strict. *}
+
+lemma retraction_strict:
+  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
+apply (rule UU_I)
+apply (drule_tac x="\<bottom>" in spec)
+apply (erule subst)
+apply (rule monofun_cfun_arg)
+apply (rule minimal)
+done
+
+lemma injection_eq:
+  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
+apply (rule iffI)
+apply (drule_tac f=f in cfun_arg_cong)
+apply simp
+apply simp
+done
+
+lemma injection_below:
+  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
+apply (rule iffI)
+apply (drule_tac f=f in monofun_cfun_arg)
+apply simp
+apply (erule monofun_cfun_arg)
+done
+
+lemma injection_defined_rev:
+  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; g\<cdot>z = \<bottom>\<rbrakk> \<Longrightarrow> z = \<bottom>"
+apply (drule_tac f=f in cfun_arg_cong)
+apply (simp add: retraction_strict)
+done
+
+lemma injection_defined:
+  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; z \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
+by (erule contrapos_nn, rule injection_defined_rev)
+
+text {* a result about functions with flat codomain *}
+
+lemma flat_eqI: "\<lbrakk>(x::'a::flat) \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> x = y"
+by (drule ax_flat, simp)
+
+lemma flat_codom:
+  "f\<cdot>x = (c::'b::flat) \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
+apply (case_tac "f\<cdot>x = \<bottom>")
+apply (rule disjI1)
+apply (rule UU_I)
+apply (erule_tac t="\<bottom>" in subst)
+apply (rule minimal [THEN monofun_cfun_arg])
+apply clarify
+apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
+apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
+apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
+done
+
+subsection {* Identity and composition *}
+
+definition
+  ID :: "'a \<rightarrow> 'a" where
+  "ID = (\<Lambda> x. x)"
+
+definition
+  cfcomp  :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c" where
+  oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"
+
+abbreviation
+  cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "oo" 100)  where
+  "f oo g == cfcomp\<cdot>f\<cdot>g"
+
+lemma ID1 [simp]: "ID\<cdot>x = x"
+by (simp add: ID_def)
+
+lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
+by (simp add: oo_def)
+
+lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
+by (simp add: cfcomp1)
+
+lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
+by (simp add: cfcomp1)
+
+lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
+by (simp add: cfun_eq_iff)
+
+text {*
+  Show that interpretation of (pcpo,@{text "_->_"}) is a category.
+  The class of objects is interpretation of syntactical class pcpo.
+  The class of arrows  between objects @{typ 'a} and @{typ 'b} is interpret. of @{typ "'a -> 'b"}.
+  The identity arrow is interpretation of @{term ID}.
+  The composition of f and g is interpretation of @{text "oo"}.
+*}
+
+lemma ID2 [simp]: "f oo ID = f"
+by (rule cfun_eqI, simp)
+
+lemma ID3 [simp]: "ID oo f = f"
+by (rule cfun_eqI, simp)
+
+lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
+by (rule cfun_eqI, simp)
+
+subsection {* Strictified functions *}
+
+default_sort pcpo
+
+definition
+  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b" where
+  "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"
+
+lemma cont_seq: "cont (\<lambda>x. if x = \<bottom> then \<bottom> else y)"
+unfolding cont_def is_lub_def is_ub_def ball_simps
+by (simp add: lub_eq_bottom_iff)
+
+lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
+unfolding seq_def by (simp add: cont_seq)
+
+lemma seq1 [simp]: "seq\<cdot>\<bottom> = \<bottom>"
+by (simp add: seq_conv_if)
+
+lemma seq2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
+by (simp add: seq_conv_if)
+
+lemma seq3 [simp]: "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
+by (simp add: seq_conv_if)
+
+definition
+  strictify  :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b" where
+  "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"
+
+lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
+unfolding strictify_def by simp
+
+lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by (simp add: strictify_conv_if)
+
+lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
+by (simp add: strictify_conv_if)
+
+subsection {* Continuity of let-bindings *}
+
+lemma cont2cont_Let:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
+  assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
+  shows "cont (\<lambda>x. let y = f x in g x y)"
+unfolding Let_def using f g2 g1 by (rule cont_apply)
+
+lemma cont2cont_Let' [simp, cont2cont]:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
+  shows "cont (\<lambda>x. let y = f x in g x y)"
+using f
+proof (rule cont2cont_Let)
+  fix x show "cont (\<lambda>y. g x y)"
+    using g by (simp add: prod_cont_iff)
+next
+  fix y show "cont (\<lambda>x. g x y)"
+    using g by (simp add: prod_cont_iff)
+qed
+
+text {* The simple version (suggested by Joachim Breitner) is needed if
+  the type of the defined term is not a cpo. *}
+
+lemma cont2cont_Let_simple [simp, cont2cont]:
+  assumes "\<And>y. cont (\<lambda>x. g x y)"
+  shows "cont (\<lambda>x. let y = t in g x y)"
+unfolding Let_def using assms .
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/CompactBasis.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,111 @@
+(*  Title:      HOLCF/CompactBasis.thy
+    Author:     Brian Huffman
+*)
+
+header {* A compact basis for powerdomains *}
+
+theory CompactBasis
+imports Bifinite
+begin
+
+default_sort "domain"
+
+subsection {* A compact basis for powerdomains *}
+
+typedef 'a pd_basis =
+  "{S::'a compact_basis set. finite S \<and> S \<noteq> {}}"
+by (rule_tac x="{arbitrary}" in exI, simp)
+
+lemma finite_Rep_pd_basis [simp]: "finite (Rep_pd_basis u)"
+by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
+
+lemma Rep_pd_basis_nonempty [simp]: "Rep_pd_basis u \<noteq> {}"
+by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
+
+text {* The powerdomain basis type is countable. *}
+
+lemma pd_basis_countable: "\<exists>f::'a pd_basis \<Rightarrow> nat. inj f"
+proof -
+  obtain g :: "'a compact_basis \<Rightarrow> nat" where "inj g"
+    using compact_basis.countable ..
+  hence image_g_eq: "\<And>A B. g ` A = g ` B \<longleftrightarrow> A = B"
+    by (rule inj_image_eq_iff)
+  have "inj (\<lambda>t. set_encode (g ` Rep_pd_basis t))"
+    by (simp add: inj_on_def set_encode_eq image_g_eq Rep_pd_basis_inject)
+  thus ?thesis by - (rule exI)
+  (* FIXME: why doesn't ".." or "by (rule exI)" work? *)
+qed
+
+subsection {* Unit and plus constructors *}
+
+definition
+  PDUnit :: "'a compact_basis \<Rightarrow> 'a pd_basis" where
+  "PDUnit = (\<lambda>x. Abs_pd_basis {x})"
+
+definition
+  PDPlus :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> 'a pd_basis" where
+  "PDPlus t u = Abs_pd_basis (Rep_pd_basis t \<union> Rep_pd_basis u)"
+
+lemma Rep_PDUnit:
+  "Rep_pd_basis (PDUnit x) = {x}"
+unfolding PDUnit_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)
+
+lemma Rep_PDPlus:
+  "Rep_pd_basis (PDPlus u v) = Rep_pd_basis u \<union> Rep_pd_basis v"
+unfolding PDPlus_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)
+
+lemma PDUnit_inject [simp]: "(PDUnit a = PDUnit b) = (a = b)"
+unfolding Rep_pd_basis_inject [symmetric] Rep_PDUnit by simp
+
+lemma PDPlus_assoc: "PDPlus (PDPlus t u) v = PDPlus t (PDPlus u v)"
+unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_assoc)
+
+lemma PDPlus_commute: "PDPlus t u = PDPlus u t"
+unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_commute)
+
+lemma PDPlus_absorb: "PDPlus t t = t"
+unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_absorb)
+
+lemma pd_basis_induct1:
+  assumes PDUnit: "\<And>a. P (PDUnit a)"
+  assumes PDPlus: "\<And>a t. P t \<Longrightarrow> P (PDPlus (PDUnit a) t)"
+  shows "P x"
+apply (induct x, unfold pd_basis_def, clarify)
+apply (erule (1) finite_ne_induct)
+apply (cut_tac a=x in PDUnit)
+apply (simp add: PDUnit_def)
+apply (drule_tac a=x in PDPlus)
+apply (simp add: PDUnit_def PDPlus_def
+  Abs_pd_basis_inverse [unfolded pd_basis_def])
+done
+
+lemma pd_basis_induct:
+  assumes PDUnit: "\<And>a. P (PDUnit a)"
+  assumes PDPlus: "\<And>t u. \<lbrakk>P t; P u\<rbrakk> \<Longrightarrow> P (PDPlus t u)"
+  shows "P x"
+apply (induct x rule: pd_basis_induct1)
+apply (rule PDUnit, erule PDPlus [OF PDUnit])
+done
+
+subsection {* Fold operator *}
+
+definition
+  fold_pd ::
+    "('a compact_basis \<Rightarrow> 'b::type) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a pd_basis \<Rightarrow> 'b"
+  where "fold_pd g f t = fold1 f (g ` Rep_pd_basis t)"
+
+lemma fold_pd_PDUnit:
+  assumes "class.ab_semigroup_idem_mult f"
+  shows "fold_pd g f (PDUnit x) = g x"
+unfolding fold_pd_def Rep_PDUnit by simp
+
+lemma fold_pd_PDPlus:
+  assumes "class.ab_semigroup_idem_mult f"
+  shows "fold_pd g f (PDPlus t u) = f (fold_pd g f t) (fold_pd g f u)"
+proof -
+  interpret ab_semigroup_idem_mult f by fact
+  show ?thesis unfolding fold_pd_def Rep_PDPlus
+    by (simp add: image_Un fold1_Un2)
+qed
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Completion.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,433 @@
+(*  Title:      HOLCF/Completion.thy
+    Author:     Brian Huffman
+*)
+
+header {* Defining algebraic domains by ideal completion *}
+
+theory Completion
+imports Plain_HOLCF
+begin
+
+subsection {* Ideals over a preorder *}
+
+locale preorder =
+  fixes r :: "'a::type \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
+  assumes r_refl: "x \<preceq> x"
+  assumes r_trans: "\<lbrakk>x \<preceq> y; y \<preceq> z\<rbrakk> \<Longrightarrow> x \<preceq> z"
+begin
+
+definition
+  ideal :: "'a set \<Rightarrow> bool" where
+  "ideal A = ((\<exists>x. x \<in> A) \<and> (\<forall>x\<in>A. \<forall>y\<in>A. \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z) \<and>
+    (\<forall>x y. x \<preceq> y \<longrightarrow> y \<in> A \<longrightarrow> x \<in> A))"
+
+lemma idealI:
+  assumes "\<exists>x. x \<in> A"
+  assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
+  assumes "\<And>x y. \<lbrakk>x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
+  shows "ideal A"
+unfolding ideal_def using prems by fast
+
+lemma idealD1:
+  "ideal A \<Longrightarrow> \<exists>x. x \<in> A"
+unfolding ideal_def by fast
+
+lemma idealD2:
+  "\<lbrakk>ideal A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
+unfolding ideal_def by fast
+
+lemma idealD3:
+  "\<lbrakk>ideal A; x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
+unfolding ideal_def by fast
+
+lemma ideal_principal: "ideal {x. x \<preceq> z}"
+apply (rule idealI)
+apply (rule_tac x=z in exI)
+apply (fast intro: r_refl)
+apply (rule_tac x=z in bexI, fast)
+apply (fast intro: r_refl)
+apply (fast intro: r_trans)
+done
+
+lemma ex_ideal: "\<exists>A. ideal A"
+by (rule exI, rule ideal_principal)
+
+lemma lub_image_principal:
+  assumes f: "\<And>x y. x \<preceq> y \<Longrightarrow> f x \<sqsubseteq> f y"
+  shows "(\<Squnion>x\<in>{x. x \<preceq> y}. f x) = f y"
+apply (rule lub_eqI)
+apply (rule is_lub_maximal)
+apply (rule ub_imageI)
+apply (simp add: f)
+apply (rule imageI)
+apply (simp add: r_refl)
+done
+
+text {* The set of ideals is a cpo *}
+
+lemma ideal_UN:
+  fixes A :: "nat \<Rightarrow> 'a set"
+  assumes ideal_A: "\<And>i. ideal (A i)"
+  assumes chain_A: "\<And>i j. i \<le> j \<Longrightarrow> A i \<subseteq> A j"
+  shows "ideal (\<Union>i. A i)"
+ apply (rule idealI)
+   apply (cut_tac idealD1 [OF ideal_A], fast)
+  apply (clarify, rename_tac i j)
+  apply (drule subsetD [OF chain_A [OF le_maxI1]])
+  apply (drule subsetD [OF chain_A [OF le_maxI2]])
+  apply (drule (1) idealD2 [OF ideal_A])
+  apply blast
+ apply clarify
+ apply (drule (1) idealD3 [OF ideal_A])
+ apply fast
+done
+
+lemma typedef_ideal_po:
+  fixes Abs :: "'a set \<Rightarrow> 'b::below"
+  assumes type: "type_definition Rep Abs {S. ideal S}"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  shows "OFCLASS('b, po_class)"
+ apply (intro_classes, unfold below)
+   apply (rule subset_refl)
+  apply (erule (1) subset_trans)
+ apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
+ apply (erule (1) subset_antisym)
+done
+
+lemma
+  fixes Abs :: "'a set \<Rightarrow> 'b::po"
+  assumes type: "type_definition Rep Abs {S. ideal S}"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  assumes S: "chain S"
+  shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
+    and typedef_ideal_rep_lub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
+proof -
+  have 1: "ideal (\<Union>i. Rep (S i))"
+    apply (rule ideal_UN)
+     apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
+    apply (subst below [symmetric])
+    apply (erule chain_mono [OF S])
+    done
+  hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
+    by (simp add: type_definition.Abs_inverse [OF type])
+  show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
+    apply (rule is_lubI)
+     apply (rule is_ubI)
+     apply (simp add: below 2, fast)
+    apply (simp add: below 2 is_ub_def, fast)
+    done
+  hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
+    by (rule lub_eqI)
+  show 5: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
+    by (simp add: 4 2)
+qed
+
+lemma typedef_ideal_cpo:
+  fixes Abs :: "'a set \<Rightarrow> 'b::po"
+  assumes type: "type_definition Rep Abs {S. ideal S}"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  shows "OFCLASS('b, cpo_class)"
+by (default, rule exI, erule typedef_ideal_lub [OF type below])
+
+end
+
+interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
+apply unfold_locales
+apply (rule below_refl)
+apply (erule (1) below_trans)
+done
+
+subsection {* Lemmas about least upper bounds *}
+
+lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
+apply (erule exE, drule is_lub_lub)
+apply (drule is_lubD1)
+apply (erule (1) is_ubD)
+done
+
+lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
+by (erule exE, drule is_lub_lub, erule is_lubD2)
+
+subsection {* Locale for ideal completion *}
+
+locale ideal_completion = preorder +
+  fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
+  fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
+  assumes ideal_rep: "\<And>x. ideal (rep x)"
+  assumes rep_lub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
+  assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
+  assumes subset_repD: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
+  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
+begin
+
+lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
+apply (frule bin_chain)
+apply (drule rep_lub)
+apply (simp only: lub_eqI [OF is_lub_bin_chain])
+apply (rule subsetI, rule UN_I [where a=0], simp_all)
+done
+
+lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
+by (rule iffI [OF rep_mono subset_repD])
+
+lemma rep_eq: "rep x = {a. principal a \<sqsubseteq> x}"
+unfolding below_def rep_principal
+apply safe
+apply (erule (1) idealD3 [OF ideal_rep])
+apply (erule subsetD, simp add: r_refl)
+done
+
+lemma mem_rep_iff_principal_below: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
+by (simp add: rep_eq)
+
+lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
+by (simp add: rep_eq)
+
+lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
+by (simp add: principal_below_iff_mem_rep rep_principal)
+
+lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
+unfolding po_eq_conv [where 'a='b] principal_below_iff ..
+
+lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
+unfolding po_eq_conv below_def by auto
+
+lemma repD: "a \<in> rep x \<Longrightarrow> principal a \<sqsubseteq> x"
+by (simp add: rep_eq)
+
+lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
+by (simp only: principal_below_iff)
+
+lemma ch2ch_principal [simp]:
+  "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
+by (simp add: chainI principal_mono)
+
+lemma lub_principal_rep: "principal ` rep x <<| x"
+apply (rule is_lubI)
+apply (rule ub_imageI)
+apply (erule repD)
+apply (subst below_def)
+apply (rule subsetI)
+apply (drule (1) ub_imageD)
+apply (simp add: rep_eq)
+done
+
+subsubsection {* Principal ideals approximate all elements *}
+
+lemma compact_principal [simp]: "compact (principal a)"
+by (rule compactI2, simp add: principal_below_iff_mem_rep rep_lub)
+
+text {* Construct a chain whose lub is the same as a given ideal *}
+
+lemma obtain_principal_chain:
+  obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
+proof -
+  obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
+    using countable ..
+  def enum \<equiv> "\<lambda>i. THE a. count a = i"
+  have enum_count [simp]: "\<And>x. enum (count x) = x"
+    unfolding enum_def by (simp add: inj_eq [OF inj])
+  def a \<equiv> "LEAST i. enum i \<in> rep x"
+  def b \<equiv> "\<lambda>i. LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
+  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"
+  def P \<equiv> "\<lambda>i. \<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
+  def X \<equiv> "nat_rec a (\<lambda>n i. if P i then c i (b i) else i)"
+  have X_0: "X 0 = a" unfolding X_def by simp
+  have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
+    unfolding X_def by simp
+  have a_mem: "enum a \<in> rep x"
+    unfolding a_def
+    apply (rule LeastI_ex)
+    apply (cut_tac ideal_rep [of x])
+    apply (drule idealD1)
+    apply (clarify, rename_tac a)
+    apply (rule_tac x="count a" in exI, simp)
+    done
+  have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
+    \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
+    unfolding P_def b_def by (erule LeastI2_ex, simp)
+  have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
+    \<Longrightarrow> enum (c i j) \<in> rep x \<and> enum i \<preceq> enum (c i j) \<and> enum j \<preceq> enum (c i j)"
+    unfolding c_def
+    apply (drule (1) idealD2 [OF ideal_rep], clarify)
+    apply (rule_tac a="count z" in LeastI2, simp, simp)
+    done
+  have X_mem: "\<And>n. enum (X n) \<in> rep x"
+    apply (induct_tac n)
+    apply (simp add: X_0 a_mem)
+    apply (clarsimp simp add: X_Suc, rename_tac n)
+    apply (simp add: b c)
+    done
+  have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
+    apply (clarsimp simp add: X_Suc r_refl)
+    apply (simp add: b c X_mem)
+    done
+  have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
+    unfolding b_def by (drule not_less_Least, simp)
+  have X_covers: "\<And>n. \<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)"
+    apply (induct_tac n)
+    apply (clarsimp simp add: X_0 a_def)
+    apply (drule_tac k=0 in Least_le, simp add: r_refl)
+    apply (clarsimp, rename_tac n k)
+    apply (erule le_SucE)
+    apply (rule r_trans [OF _ X_chain], simp)
+    apply (case_tac "P (X n)", simp add: X_Suc)
+    apply (rule_tac x="b (X n)" and y="Suc n" in linorder_cases)
+    apply (simp only: less_Suc_eq_le)
+    apply (drule spec, drule (1) mp, simp add: b X_mem)
+    apply (simp add: c X_mem)
+    apply (drule (1) less_b)
+    apply (erule r_trans)
+    apply (simp add: b c X_mem)
+    apply (simp add: X_Suc)
+    apply (simp add: P_def)
+    done
+  have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
+    by (simp add: X_chain)
+  have 2: "x = (\<Squnion>n. principal (enum (X n)))"
+    apply (simp add: eq_iff rep_lub 1 rep_principal)
+    apply (auto, rename_tac a)
+    apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
+    apply (rule_tac x=i in exI, simp add: X_covers)
+    apply (rule_tac x="count a" in exI, simp)
+    apply (erule idealD3 [OF ideal_rep])
+    apply (rule X_mem)
+    done
+  from 1 2 show ?thesis ..
+qed
+
+lemma principal_induct:
+  assumes adm: "adm P"
+  assumes P: "\<And>a. P (principal a)"
+  shows "P x"
+apply (rule obtain_principal_chain [of x])
+apply (simp add: admD [OF adm] P)
+done
+
+lemma principal_induct2:
+  "\<lbrakk>\<And>y. adm (\<lambda>x. P x y); \<And>x. adm (\<lambda>y. P x y);
+    \<And>a b. P (principal a) (principal b)\<rbrakk> \<Longrightarrow> P x y"
+apply (rule_tac x=y in spec)
+apply (rule_tac x=x in principal_induct, simp)
+apply (rule allI, rename_tac y)
+apply (rule_tac x=y in principal_induct, simp)
+apply simp
+done
+
+lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
+apply (rule obtain_principal_chain [of x])
+apply (drule adm_compact_neq [OF _ cont_id])
+apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
+apply (drule (2) admD2, fast, simp)
+done
+
+lemma obtain_compact_chain:
+  obtains Y :: "nat \<Rightarrow> 'b"
+  where "chain Y" and "\<forall>i. compact (Y i)" and "x = (\<Squnion>i. Y i)"
+apply (rule obtain_principal_chain [of x])
+apply (rule_tac Y="\<lambda>i. principal (Y i)" in that, simp_all)
+done
+
+subsection {* Defining functions in terms of basis elements *}
+
+definition
+  basis_fun :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
+  "basis_fun = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"
+
+lemma basis_fun_lemma:
+  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
+  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
+  shows "\<exists>u. f ` rep x <<| u"
+proof -
+  obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
+  and x: "x = (\<Squnion>i. principal (Y i))"
+    by (rule obtain_principal_chain [of x])
+  have chain: "chain (\<lambda>i. f (Y i))"
+    by (rule chainI, simp add: f_mono Y)
+  have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
+    by (simp add: x rep_lub Y rep_principal)
+  have "f ` rep x <<| (\<Squnion>n. f (Y n))"
+    apply (rule is_lubI)
+    apply (rule ub_imageI, rename_tac a)
+    apply (clarsimp simp add: rep_x)
+    apply (drule f_mono)
+    apply (erule below_lub [OF chain])
+    apply (rule lub_below [OF chain])
+    apply (drule_tac x="Y n" in ub_imageD)
+    apply (simp add: rep_x, fast intro: r_refl)
+    apply assumption
+    done
+  thus ?thesis ..
+qed
+
+lemma basis_fun_beta:
+  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
+  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
+  shows "basis_fun f\<cdot>x = lub (f ` rep x)"
+unfolding basis_fun_def
+proof (rule beta_cfun)
+  have lub: "\<And>x. \<exists>u. f ` rep x <<| u"
+    using f_mono by (rule basis_fun_lemma)
+  show cont: "cont (\<lambda>x. lub (f ` rep x))"
+    apply (rule contI2)
+     apply (rule monofunI)
+     apply (rule is_lub_thelub_ex [OF lub ub_imageI])
+     apply (rule is_ub_thelub_ex [OF lub imageI])
+     apply (erule (1) subsetD [OF rep_mono])
+    apply (rule is_lub_thelub_ex [OF lub ub_imageI])
+    apply (simp add: rep_lub, clarify)
+    apply (erule rev_below_trans [OF is_ub_thelub])
+    apply (erule is_ub_thelub_ex [OF lub imageI])
+    done
+qed
+
+lemma basis_fun_principal:
+  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
+  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
+  shows "basis_fun f\<cdot>(principal a) = f a"
+apply (subst basis_fun_beta, erule f_mono)
+apply (subst rep_principal)
+apply (rule lub_image_principal, erule f_mono)
+done
+
+lemma basis_fun_mono:
+  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
+  assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
+  assumes below: "\<And>a. f a \<sqsubseteq> g a"
+  shows "basis_fun f \<sqsubseteq> basis_fun g"
+ apply (rule cfun_belowI)
+ apply (simp only: basis_fun_beta f_mono g_mono)
+ apply (rule is_lub_thelub_ex)
+  apply (rule basis_fun_lemma, erule f_mono)
+ apply (rule ub_imageI, rename_tac a)
+ apply (rule below_trans [OF below])
+ apply (rule is_ub_thelub_ex)
+  apply (rule basis_fun_lemma, erule g_mono)
+ apply (erule imageI)
+done
+
+end
+
+lemma (in preorder) typedef_ideal_completion:
+  fixes Abs :: "'a set \<Rightarrow> 'b::cpo"
+  assumes type: "type_definition Rep Abs {S. ideal S}"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  assumes principal: "\<And>a. principal a = Abs {b. b \<preceq> a}"
+  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
+  shows "ideal_completion r principal Rep"
+proof
+  interpret type_definition Rep Abs "{S. ideal S}" by fact
+  fix a b :: 'a and x y :: 'b and Y :: "nat \<Rightarrow> 'b"
+  show "ideal (Rep x)"
+    using Rep [of x] by simp
+  show "chain Y \<Longrightarrow> Rep (\<Squnion>i. Y i) = (\<Union>i. Rep (Y i))"
+    using type below by (rule typedef_ideal_rep_lub)
+  show "Rep (principal a) = {b. b \<preceq> a}"
+    by (simp add: principal Abs_inverse ideal_principal)
+  show "Rep x \<subseteq> Rep y \<Longrightarrow> x \<sqsubseteq> y"
+    by (simp only: below)
+  show "\<exists>f::'a \<Rightarrow> nat. inj f"
+    by (rule countable)
+qed
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Cont.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,239 @@
+(*  Title:      HOLCF/Cont.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* Continuity and monotonicity *}
+
+theory Cont
+imports Pcpo
+begin
+
+text {*
+   Now we change the default class! Form now on all untyped type variables are
+   of default class po
+*}
+
+default_sort po
+
+subsection {* Definitions *}
+
+definition
+  monofun :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"  -- "monotonicity"  where
+  "monofun f = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"
+
+definition
+  cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool"
+where
+  "cont f = (\<forall>Y. chain Y \<longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i))"
+
+lemma contI:
+  "\<lbrakk>\<And>Y. chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> cont f"
+by (simp add: cont_def)
+
+lemma contE:
+  "\<lbrakk>cont f; chain Y\<rbrakk> \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
+by (simp add: cont_def)
+
+lemma monofunI: 
+  "\<lbrakk>\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y\<rbrakk> \<Longrightarrow> monofun f"
+by (simp add: monofun_def)
+
+lemma monofunE: 
+  "\<lbrakk>monofun f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> f y"
+by (simp add: monofun_def)
+
+
+subsection {* Equivalence of alternate definition *}
+
+text {* monotone functions map chains to chains *}
+
+lemma ch2ch_monofun: "\<lbrakk>monofun f; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. f (Y i))"
+apply (rule chainI)
+apply (erule monofunE)
+apply (erule chainE)
+done
+
+text {* monotone functions map upper bound to upper bounds *}
+
+lemma ub2ub_monofun: 
+  "\<lbrakk>monofun f; range Y <| u\<rbrakk> \<Longrightarrow> range (\<lambda>i. f (Y i)) <| f u"
+apply (rule ub_rangeI)
+apply (erule monofunE)
+apply (erule ub_rangeD)
+done
+
+text {* a lemma about binary chains *}
+
+lemma binchain_cont:
+  "\<lbrakk>cont f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> range (\<lambda>i::nat. f (if i = 0 then x else y)) <<| f y"
+apply (subgoal_tac "f (\<Squnion>i::nat. if i = 0 then x else y) = f y")
+apply (erule subst)
+apply (erule contE)
+apply (erule bin_chain)
+apply (rule_tac f=f in arg_cong)
+apply (erule is_lub_bin_chain [THEN lub_eqI])
+done
+
+text {* continuity implies monotonicity *}
+
+lemma cont2mono: "cont f \<Longrightarrow> monofun f"
+apply (rule monofunI)
+apply (drule (1) binchain_cont)
+apply (drule_tac i=0 in is_lub_rangeD1)
+apply simp
+done
+
+lemmas cont2monofunE = cont2mono [THEN monofunE]
+
+lemmas ch2ch_cont = cont2mono [THEN ch2ch_monofun]
+
+text {* continuity implies preservation of lubs *}
+
+lemma cont2contlubE:
+  "\<lbrakk>cont f; chain Y\<rbrakk> \<Longrightarrow> f (\<Squnion> i. Y i) = (\<Squnion> i. f (Y i))"
+apply (rule lub_eqI [symmetric])
+apply (erule (1) contE)
+done
+
+lemma contI2:
+  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
+  assumes mono: "monofun f"
+  assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
+     \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
+  shows "cont f"
+proof (rule contI)
+  fix Y :: "nat \<Rightarrow> 'a"
+  assume Y: "chain Y"
+  with mono have fY: "chain (\<lambda>i. f (Y i))"
+    by (rule ch2ch_monofun)
+  have "(\<Squnion>i. f (Y i)) = f (\<Squnion>i. Y i)"
+    apply (rule below_antisym)
+    apply (rule lub_below [OF fY])
+    apply (rule monofunE [OF mono])
+    apply (rule is_ub_thelub [OF Y])
+    apply (rule below [OF Y fY])
+    done
+  with fY show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
+    by (rule thelubE)
+qed
+
+subsection {* Collection of continuity rules *}
+
+ML {*
+structure Cont2ContData = Named_Thms
+(
+  val name = "cont2cont"
+  val description = "continuity intro rule"
+)
+*}
+
+setup Cont2ContData.setup
+
+subsection {* Continuity of basic functions *}
+
+text {* The identity function is continuous *}
+
+lemma cont_id [simp, cont2cont]: "cont (\<lambda>x. x)"
+apply (rule contI)
+apply (erule cpo_lubI)
+done
+
+text {* constant functions are continuous *}
+
+lemma cont_const [simp, cont2cont]: "cont (\<lambda>x. c)"
+  using is_lub_const by (rule contI)
+
+text {* application of functions is continuous *}
+
+lemma cont_apply:
+  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
+  assumes 1: "cont (\<lambda>x. t x)"
+  assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
+  assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
+  shows "cont (\<lambda>x. (f x) (t x))"
+proof (rule contI2 [OF monofunI])
+  fix x y :: "'a" assume "x \<sqsubseteq> y"
+  then show "f x (t x) \<sqsubseteq> f y (t y)"
+    by (auto intro: cont2monofunE [OF 1]
+                    cont2monofunE [OF 2]
+                    cont2monofunE [OF 3]
+                    below_trans)
+next
+  fix Y :: "nat \<Rightarrow> 'a" assume "chain Y"
+  then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. f (Y i) (t (Y i)))"
+    by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
+                   cont2contlubE [OF 2] ch2ch_cont [OF 2]
+                   cont2contlubE [OF 3] ch2ch_cont [OF 3]
+                   diag_lub below_refl)
+qed
+
+lemma cont_compose:
+  "\<lbrakk>cont c; cont (\<lambda>x. f x)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. c (f x))"
+by (rule cont_apply [OF _ _ cont_const])
+
+text {* Least upper bounds preserve continuity *}
+
+lemma cont2cont_lub [simp]:
+  assumes chain: "\<And>x. chain (\<lambda>i. F i x)" and cont: "\<And>i. cont (\<lambda>x. F i x)"
+  shows "cont (\<lambda>x. \<Squnion>i. F i x)"
+apply (rule contI2)
+apply (simp add: monofunI cont2monofunE [OF cont] lub_mono chain)
+apply (simp add: cont2contlubE [OF cont])
+apply (simp add: diag_lub ch2ch_cont [OF cont] chain)
+done
+
+text {* if-then-else is continuous *}
+
+lemma cont_if [simp, cont2cont]:
+  "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. if b then f x else g x)"
+by (induct b) simp_all
+
+subsection {* Finite chains and flat pcpos *}
+
+text {* Monotone functions map finite chains to finite chains. *}
+
+lemma monofun_finch2finch:
+  "\<lbrakk>monofun f; finite_chain Y\<rbrakk> \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
+apply (unfold finite_chain_def)
+apply (simp add: ch2ch_monofun)
+apply (force simp add: max_in_chain_def)
+done
+
+text {* The same holds for continuous functions. *}
+
+lemma cont_finch2finch:
+  "\<lbrakk>cont f; finite_chain Y\<rbrakk> \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
+by (rule cont2mono [THEN monofun_finch2finch])
+
+text {* All monotone functions with chain-finite domain are continuous. *}
+
+lemma chfindom_monofun2cont: "monofun f \<Longrightarrow> cont (f::'a::chfin \<Rightarrow> 'b::cpo)"
+apply (erule contI2)
+apply (frule chfin2finch)
+apply (clarsimp simp add: finite_chain_def)
+apply (subgoal_tac "max_in_chain i (\<lambda>i. f (Y i))")
+apply (simp add: maxinch_is_thelub ch2ch_monofun)
+apply (force simp add: max_in_chain_def)
+done
+
+text {* All strict functions with flat domain are continuous. *}
+
+lemma flatdom_strict2mono: "f \<bottom> = \<bottom> \<Longrightarrow> monofun (f::'a::flat \<Rightarrow> 'b::pcpo)"
+apply (rule monofunI)
+apply (drule ax_flat)
+apply auto
+done
+
+lemma flatdom_strict2cont: "f \<bottom> = \<bottom> \<Longrightarrow> cont (f::'a::flat \<Rightarrow> 'b::pcpo)"
+by (rule flatdom_strict2mono [THEN chfindom_monofun2cont])
+
+text {* All functions with discrete domain are continuous. *}
+
+lemma cont_discrete_cpo [simp, cont2cont]: "cont (f::'a::discrete_cpo \<Rightarrow> 'b::cpo)"
+apply (rule contI)
+apply (drule discrete_chain_const, clarify)
+apply (simp add: is_lub_const)
+done
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ConvexPD.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,651 @@
+(*  Title:      HOLCF/ConvexPD.thy
+    Author:     Brian Huffman
+*)
+
+header {* Convex powerdomain *}
+
+theory ConvexPD
+imports UpperPD LowerPD
+begin
+
+subsection {* Basis preorder *}
+
+definition
+  convex_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<natural>" 50) where
+  "convex_le = (\<lambda>u v. u \<le>\<sharp> v \<and> u \<le>\<flat> v)"
+
+lemma convex_le_refl [simp]: "t \<le>\<natural> t"
+unfolding convex_le_def by (fast intro: upper_le_refl lower_le_refl)
+
+lemma convex_le_trans: "\<lbrakk>t \<le>\<natural> u; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> t \<le>\<natural> v"
+unfolding convex_le_def by (fast intro: upper_le_trans lower_le_trans)
+
+interpretation convex_le: preorder convex_le
+by (rule preorder.intro, rule convex_le_refl, rule convex_le_trans)
+
+lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<natural> t"
+unfolding convex_le_def Rep_PDUnit by simp
+
+lemma PDUnit_convex_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<natural> PDUnit y"
+unfolding convex_le_def by (fast intro: PDUnit_upper_mono PDUnit_lower_mono)
+
+lemma PDPlus_convex_mono: "\<lbrakk>s \<le>\<natural> t; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<natural> PDPlus t v"
+unfolding convex_le_def by (fast intro: PDPlus_upper_mono PDPlus_lower_mono)
+
+lemma convex_le_PDUnit_PDUnit_iff [simp]:
+  "(PDUnit a \<le>\<natural> PDUnit b) = (a \<sqsubseteq> b)"
+unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit by fast
+
+lemma convex_le_PDUnit_lemma1:
+  "(PDUnit a \<le>\<natural> t) = (\<forall>b\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
+unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
+using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast
+
+lemma convex_le_PDUnit_PDPlus_iff [simp]:
+  "(PDUnit a \<le>\<natural> PDPlus t u) = (PDUnit a \<le>\<natural> t \<and> PDUnit a \<le>\<natural> u)"
+unfolding convex_le_PDUnit_lemma1 Rep_PDPlus by fast
+
+lemma convex_le_PDUnit_lemma2:
+  "(t \<le>\<natural> PDUnit b) = (\<forall>a\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
+unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
+using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast
+
+lemma convex_le_PDPlus_PDUnit_iff [simp]:
+  "(PDPlus t u \<le>\<natural> PDUnit a) = (t \<le>\<natural> PDUnit a \<and> u \<le>\<natural> PDUnit a)"
+unfolding convex_le_PDUnit_lemma2 Rep_PDPlus by fast
+
+lemma convex_le_PDPlus_lemma:
+  assumes z: "PDPlus t u \<le>\<natural> z"
+  shows "\<exists>v w. z = PDPlus v w \<and> t \<le>\<natural> v \<and> u \<le>\<natural> w"
+proof (intro exI conjI)
+  let ?A = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis t. a \<sqsubseteq> b}"
+  let ?B = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis u. a \<sqsubseteq> b}"
+  let ?v = "Abs_pd_basis ?A"
+  let ?w = "Abs_pd_basis ?B"
+  have Rep_v: "Rep_pd_basis ?v = ?A"
+    apply (rule Abs_pd_basis_inverse)
+    apply (rule Rep_pd_basis_nonempty [of t, folded ex_in_conv, THEN exE])
+    apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
+    apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
+    apply (simp add: pd_basis_def)
+    apply fast
+    done
+  have Rep_w: "Rep_pd_basis ?w = ?B"
+    apply (rule Abs_pd_basis_inverse)
+    apply (rule Rep_pd_basis_nonempty [of u, folded ex_in_conv, THEN exE])
+    apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
+    apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
+    apply (simp add: pd_basis_def)
+    apply fast
+    done
+  show "z = PDPlus ?v ?w"
+    apply (insert z)
+    apply (simp add: convex_le_def, erule conjE)
+    apply (simp add: Rep_pd_basis_inject [symmetric] Rep_PDPlus)
+    apply (simp add: Rep_v Rep_w)
+    apply (rule equalityI)
+     apply (rule subsetI)
+     apply (simp only: upper_le_def)
+     apply (drule (1) bspec, erule bexE)
+     apply (simp add: Rep_PDPlus)
+     apply fast
+    apply fast
+    done
+  show "t \<le>\<natural> ?v" "u \<le>\<natural> ?w"
+   apply (insert z)
+   apply (simp_all add: convex_le_def upper_le_def lower_le_def Rep_PDPlus Rep_v Rep_w)
+   apply fast+
+   done
+qed
+
+lemma convex_le_induct [induct set: convex_le]:
+  assumes le: "t \<le>\<natural> u"
+  assumes 2: "\<And>t u v. \<lbrakk>P t u; P u v\<rbrakk> \<Longrightarrow> P t v"
+  assumes 3: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
+  assumes 4: "\<And>t u v w. \<lbrakk>P t v; P u w\<rbrakk> \<Longrightarrow> P (PDPlus t u) (PDPlus v w)"
+  shows "P t u"
+using le apply (induct t arbitrary: u rule: pd_basis_induct)
+apply (erule rev_mp)
+apply (induct_tac u rule: pd_basis_induct1)
+apply (simp add: 3)
+apply (simp, clarify, rename_tac a b t)
+apply (subgoal_tac "P (PDPlus (PDUnit a) (PDUnit a)) (PDPlus (PDUnit b) t)")
+apply (simp add: PDPlus_absorb)
+apply (erule (1) 4 [OF 3])
+apply (drule convex_le_PDPlus_lemma, clarify)
+apply (simp add: 4)
+done
+
+
+subsection {* Type definition *}
+
+typedef (open) 'a convex_pd =
+  "{S::'a pd_basis set. convex_le.ideal S}"
+by (fast intro: convex_le.ideal_principal)
+
+instantiation convex_pd :: ("domain") below
+begin
+
+definition
+  "x \<sqsubseteq> y \<longleftrightarrow> Rep_convex_pd x \<subseteq> Rep_convex_pd y"
+
+instance ..
+end
+
+instance convex_pd :: ("domain") po
+using type_definition_convex_pd below_convex_pd_def
+by (rule convex_le.typedef_ideal_po)
+
+instance convex_pd :: ("domain") cpo
+using type_definition_convex_pd below_convex_pd_def
+by (rule convex_le.typedef_ideal_cpo)
+
+definition
+  convex_principal :: "'a pd_basis \<Rightarrow> 'a convex_pd" where
+  "convex_principal t = Abs_convex_pd {u. u \<le>\<natural> t}"
+
+interpretation convex_pd:
+  ideal_completion convex_le convex_principal Rep_convex_pd
+using type_definition_convex_pd below_convex_pd_def
+using convex_principal_def pd_basis_countable
+by (rule convex_le.typedef_ideal_completion)
+
+text {* Convex powerdomain is pointed *}
+
+lemma convex_pd_minimal: "convex_principal (PDUnit compact_bot) \<sqsubseteq> ys"
+by (induct ys rule: convex_pd.principal_induct, simp, simp)
+
+instance convex_pd :: ("domain") pcpo
+by intro_classes (fast intro: convex_pd_minimal)
+
+lemma inst_convex_pd_pcpo: "\<bottom> = convex_principal (PDUnit compact_bot)"
+by (rule convex_pd_minimal [THEN UU_I, symmetric])
+
+
+subsection {* Monadic unit and plus *}
+
+definition
+  convex_unit :: "'a \<rightarrow> 'a convex_pd" where
+  "convex_unit = compact_basis.basis_fun (\<lambda>a. convex_principal (PDUnit a))"
+
+definition
+  convex_plus :: "'a convex_pd \<rightarrow> 'a convex_pd \<rightarrow> 'a convex_pd" where
+  "convex_plus = convex_pd.basis_fun (\<lambda>t. convex_pd.basis_fun (\<lambda>u.
+      convex_principal (PDPlus t u)))"
+
+abbreviation
+  convex_add :: "'a convex_pd \<Rightarrow> 'a convex_pd \<Rightarrow> 'a convex_pd"
+    (infixl "+\<natural>" 65) where
+  "xs +\<natural> ys == convex_plus\<cdot>xs\<cdot>ys"
+
+syntax
+  "_convex_pd" :: "args \<Rightarrow> 'a convex_pd" ("{_}\<natural>")
+
+translations
+  "{x,xs}\<natural>" == "{x}\<natural> +\<natural> {xs}\<natural>"
+  "{x}\<natural>" == "CONST convex_unit\<cdot>x"
+
+lemma convex_unit_Rep_compact_basis [simp]:
+  "{Rep_compact_basis a}\<natural> = convex_principal (PDUnit a)"
+unfolding convex_unit_def
+by (simp add: compact_basis.basis_fun_principal PDUnit_convex_mono)
+
+lemma convex_plus_principal [simp]:
+  "convex_principal t +\<natural> convex_principal u = convex_principal (PDPlus t u)"
+unfolding convex_plus_def
+by (simp add: convex_pd.basis_fun_principal
+    convex_pd.basis_fun_mono PDPlus_convex_mono)
+
+interpretation convex_add: semilattice convex_add proof
+  fix xs ys zs :: "'a convex_pd"
+  show "(xs +\<natural> ys) +\<natural> zs = xs +\<natural> (ys +\<natural> zs)"
+    apply (induct xs ys arbitrary: zs rule: convex_pd.principal_induct2, simp, simp)
+    apply (rule_tac x=zs in convex_pd.principal_induct, simp)
+    apply (simp add: PDPlus_assoc)
+    done
+  show "xs +\<natural> ys = ys +\<natural> xs"
+    apply (induct xs ys rule: convex_pd.principal_induct2, simp, simp)
+    apply (simp add: PDPlus_commute)
+    done
+  show "xs +\<natural> xs = xs"
+    apply (induct xs rule: convex_pd.principal_induct, simp)
+    apply (simp add: PDPlus_absorb)
+    done
+qed
+
+lemmas convex_plus_assoc = convex_add.assoc
+lemmas convex_plus_commute = convex_add.commute
+lemmas convex_plus_absorb = convex_add.idem
+lemmas convex_plus_left_commute = convex_add.left_commute
+lemmas convex_plus_left_absorb = convex_add.left_idem
+
+text {* Useful for @{text "simp add: convex_plus_ac"} *}
+lemmas convex_plus_ac =
+  convex_plus_assoc convex_plus_commute convex_plus_left_commute
+
+text {* Useful for @{text "simp only: convex_plus_aci"} *}
+lemmas convex_plus_aci =
+  convex_plus_ac convex_plus_absorb convex_plus_left_absorb
+
+lemma convex_unit_below_plus_iff [simp]:
+  "{x}\<natural> \<sqsubseteq> ys +\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
+apply (induct x rule: compact_basis.principal_induct, simp)
+apply (induct ys rule: convex_pd.principal_induct, simp)
+apply (induct zs rule: convex_pd.principal_induct, simp)
+apply simp
+done
+
+lemma convex_plus_below_unit_iff [simp]:
+  "xs +\<natural> ys \<sqsubseteq> {z}\<natural> \<longleftrightarrow> xs \<sqsubseteq> {z}\<natural> \<and> ys \<sqsubseteq> {z}\<natural>"
+apply (induct xs rule: convex_pd.principal_induct, simp)
+apply (induct ys rule: convex_pd.principal_induct, simp)
+apply (induct z rule: compact_basis.principal_induct, simp)
+apply simp
+done
+
+lemma convex_unit_below_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
+apply (induct x rule: compact_basis.principal_induct, simp)
+apply (induct y rule: compact_basis.principal_induct, simp)
+apply simp
+done
+
+lemma convex_unit_eq_iff [simp]: "{x}\<natural> = {y}\<natural> \<longleftrightarrow> x = y"
+unfolding po_eq_conv by simp
+
+lemma convex_unit_strict [simp]: "{\<bottom>}\<natural> = \<bottom>"
+using convex_unit_Rep_compact_basis [of compact_bot]
+by (simp add: inst_convex_pd_pcpo)
+
+lemma convex_unit_bottom_iff [simp]: "{x}\<natural> = \<bottom> \<longleftrightarrow> x = \<bottom>"
+unfolding convex_unit_strict [symmetric] by (rule convex_unit_eq_iff)
+
+lemma compact_convex_unit: "compact x \<Longrightarrow> compact {x}\<natural>"
+by (auto dest!: compact_basis.compact_imp_principal)
+
+lemma compact_convex_unit_iff [simp]: "compact {x}\<natural> \<longleftrightarrow> compact x"
+apply (safe elim!: compact_convex_unit)
+apply (simp only: compact_def convex_unit_below_iff [symmetric])
+apply (erule adm_subst [OF cont_Rep_cfun2])
+done
+
+lemma compact_convex_plus [simp]:
+  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<natural> ys)"
+by (auto dest!: convex_pd.compact_imp_principal)
+
+
+subsection {* Induction rules *}
+
+lemma convex_pd_induct1:
+  assumes P: "adm P"
+  assumes unit: "\<And>x. P {x}\<natural>"
+  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<natural>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<natural> +\<natural> ys)"
+  shows "P (xs::'a convex_pd)"
+apply (induct xs rule: convex_pd.principal_induct, rule P)
+apply (induct_tac a rule: pd_basis_induct1)
+apply (simp only: convex_unit_Rep_compact_basis [symmetric])
+apply (rule unit)
+apply (simp only: convex_unit_Rep_compact_basis [symmetric]
+                  convex_plus_principal [symmetric])
+apply (erule insert [OF unit])
+done
+
+lemma convex_pd_induct
+  [case_names adm convex_unit convex_plus, induct type: convex_pd]:
+  assumes P: "adm P"
+  assumes unit: "\<And>x. P {x}\<natural>"
+  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<natural> ys)"
+  shows "P (xs::'a convex_pd)"
+apply (induct xs rule: convex_pd.principal_induct, rule P)
+apply (induct_tac a rule: pd_basis_induct)
+apply (simp only: convex_unit_Rep_compact_basis [symmetric] unit)
+apply (simp only: convex_plus_principal [symmetric] plus)
+done
+
+
+subsection {* Monadic bind *}
+
+definition
+  convex_bind_basis ::
+  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
+  "convex_bind_basis = fold_pd
+    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
+    (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<natural> y\<cdot>f)"
+
+lemma ACI_convex_bind:
+  "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<natural> y\<cdot>f)"
+apply unfold_locales
+apply (simp add: convex_plus_assoc)
+apply (simp add: convex_plus_commute)
+apply (simp add: eta_cfun)
+done
+
+lemma convex_bind_basis_simps [simp]:
+  "convex_bind_basis (PDUnit a) =
+    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
+  "convex_bind_basis (PDPlus t u) =
+    (\<Lambda> f. convex_bind_basis t\<cdot>f +\<natural> convex_bind_basis u\<cdot>f)"
+unfolding convex_bind_basis_def
+apply -
+apply (rule fold_pd_PDUnit [OF ACI_convex_bind])
+apply (rule fold_pd_PDPlus [OF ACI_convex_bind])
+done
+
+lemma convex_bind_basis_mono:
+  "t \<le>\<natural> u \<Longrightarrow> convex_bind_basis t \<sqsubseteq> convex_bind_basis u"
+apply (erule convex_le_induct)
+apply (erule (1) below_trans)
+apply (simp add: monofun_LAM monofun_cfun)
+apply (simp add: monofun_LAM monofun_cfun)
+done
+
+definition
+  convex_bind :: "'a convex_pd \<rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
+  "convex_bind = convex_pd.basis_fun convex_bind_basis"
+
+lemma convex_bind_principal [simp]:
+  "convex_bind\<cdot>(convex_principal t) = convex_bind_basis t"
+unfolding convex_bind_def
+apply (rule convex_pd.basis_fun_principal)
+apply (erule convex_bind_basis_mono)
+done
+
+lemma convex_bind_unit [simp]:
+  "convex_bind\<cdot>{x}\<natural>\<cdot>f = f\<cdot>x"
+by (induct x rule: compact_basis.principal_induct, simp, simp)
+
+lemma convex_bind_plus [simp]:
+  "convex_bind\<cdot>(xs +\<natural> ys)\<cdot>f = convex_bind\<cdot>xs\<cdot>f +\<natural> convex_bind\<cdot>ys\<cdot>f"
+by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
+
+lemma convex_bind_strict [simp]: "convex_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
+unfolding convex_unit_strict [symmetric] by (rule convex_bind_unit)
+
+lemma convex_bind_bind:
+  "convex_bind\<cdot>(convex_bind\<cdot>xs\<cdot>f)\<cdot>g =
+    convex_bind\<cdot>xs\<cdot>(\<Lambda> x. convex_bind\<cdot>(f\<cdot>x)\<cdot>g)"
+by (induct xs, simp_all)
+
+
+subsection {* Map *}
+
+definition
+  convex_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a convex_pd \<rightarrow> 'b convex_pd" where
+  "convex_map = (\<Lambda> f xs. convex_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<natural>))"
+
+lemma convex_map_unit [simp]:
+  "convex_map\<cdot>f\<cdot>{x}\<natural> = {f\<cdot>x}\<natural>"
+unfolding convex_map_def by simp
+
+lemma convex_map_plus [simp]:
+  "convex_map\<cdot>f\<cdot>(xs +\<natural> ys) = convex_map\<cdot>f\<cdot>xs +\<natural> convex_map\<cdot>f\<cdot>ys"
+unfolding convex_map_def by simp
+
+lemma convex_map_bottom [simp]: "convex_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<natural>"
+unfolding convex_map_def by simp
+
+lemma convex_map_ident: "convex_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
+by (induct xs rule: convex_pd_induct, simp_all)
+
+lemma convex_map_ID: "convex_map\<cdot>ID = ID"
+by (simp add: cfun_eq_iff ID_def convex_map_ident)
+
+lemma convex_map_map:
+  "convex_map\<cdot>f\<cdot>(convex_map\<cdot>g\<cdot>xs) = convex_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
+by (induct xs rule: convex_pd_induct, simp_all)
+
+lemma ep_pair_convex_map: "ep_pair e p \<Longrightarrow> ep_pair (convex_map\<cdot>e) (convex_map\<cdot>p)"
+apply default
+apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse)
+apply (induct_tac y rule: convex_pd_induct)
+apply (simp_all add: ep_pair.e_p_below monofun_cfun)
+done
+
+lemma deflation_convex_map: "deflation d \<Longrightarrow> deflation (convex_map\<cdot>d)"
+apply default
+apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem)
+apply (induct_tac x rule: convex_pd_induct)
+apply (simp_all add: deflation.below monofun_cfun)
+done
+
+(* FIXME: long proof! *)
+lemma finite_deflation_convex_map:
+  assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
+proof (rule finite_deflation_intro)
+  interpret d: finite_deflation d by fact
+  have "deflation d" by fact
+  thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
+  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
+  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
+    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
+  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
+  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
+    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
+  hence *: "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
+  hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
+    apply (rule rev_finite_subset)
+    apply clarsimp
+    apply (induct_tac xs rule: convex_pd.principal_induct)
+    apply (simp add: adm_mem_finite *)
+    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
+    apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
+    apply simp
+    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
+    apply clarsimp
+    apply (rule imageI)
+    apply (rule vimageI2)
+    apply (simp add: Rep_PDUnit)
+    apply (rule range_eqI)
+    apply (erule sym)
+    apply (rule exI)
+    apply (rule Abs_compact_basis_inverse [symmetric])
+    apply (simp add: d.compact)
+    apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
+    apply clarsimp
+    apply (rule imageI)
+    apply (rule vimageI2)
+    apply (simp add: Rep_PDPlus)
+    done
+  thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
+    by (rule finite_range_imp_finite_fixes)
+qed
+
+subsection {* Convex powerdomain is a domain *}
+
+definition
+  convex_approx :: "nat \<Rightarrow> udom convex_pd \<rightarrow> udom convex_pd"
+where
+  "convex_approx = (\<lambda>i. convex_map\<cdot>(udom_approx i))"
+
+lemma convex_approx: "approx_chain convex_approx"
+using convex_map_ID finite_deflation_convex_map
+unfolding convex_approx_def by (rule approx_chain_lemma1)
+
+definition convex_defl :: "defl \<rightarrow> defl"
+where "convex_defl = defl_fun1 convex_approx convex_map"
+
+lemma cast_convex_defl:
+  "cast\<cdot>(convex_defl\<cdot>A) =
+    udom_emb convex_approx oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj convex_approx"
+using convex_approx finite_deflation_convex_map
+unfolding convex_defl_def by (rule cast_defl_fun1)
+
+instantiation convex_pd :: ("domain") liftdomain
+begin
+
+definition
+  "emb = udom_emb convex_approx oo convex_map\<cdot>emb"
+
+definition
+  "prj = convex_map\<cdot>prj oo udom_prj convex_approx"
+
+definition
+  "defl (t::'a convex_pd itself) = convex_defl\<cdot>DEFL('a)"
+
+definition
+  "(liftemb :: 'a convex_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a convex_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::'a convex_pd itself) = u_defl\<cdot>DEFL('a convex_pd)"
+
+instance
+using liftemb_convex_pd_def liftprj_convex_pd_def liftdefl_convex_pd_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a convex_pd)"
+    unfolding emb_convex_pd_def prj_convex_pd_def
+    using ep_pair_udom [OF convex_approx]
+    by (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj)
+next
+  show "cast\<cdot>DEFL('a convex_pd) = emb oo (prj :: udom \<rightarrow> 'a convex_pd)"
+    unfolding emb_convex_pd_def prj_convex_pd_def defl_convex_pd_def cast_convex_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff convex_map_map)
+qed
+
+end
+
+text {* DEFL of type constructor = type combinator *}
+
+lemma DEFL_convex: "DEFL('a convex_pd) = convex_defl\<cdot>DEFL('a)"
+by (rule defl_convex_pd_def)
+
+
+subsection {* Join *}
+
+definition
+  convex_join :: "'a convex_pd convex_pd \<rightarrow> 'a convex_pd" where
+  "convex_join = (\<Lambda> xss. convex_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
+
+lemma convex_join_unit [simp]:
+  "convex_join\<cdot>{xs}\<natural> = xs"
+unfolding convex_join_def by simp
+
+lemma convex_join_plus [simp]:
+  "convex_join\<cdot>(xss +\<natural> yss) = convex_join\<cdot>xss +\<natural> convex_join\<cdot>yss"
+unfolding convex_join_def by simp
+
+lemma convex_join_bottom [simp]: "convex_join\<cdot>\<bottom> = \<bottom>"
+unfolding convex_join_def by simp
+
+lemma convex_join_map_unit:
+  "convex_join\<cdot>(convex_map\<cdot>convex_unit\<cdot>xs) = xs"
+by (induct xs rule: convex_pd_induct, simp_all)
+
+lemma convex_join_map_join:
+  "convex_join\<cdot>(convex_map\<cdot>convex_join\<cdot>xsss) = convex_join\<cdot>(convex_join\<cdot>xsss)"
+by (induct xsss rule: convex_pd_induct, simp_all)
+
+lemma convex_join_map_map:
+  "convex_join\<cdot>(convex_map\<cdot>(convex_map\<cdot>f)\<cdot>xss) =
+   convex_map\<cdot>f\<cdot>(convex_join\<cdot>xss)"
+by (induct xss rule: convex_pd_induct, simp_all)
+
+
+subsection {* Conversions to other powerdomains *}
+
+text {* Convex to upper *}
+
+lemma convex_le_imp_upper_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<sharp> u"
+unfolding convex_le_def by simp
+
+definition
+  convex_to_upper :: "'a convex_pd \<rightarrow> 'a upper_pd" where
+  "convex_to_upper = convex_pd.basis_fun upper_principal"
+
+lemma convex_to_upper_principal [simp]:
+  "convex_to_upper\<cdot>(convex_principal t) = upper_principal t"
+unfolding convex_to_upper_def
+apply (rule convex_pd.basis_fun_principal)
+apply (rule upper_pd.principal_mono)
+apply (erule convex_le_imp_upper_le)
+done
+
+lemma convex_to_upper_unit [simp]:
+  "convex_to_upper\<cdot>{x}\<natural> = {x}\<sharp>"
+by (induct x rule: compact_basis.principal_induct, simp, simp)
+
+lemma convex_to_upper_plus [simp]:
+  "convex_to_upper\<cdot>(xs +\<natural> ys) = convex_to_upper\<cdot>xs +\<sharp> convex_to_upper\<cdot>ys"
+by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
+
+lemma convex_to_upper_bind [simp]:
+  "convex_to_upper\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
+    upper_bind\<cdot>(convex_to_upper\<cdot>xs)\<cdot>(convex_to_upper oo f)"
+by (induct xs rule: convex_pd_induct, simp, simp, simp)
+
+lemma convex_to_upper_map [simp]:
+  "convex_to_upper\<cdot>(convex_map\<cdot>f\<cdot>xs) = upper_map\<cdot>f\<cdot>(convex_to_upper\<cdot>xs)"
+by (simp add: convex_map_def upper_map_def cfcomp_LAM)
+
+lemma convex_to_upper_join [simp]:
+  "convex_to_upper\<cdot>(convex_join\<cdot>xss) =
+    upper_bind\<cdot>(convex_to_upper\<cdot>xss)\<cdot>convex_to_upper"
+by (simp add: convex_join_def upper_join_def cfcomp_LAM eta_cfun)
+
+text {* Convex to lower *}
+
+lemma convex_le_imp_lower_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<flat> u"
+unfolding convex_le_def by simp
+
+definition
+  convex_to_lower :: "'a convex_pd \<rightarrow> 'a lower_pd" where
+  "convex_to_lower = convex_pd.basis_fun lower_principal"
+
+lemma convex_to_lower_principal [simp]:
+  "convex_to_lower\<cdot>(convex_principal t) = lower_principal t"
+unfolding convex_to_lower_def
+apply (rule convex_pd.basis_fun_principal)
+apply (rule lower_pd.principal_mono)
+apply (erule convex_le_imp_lower_le)
+done
+
+lemma convex_to_lower_unit [simp]:
+  "convex_to_lower\<cdot>{x}\<natural> = {x}\<flat>"
+by (induct x rule: compact_basis.principal_induct, simp, simp)
+
+lemma convex_to_lower_plus [simp]:
+  "convex_to_lower\<cdot>(xs +\<natural> ys) = convex_to_lower\<cdot>xs +\<flat> convex_to_lower\<cdot>ys"
+by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
+
+lemma convex_to_lower_bind [simp]:
+  "convex_to_lower\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
+    lower_bind\<cdot>(convex_to_lower\<cdot>xs)\<cdot>(convex_to_lower oo f)"
+by (induct xs rule: convex_pd_induct, simp, simp, simp)
+
+lemma convex_to_lower_map [simp]:
+  "convex_to_lower\<cdot>(convex_map\<cdot>f\<cdot>xs) = lower_map\<cdot>f\<cdot>(convex_to_lower\<cdot>xs)"
+by (simp add: convex_map_def lower_map_def cfcomp_LAM)
+
+lemma convex_to_lower_join [simp]:
+  "convex_to_lower\<cdot>(convex_join\<cdot>xss) =
+    lower_bind\<cdot>(convex_to_lower\<cdot>xss)\<cdot>convex_to_lower"
+by (simp add: convex_join_def lower_join_def cfcomp_LAM eta_cfun)
+
+text {* Ordering property *}
+
+lemma convex_pd_below_iff:
+  "(xs \<sqsubseteq> ys) =
+    (convex_to_upper\<cdot>xs \<sqsubseteq> convex_to_upper\<cdot>ys \<and>
+     convex_to_lower\<cdot>xs \<sqsubseteq> convex_to_lower\<cdot>ys)"
+apply (induct xs rule: convex_pd.principal_induct, simp)
+apply (induct ys rule: convex_pd.principal_induct, simp)
+apply (simp add: convex_le_def)
+done
+
+lemmas convex_plus_below_plus_iff =
+  convex_pd_below_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
+
+lemmas convex_pd_below_simps =
+  convex_unit_below_plus_iff
+  convex_plus_below_unit_iff
+  convex_plus_below_plus_iff
+  convex_unit_below_iff
+  convex_to_upper_unit
+  convex_to_upper_plus
+  convex_to_lower_unit
+  convex_to_lower_plus
+  upper_pd_below_simps
+  lower_pd_below_simps
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Cpodef.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,285 @@
+(*  Title:      HOLCF/Pcpodef.thy
+    Author:     Brian Huffman
+*)
+
+header {* Subtypes of pcpos *}
+
+theory Cpodef
+imports Adm
+uses ("Tools/cpodef.ML")
+begin
+
+subsection {* Proving a subtype is a partial order *}
+
+text {*
+  A subtype of a partial order is itself a partial order,
+  if the ordering is defined in the standard way.
+*}
+
+setup {* Sign.add_const_constraint (@{const_name Porder.below}, NONE) *}
+
+theorem typedef_po:
+  fixes Abs :: "'a::po \<Rightarrow> 'b::type"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  shows "OFCLASS('b, po_class)"
+ apply (intro_classes, unfold below)
+   apply (rule below_refl)
+  apply (erule (1) below_trans)
+ apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
+ apply (erule (1) below_antisym)
+done
+
+setup {* Sign.add_const_constraint (@{const_name Porder.below},
+  SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"}) *}
+
+subsection {* Proving a subtype is finite *}
+
+lemma typedef_finite_UNIV:
+  fixes Abs :: "'a::type \<Rightarrow> 'b::type"
+  assumes type: "type_definition Rep Abs A"
+  shows "finite A \<Longrightarrow> finite (UNIV :: 'b set)"
+proof -
+  assume "finite A"
+  hence "finite (Abs ` A)" by (rule finite_imageI)
+  thus "finite (UNIV :: 'b set)"
+    by (simp only: type_definition.Abs_image [OF type])
+qed
+
+subsection {* Proving a subtype is chain-finite *}
+
+lemma ch2ch_Rep:
+  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  shows "chain S \<Longrightarrow> chain (\<lambda>i. Rep (S i))"
+unfolding chain_def below .
+
+theorem typedef_chfin:
+  fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  shows "OFCLASS('b, chfin_class)"
+ apply intro_classes
+ apply (drule ch2ch_Rep [OF below])
+ apply (drule chfin)
+ apply (unfold max_in_chain_def)
+ apply (simp add: type_definition.Rep_inject [OF type])
+done
+
+subsection {* Proving a subtype is complete *}
+
+text {*
+  A subtype of a cpo is itself a cpo if the ordering is
+  defined in the standard way, and the defining subset
+  is closed with respect to limits of chains.  A set is
+  closed if and only if membership in the set is an
+  admissible predicate.
+*}
+
+lemma typedef_is_lubI:
+  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
+unfolding is_lub_def is_ub_def below by simp
+
+lemma Abs_inverse_lub_Rep:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and adm:  "adm (\<lambda>x. x \<in> A)"
+  shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
+ apply (rule type_definition.Abs_inverse [OF type])
+ apply (erule admD [OF adm ch2ch_Rep [OF below]])
+ apply (rule type_definition.Rep [OF type])
+done
+
+theorem typedef_is_lub:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and adm: "adm (\<lambda>x. x \<in> A)"
+  shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
+proof -
+  assume S: "chain S"
+  hence "chain (\<lambda>i. Rep (S i))" by (rule ch2ch_Rep [OF below])
+  hence "range (\<lambda>i. Rep (S i)) <<| (\<Squnion>i. Rep (S i))" by (rule cpo_lubI)
+  hence "range (\<lambda>i. Rep (S i)) <<| Rep (Abs (\<Squnion>i. Rep (S i)))"
+    by (simp only: Abs_inverse_lub_Rep [OF type below adm S])
+  thus "range S <<| Abs (\<Squnion>i. Rep (S i))"
+    by (rule typedef_is_lubI [OF below])
+qed
+
+lemmas typedef_lub = typedef_is_lub [THEN lub_eqI, standard]
+
+theorem typedef_cpo:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and adm: "adm (\<lambda>x. x \<in> A)"
+  shows "OFCLASS('b, cpo_class)"
+proof
+  fix S::"nat \<Rightarrow> 'b" assume "chain S"
+  hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
+    by (rule typedef_is_lub [OF type below adm])
+  thus "\<exists>x. range S <<| x" ..
+qed
+
+subsubsection {* Continuity of \emph{Rep} and \emph{Abs} *}
+
+text {* For any sub-cpo, the @{term Rep} function is continuous. *}
+
+theorem typedef_cont_Rep:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and adm: "adm (\<lambda>x. x \<in> A)"
+  shows "cont Rep"
+ apply (rule contI)
+ apply (simp only: typedef_lub [OF type below adm])
+ apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
+ apply (rule cpo_lubI)
+ apply (erule ch2ch_Rep [OF below])
+done
+
+text {*
+  For a sub-cpo, we can make the @{term Abs} function continuous
+  only if we restrict its domain to the defining subset by
+  composing it with another continuous function.
+*}
+
+theorem typedef_cont_Abs:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
+  fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
+    and f_in_A: "\<And>x. f x \<in> A"
+  shows "cont f \<Longrightarrow> cont (\<lambda>x. Abs (f x))"
+unfolding cont_def is_lub_def is_ub_def ball_simps below
+by (simp add: type_definition.Abs_inverse [OF type f_in_A])
+
+subsection {* Proving subtype elements are compact *}
+
+theorem typedef_compact:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and adm: "adm (\<lambda>x. x \<in> A)"
+  shows "compact (Rep k) \<Longrightarrow> compact k"
+proof (unfold compact_def)
+  have cont_Rep: "cont Rep"
+    by (rule typedef_cont_Rep [OF type below adm])
+  assume "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> x)"
+  with cont_Rep have "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> Rep x)" by (rule adm_subst)
+  thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold below)
+qed
+
+subsection {* Proving a subtype is pointed *}
+
+text {*
+  A subtype of a cpo has a least element if and only if
+  the defining subset has a least element.
+*}
+
+theorem typedef_pcpo_generic:
+  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and z_in_A: "z \<in> A"
+    and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
+  shows "OFCLASS('b, pcpo_class)"
+ apply (intro_classes)
+ apply (rule_tac x="Abs z" in exI, rule allI)
+ apply (unfold below)
+ apply (subst type_definition.Abs_inverse [OF type z_in_A])
+ apply (rule z_least [OF type_definition.Rep [OF type]])
+done
+
+text {*
+  As a special case, a subtype of a pcpo has a least element
+  if the defining subset contains @{term \<bottom>}.
+*}
+
+theorem typedef_pcpo:
+  fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "OFCLASS('b, pcpo_class)"
+by (rule typedef_pcpo_generic [OF type below UU_in_A], rule minimal)
+
+subsubsection {* Strictness of \emph{Rep} and \emph{Abs} *}
+
+text {*
+  For a sub-pcpo where @{term \<bottom>} is a member of the defining
+  subset, @{term Rep} and @{term Abs} are both strict.
+*}
+
+theorem typedef_Abs_strict:
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "Abs \<bottom> = \<bottom>"
+ apply (rule UU_I, unfold below)
+ apply (simp add: type_definition.Abs_inverse [OF type UU_in_A])
+done
+
+theorem typedef_Rep_strict:
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "Rep \<bottom> = \<bottom>"
+ apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
+ apply (rule type_definition.Abs_inverse [OF type UU_in_A])
+done
+
+theorem typedef_Abs_bottom_iff:
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
+ apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
+ apply (simp add: type_definition.Abs_inject [OF type] UU_in_A)
+done
+
+theorem typedef_Rep_bottom_iff:
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "(Rep x = \<bottom>) = (x = \<bottom>)"
+ apply (rule typedef_Rep_strict [OF type below UU_in_A, THEN subst])
+ apply (simp add: type_definition.Rep_inject [OF type])
+done
+
+theorem typedef_Abs_defined:
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "\<lbrakk>x \<noteq> \<bottom>; x \<in> A\<rbrakk> \<Longrightarrow> Abs x \<noteq> \<bottom>"
+by (simp add: typedef_Abs_bottom_iff [OF type below UU_in_A])
+
+theorem typedef_Rep_defined:
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "x \<noteq> \<bottom> \<Longrightarrow> Rep x \<noteq> \<bottom>"
+by (simp add: typedef_Rep_bottom_iff [OF type below UU_in_A])
+
+subsection {* Proving a subtype is flat *}
+
+theorem typedef_flat:
+  fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
+  assumes type: "type_definition Rep Abs A"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and UU_in_A: "\<bottom> \<in> A"
+  shows "OFCLASS('b, flat_class)"
+ apply (intro_classes)
+ apply (unfold below)
+ apply (simp add: type_definition.Rep_inject [OF type, symmetric])
+ apply (simp add: typedef_Rep_strict [OF type below UU_in_A])
+ apply (simp add: ax_flat)
+done
+
+subsection {* HOLCF type definition package *}
+
+use "Tools/cpodef.ML"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Cprod.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,43 @@
+(*  Title:      HOLCF/Cprod.thy
+    Author:     Franz Regensburger
+*)
+
+header {* The cpo of cartesian products *}
+
+theory Cprod
+imports Cfun
+begin
+
+default_sort cpo
+
+subsection {* Continuous case function for unit type *}
+
+definition
+  unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a" where
+  "unit_when = (\<Lambda> a _. a)"
+
+translations
+  "\<Lambda>(). t" == "CONST unit_when\<cdot>t"
+
+lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
+by (simp add: unit_when_def)
+
+subsection {* Continuous version of split function *}
+
+definition
+  csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
+  "csplit = (\<Lambda> f p. f\<cdot>(fst p)\<cdot>(snd p))"
+
+translations
+  "\<Lambda>(CONST Pair x y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"
+
+
+subsection {* Convert all lemmas to the continuous versions *}
+
+lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
+by (simp add: csplit_def)
+
+lemma csplit_Pair [simp]: "csplit\<cdot>f\<cdot>(x, y) = f\<cdot>x\<cdot>y"
+by (simp add: csplit_def)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Deflation.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,408 @@
+(*  Title:      HOLCF/Deflation.thy
+    Author:     Brian Huffman
+*)
+
+header {* Continuous deflations and ep-pairs *}
+
+theory Deflation
+imports Plain_HOLCF
+begin
+
+default_sort cpo
+
+subsection {* Continuous deflations *}
+
+locale deflation =
+  fixes d :: "'a \<rightarrow> 'a"
+  assumes idem: "\<And>x. d\<cdot>(d\<cdot>x) = d\<cdot>x"
+  assumes below: "\<And>x. d\<cdot>x \<sqsubseteq> x"
+begin
+
+lemma below_ID: "d \<sqsubseteq> ID"
+by (rule cfun_belowI, simp add: below)
+
+text {* The set of fixed points is the same as the range. *}
+
+lemma fixes_eq_range: "{x. d\<cdot>x = x} = range (\<lambda>x. d\<cdot>x)"
+by (auto simp add: eq_sym_conv idem)
+
+lemma range_eq_fixes: "range (\<lambda>x. d\<cdot>x) = {x. d\<cdot>x = x}"
+by (auto simp add: eq_sym_conv idem)
+
+text {*
+  The pointwise ordering on deflation functions coincides with
+  the subset ordering of their sets of fixed-points.
+*}
+
+lemma belowI:
+  assumes f: "\<And>x. d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
+proof (rule cfun_belowI)
+  fix x
+  from below have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
+  also from idem have "f\<cdot>(d\<cdot>x) = d\<cdot>x" by (rule f)
+  finally show "d\<cdot>x \<sqsubseteq> f\<cdot>x" .
+qed
+
+lemma belowD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
+proof (rule below_antisym)
+  from below show "d\<cdot>x \<sqsubseteq> x" .
+next
+  assume "f \<sqsubseteq> d"
+  hence "f\<cdot>x \<sqsubseteq> d\<cdot>x" by (rule monofun_cfun_fun)
+  also assume "f\<cdot>x = x"
+  finally show "x \<sqsubseteq> d\<cdot>x" .
+qed
+
+end
+
+lemma deflation_strict: "deflation d \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
+by (rule deflation.below [THEN UU_I])
+
+lemma adm_deflation: "adm (\<lambda>d. deflation d)"
+by (simp add: deflation_def)
+
+lemma deflation_ID: "deflation ID"
+by (simp add: deflation.intro)
+
+lemma deflation_UU: "deflation \<bottom>"
+by (simp add: deflation.intro)
+
+lemma deflation_below_iff:
+  "\<lbrakk>deflation p; deflation q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> (\<forall>x. p\<cdot>x = x \<longrightarrow> q\<cdot>x = x)"
+ apply safe
+  apply (simp add: deflation.belowD)
+ apply (simp add: deflation.belowI)
+done
+
+text {*
+  The composition of two deflations is equal to
+  the lesser of the two (if they are comparable).
+*}
+
+lemma deflation_below_comp1:
+  assumes "deflation f"
+  assumes "deflation g"
+  shows "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>(g\<cdot>x) = f\<cdot>x"
+proof (rule below_antisym)
+  interpret g: deflation g by fact
+  from g.below show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
+next
+  interpret f: deflation f by fact
+  assume "f \<sqsubseteq> g" hence "f\<cdot>x \<sqsubseteq> g\<cdot>x" by (rule monofun_cfun_fun)
+  hence "f\<cdot>(f\<cdot>x) \<sqsubseteq> f\<cdot>(g\<cdot>x)" by (rule monofun_cfun_arg)
+  also have "f\<cdot>(f\<cdot>x) = f\<cdot>x" by (rule f.idem)
+  finally show "f\<cdot>x \<sqsubseteq> f\<cdot>(g\<cdot>x)" .
+qed
+
+lemma deflation_below_comp2:
+  "\<lbrakk>deflation f; deflation g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> g\<cdot>(f\<cdot>x) = f\<cdot>x"
+by (simp only: deflation.belowD deflation.idem)
+
+
+subsection {* Deflations with finite range *}
+
+lemma finite_range_imp_finite_fixes:
+  "finite (range f) \<Longrightarrow> finite {x. f x = x}"
+proof -
+  have "{x. f x = x} \<subseteq> range f"
+    by (clarify, erule subst, rule rangeI)
+  moreover assume "finite (range f)"
+  ultimately show "finite {x. f x = x}"
+    by (rule finite_subset)
+qed
+
+locale finite_deflation = deflation +
+  assumes finite_fixes: "finite {x. d\<cdot>x = x}"
+begin
+
+lemma finite_range: "finite (range (\<lambda>x. d\<cdot>x))"
+by (simp add: range_eq_fixes finite_fixes)
+
+lemma finite_image: "finite ((\<lambda>x. d\<cdot>x) ` A)"
+by (rule finite_subset [OF image_mono [OF subset_UNIV] finite_range])
+
+lemma compact: "compact (d\<cdot>x)"
+proof (rule compactI2)
+  fix Y :: "nat \<Rightarrow> 'a"
+  assume Y: "chain Y"
+  have "finite_chain (\<lambda>i. d\<cdot>(Y i))"
+  proof (rule finite_range_imp_finch)
+    show "chain (\<lambda>i. d\<cdot>(Y i))"
+      using Y by simp
+    have "range (\<lambda>i. d\<cdot>(Y i)) \<subseteq> range (\<lambda>x. d\<cdot>x)"
+      by clarsimp
+    thus "finite (range (\<lambda>i. d\<cdot>(Y i)))"
+      using finite_range by (rule finite_subset)
+  qed
+  hence "\<exists>j. (\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)"
+    by (simp add: finite_chain_def maxinch_is_thelub Y)
+  then obtain j where j: "(\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)" ..
+
+  assume "d\<cdot>x \<sqsubseteq> (\<Squnion>i. Y i)"
+  hence "d\<cdot>(d\<cdot>x) \<sqsubseteq> d\<cdot>(\<Squnion>i. Y i)"
+    by (rule monofun_cfun_arg)
+  hence "d\<cdot>x \<sqsubseteq> (\<Squnion>i. d\<cdot>(Y i))"
+    by (simp add: contlub_cfun_arg Y idem)
+  hence "d\<cdot>x \<sqsubseteq> d\<cdot>(Y j)"
+    using j by simp
+  hence "d\<cdot>x \<sqsubseteq> Y j"
+    using below by (rule below_trans)
+  thus "\<exists>j. d\<cdot>x \<sqsubseteq> Y j" ..
+qed
+
+end
+
+lemma finite_deflation_intro:
+  "deflation d \<Longrightarrow> finite {x. d\<cdot>x = x} \<Longrightarrow> finite_deflation d"
+by (intro finite_deflation.intro finite_deflation_axioms.intro)
+
+lemma finite_deflation_imp_deflation:
+  "finite_deflation d \<Longrightarrow> deflation d"
+unfolding finite_deflation_def by simp
+
+lemma finite_deflation_UU: "finite_deflation \<bottom>"
+by default simp_all
+
+
+subsection {* Continuous embedding-projection pairs *}
+
+locale ep_pair =
+  fixes e :: "'a \<rightarrow> 'b" and p :: "'b \<rightarrow> 'a"
+  assumes e_inverse [simp]: "\<And>x. p\<cdot>(e\<cdot>x) = x"
+  and e_p_below: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
+begin
+
+lemma e_below_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
+proof
+  assume "e\<cdot>x \<sqsubseteq> e\<cdot>y"
+  hence "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>(e\<cdot>y)" by (rule monofun_cfun_arg)
+  thus "x \<sqsubseteq> y" by simp
+next
+  assume "x \<sqsubseteq> y"
+  thus "e\<cdot>x \<sqsubseteq> e\<cdot>y" by (rule monofun_cfun_arg)
+qed
+
+lemma e_eq_iff [simp]: "e\<cdot>x = e\<cdot>y \<longleftrightarrow> x = y"
+unfolding po_eq_conv e_below_iff ..
+
+lemma p_eq_iff:
+  "\<lbrakk>e\<cdot>(p\<cdot>x) = x; e\<cdot>(p\<cdot>y) = y\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>y \<longleftrightarrow> x = y"
+by (safe, erule subst, erule subst, simp)
+
+lemma p_inverse: "(\<exists>x. y = e\<cdot>x) = (e\<cdot>(p\<cdot>y) = y)"
+by (auto, rule exI, erule sym)
+
+lemma e_below_iff_below_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
+proof
+  assume "e\<cdot>x \<sqsubseteq> y"
+  then have "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>y" by (rule monofun_cfun_arg)
+  then show "x \<sqsubseteq> p\<cdot>y" by simp
+next
+  assume "x \<sqsubseteq> p\<cdot>y"
+  then have "e\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>y)" by (rule monofun_cfun_arg)
+  then show "e\<cdot>x \<sqsubseteq> y" using e_p_below by (rule below_trans)
+qed
+
+lemma compact_e_rev: "compact (e\<cdot>x) \<Longrightarrow> compact x"
+proof -
+  assume "compact (e\<cdot>x)"
+  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (rule compactD)
+  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> e\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
+  hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by simp
+  thus "compact x" by (rule compactI)
+qed
+
+lemma compact_e: "compact x \<Longrightarrow> compact (e\<cdot>x)"
+proof -
+  assume "compact x"
+  hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by (rule compactD)
+  hence "adm (\<lambda>y. \<not> x \<sqsubseteq> p\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
+  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_below_iff_below_p)
+  thus "compact (e\<cdot>x)" by (rule compactI)
+qed
+
+lemma compact_e_iff: "compact (e\<cdot>x) \<longleftrightarrow> compact x"
+by (rule iffI [OF compact_e_rev compact_e])
+
+text {* Deflations from ep-pairs *}
+
+lemma deflation_e_p: "deflation (e oo p)"
+by (simp add: deflation.intro e_p_below)
+
+lemma deflation_e_d_p:
+  assumes "deflation d"
+  shows "deflation (e oo d oo p)"
+proof
+  interpret deflation d by fact
+  fix x :: 'b
+  show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
+    by (simp add: idem)
+  show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
+    by (simp add: e_below_iff_below_p below)
+qed
+
+lemma finite_deflation_e_d_p:
+  assumes "finite_deflation d"
+  shows "finite_deflation (e oo d oo p)"
+proof
+  interpret finite_deflation d by fact
+  fix x :: 'b
+  show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
+    by (simp add: idem)
+  show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
+    by (simp add: e_below_iff_below_p below)
+  have "finite ((\<lambda>x. e\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. p\<cdot>x))"
+    by (simp add: finite_image)
+  hence "finite (range (\<lambda>x. (e oo d oo p)\<cdot>x))"
+    by (simp add: image_image)
+  thus "finite {x. (e oo d oo p)\<cdot>x = x}"
+    by (rule finite_range_imp_finite_fixes)
+qed
+
+lemma deflation_p_d_e:
+  assumes "deflation d"
+  assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
+  shows "deflation (p oo d oo e)"
+proof -
+  interpret d: deflation d by fact
+  {
+    fix x
+    have "d\<cdot>(e\<cdot>x) \<sqsubseteq> e\<cdot>x"
+      by (rule d.below)
+    hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(e\<cdot>x)"
+      by (rule monofun_cfun_arg)
+    hence "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
+      by simp
+  }
+  note p_d_e_below = this
+  show ?thesis
+  proof
+    fix x
+    show "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
+      by (rule p_d_e_below)
+  next
+    fix x
+    show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) = (p oo d oo e)\<cdot>x"
+    proof (rule below_antisym)
+      show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) \<sqsubseteq> (p oo d oo e)\<cdot>x"
+        by (rule p_d_e_below)
+      have "p\<cdot>(d\<cdot>(d\<cdot>(d\<cdot>(e\<cdot>x)))) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
+        by (intro monofun_cfun_arg d)
+      hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
+        by (simp only: d.idem)
+      thus "(p oo d oo e)\<cdot>x \<sqsubseteq> (p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x)"
+        by simp
+    qed
+  qed
+qed
+
+lemma finite_deflation_p_d_e:
+  assumes "finite_deflation d"
+  assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
+  shows "finite_deflation (p oo d oo e)"
+proof -
+  interpret d: finite_deflation d by fact
+  show ?thesis
+  proof (rule finite_deflation_intro)
+    have "deflation d" ..
+    thus "deflation (p oo d oo e)"
+      using d by (rule deflation_p_d_e)
+  next
+    have "finite ((\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
+      by (rule d.finite_image)
+    hence "finite ((\<lambda>x. p\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
+      by (rule finite_imageI)
+    hence "finite (range (\<lambda>x. (p oo d oo e)\<cdot>x))"
+      by (simp add: image_image)
+    thus "finite {x. (p oo d oo e)\<cdot>x = x}"
+      by (rule finite_range_imp_finite_fixes)
+  qed
+qed
+
+end
+
+subsection {* Uniqueness of ep-pairs *}
+
+lemma ep_pair_unique_e_lemma:
+  assumes 1: "ep_pair e1 p" and 2: "ep_pair e2 p"
+  shows "e1 \<sqsubseteq> e2"
+proof (rule cfun_belowI)
+  fix x
+  have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
+    by (rule ep_pair.e_p_below [OF 1])
+  thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
+    by (simp only: ep_pair.e_inverse [OF 2])
+qed
+
+lemma ep_pair_unique_e:
+  "\<lbrakk>ep_pair e1 p; ep_pair e2 p\<rbrakk> \<Longrightarrow> e1 = e2"
+by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)
+
+lemma ep_pair_unique_p_lemma:
+  assumes 1: "ep_pair e p1" and 2: "ep_pair e p2"
+  shows "p1 \<sqsubseteq> p2"
+proof (rule cfun_belowI)
+  fix x
+  have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
+    by (rule ep_pair.e_p_below [OF 1])
+  hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
+    by (rule monofun_cfun_arg)
+  thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
+    by (simp only: ep_pair.e_inverse [OF 2])
+qed
+
+lemma ep_pair_unique_p:
+  "\<lbrakk>ep_pair e p1; ep_pair e p2\<rbrakk> \<Longrightarrow> p1 = p2"
+by (fast intro: below_antisym elim: ep_pair_unique_p_lemma)
+
+subsection {* Composing ep-pairs *}
+
+lemma ep_pair_ID_ID: "ep_pair ID ID"
+by default simp_all
+
+lemma ep_pair_comp:
+  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
+  shows "ep_pair (e2 oo e1) (p1 oo p2)"
+proof
+  interpret ep1: ep_pair e1 p1 by fact
+  interpret ep2: ep_pair e2 p2 by fact
+  fix x y
+  show "(p1 oo p2)\<cdot>((e2 oo e1)\<cdot>x) = x"
+    by simp
+  have "e1\<cdot>(p1\<cdot>(p2\<cdot>y)) \<sqsubseteq> p2\<cdot>y"
+    by (rule ep1.e_p_below)
+  hence "e2\<cdot>(e1\<cdot>(p1\<cdot>(p2\<cdot>y))) \<sqsubseteq> e2\<cdot>(p2\<cdot>y)"
+    by (rule monofun_cfun_arg)
+  also have "e2\<cdot>(p2\<cdot>y) \<sqsubseteq> y"
+    by (rule ep2.e_p_below)
+  finally show "(e2 oo e1)\<cdot>((p1 oo p2)\<cdot>y) \<sqsubseteq> y"
+    by simp
+qed
+
+locale pcpo_ep_pair = ep_pair +
+  constrains e :: "'a::pcpo \<rightarrow> 'b::pcpo"
+  constrains p :: "'b::pcpo \<rightarrow> 'a::pcpo"
+begin
+
+lemma e_strict [simp]: "e\<cdot>\<bottom> = \<bottom>"
+proof -
+  have "\<bottom> \<sqsubseteq> p\<cdot>\<bottom>" by (rule minimal)
+  hence "e\<cdot>\<bottom> \<sqsubseteq> e\<cdot>(p\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
+  also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_below)
+  finally show "e\<cdot>\<bottom> = \<bottom>" by simp
+qed
+
+lemma e_bottom_iff [simp]: "e\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
+by (rule e_eq_iff [where y="\<bottom>", unfolded e_strict])
+
+lemma e_defined: "x \<noteq> \<bottom> \<Longrightarrow> e\<cdot>x \<noteq> \<bottom>"
+by simp
+
+lemma p_strict [simp]: "p\<cdot>\<bottom> = \<bottom>"
+by (rule e_inverse [where x="\<bottom>", unfolded e_strict])
+
+lemmas stricts = e_strict p_strict
+
+end
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Discrete.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,38 @@
+(*  Title:      HOLCF/Discrete.thy
+    Author:     Tobias Nipkow
+*)
+
+header {* Discrete cpo types *}
+
+theory Discrete
+imports Cont
+begin
+
+datatype 'a discr = Discr "'a :: type"
+
+subsection {* Discrete cpo class instance *}
+
+instantiation discr :: (type) discrete_cpo
+begin
+
+definition
+  "(op \<sqsubseteq> :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (op =)"
+
+instance
+by default (simp add: below_discr_def)
+
+end
+
+subsection {* \emph{undiscr} *}
+
+definition
+  undiscr :: "('a::type)discr => 'a" where
+  "undiscr x = (case x of Discr y => y)"
+
+lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
+by (simp add: undiscr_def)
+
+lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
+by (induct y) simp
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Domain.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,352 @@
+(*  Title:      HOLCF/Domain.thy
+    Author:     Brian Huffman
+*)
+
+header {* Domain package *}
+
+theory Domain
+imports Bifinite Domain_Aux
+uses
+  ("Tools/domaindef.ML")
+  ("Tools/Domain/domain_isomorphism.ML")
+  ("Tools/Domain/domain_axioms.ML")
+  ("Tools/Domain/domain.ML")
+begin
+
+default_sort "domain"
+
+subsection {* Representations of types *}
+
+lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a) = cast\<cdot>DEFL('a)\<cdot>x"
+by (simp add: cast_DEFL)
+
+lemma emb_prj_emb:
+  fixes x :: "'a"
+  assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
+  shows "emb\<cdot>(prj\<cdot>(emb\<cdot>x) :: 'b) = emb\<cdot>x"
+unfolding emb_prj
+apply (rule cast.belowD)
+apply (rule monofun_cfun_arg [OF assms])
+apply (simp add: cast_DEFL)
+done
+
+lemma prj_emb_prj:
+  assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
+  shows "prj\<cdot>(emb\<cdot>(prj\<cdot>x :: 'b)) = (prj\<cdot>x :: 'a)"
+ apply (rule emb_eq_iff [THEN iffD1])
+ apply (simp only: emb_prj)
+ apply (rule deflation_below_comp1)
+   apply (rule deflation_cast)
+  apply (rule deflation_cast)
+ apply (rule monofun_cfun_arg [OF assms])
+done
+
+text {* Isomorphism lemmas used internally by the domain package: *}
+
+lemma domain_abs_iso:
+  fixes abs and rep
+  assumes DEFL: "DEFL('b) = DEFL('a)"
+  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
+  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
+  shows "rep\<cdot>(abs\<cdot>x) = x"
+unfolding abs_def rep_def
+by (simp add: emb_prj_emb DEFL)
+
+lemma domain_rep_iso:
+  fixes abs and rep
+  assumes DEFL: "DEFL('b) = DEFL('a)"
+  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
+  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
+  shows "abs\<cdot>(rep\<cdot>x) = x"
+unfolding abs_def rep_def
+by (simp add: emb_prj_emb DEFL)
+
+subsection {* Deflations as sets *}
+
+definition defl_set :: "defl \<Rightarrow> udom set"
+where "defl_set A = {x. cast\<cdot>A\<cdot>x = x}"
+
+lemma adm_defl_set: "adm (\<lambda>x. x \<in> defl_set A)"
+unfolding defl_set_def by simp
+
+lemma defl_set_bottom: "\<bottom> \<in> defl_set A"
+unfolding defl_set_def by simp
+
+lemma defl_set_cast [simp]: "cast\<cdot>A\<cdot>x \<in> defl_set A"
+unfolding defl_set_def by simp
+
+lemma defl_set_subset_iff: "defl_set A \<subseteq> defl_set B \<longleftrightarrow> A \<sqsubseteq> B"
+apply (simp add: defl_set_def subset_eq cast_below_cast [symmetric])
+apply (auto simp add: cast.belowI cast.belowD)
+done
+
+subsection {* Proving a subtype is representable *}
+
+text {* Temporarily relax type constraints. *}
+
+setup {*
+  fold Sign.add_const_constraint
+  [ (@{const_name defl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
+  , (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"})
+  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"})
+  , (@{const_name liftdefl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
+  , (@{const_name liftemb}, SOME @{typ "'a::pcpo u \<rightarrow> udom"})
+  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::pcpo u"}) ]
+*}
+
+lemma typedef_liftdomain_class:
+  fixes Rep :: "'a::pcpo \<Rightarrow> udom"
+  fixes Abs :: "udom \<Rightarrow> 'a::pcpo"
+  fixes t :: defl
+  assumes type: "type_definition Rep Abs (defl_set t)"
+  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)"
+  assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))"
+  assumes defl: "defl \<equiv> (\<lambda> a::'a itself. t)"
+  assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
+  assumes liftprj: "(liftprj :: udom \<rightarrow> 'a u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
+  assumes liftdefl: "(liftdefl :: 'a itself \<Rightarrow> defl) \<equiv> (\<lambda>t. u_defl\<cdot>DEFL('a))"
+  shows "OFCLASS('a, liftdomain_class)"
+using liftemb [THEN meta_eq_to_obj_eq]
+using liftprj [THEN meta_eq_to_obj_eq]
+proof (rule liftdomain_class_intro)
+  have emb_beta: "\<And>x. emb\<cdot>x = Rep x"
+    unfolding emb
+    apply (rule beta_cfun)
+    apply (rule typedef_cont_Rep [OF type below adm_defl_set])
+    done
+  have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)"
+    unfolding prj
+    apply (rule beta_cfun)
+    apply (rule typedef_cont_Abs [OF type below adm_defl_set])
+    apply simp_all
+    done
+  have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x"
+    using type_definition.Rep [OF type]
+    unfolding prj_beta emb_beta defl_set_def
+    by (simp add: type_definition.Rep_inverse [OF type])
+  have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y"
+    unfolding prj_beta emb_beta
+    by (simp add: type_definition.Abs_inverse [OF type])
+  show "ep_pair (emb :: 'a \<rightarrow> udom) prj"
+    apply default
+    apply (simp add: prj_emb)
+    apply (simp add: emb_prj cast.below)
+    done
+  show "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
+    by (rule cfun_eqI, simp add: defl emb_prj)
+  show "LIFTDEFL('a) = u_defl\<cdot>DEFL('a)"
+    unfolding liftdefl ..
+qed
+
+lemma typedef_DEFL:
+  assumes "defl \<equiv> (\<lambda>a::'a::pcpo itself. t)"
+  shows "DEFL('a::pcpo) = t"
+unfolding assms ..
+
+text {* Restore original typing constraints. *}
+
+setup {*
+  fold Sign.add_const_constraint
+  [ (@{const_name defl}, SOME @{typ "'a::domain itself \<Rightarrow> defl"})
+  , (@{const_name emb}, SOME @{typ "'a::domain \<rightarrow> udom"})
+  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::domain"})
+  , (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> defl"})
+  , (@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom"})
+  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::predomain u"}) ]
+*}
+
+use "Tools/domaindef.ML"
+
+subsection {* Isomorphic deflations *}
+
+definition
+  isodefl :: "('a \<rightarrow> 'a) \<Rightarrow> defl \<Rightarrow> bool"
+where
+  "isodefl d t \<longleftrightarrow> cast\<cdot>t = emb oo d oo prj"
+
+lemma isodeflI: "(\<And>x. cast\<cdot>t\<cdot>x = emb\<cdot>(d\<cdot>(prj\<cdot>x))) \<Longrightarrow> isodefl d t"
+unfolding isodefl_def by (simp add: cfun_eqI)
+
+lemma cast_isodefl: "isodefl d t \<Longrightarrow> cast\<cdot>t = (\<Lambda> x. emb\<cdot>(d\<cdot>(prj\<cdot>x)))"
+unfolding isodefl_def by (simp add: cfun_eqI)
+
+lemma isodefl_strict: "isodefl d t \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
+unfolding isodefl_def
+by (drule cfun_fun_cong [where x="\<bottom>"], simp)
+
+lemma isodefl_imp_deflation:
+  fixes d :: "'a \<rightarrow> 'a"
+  assumes "isodefl d t" shows "deflation d"
+proof
+  note assms [unfolded isodefl_def, simp]
+  fix x :: 'a
+  show "d\<cdot>(d\<cdot>x) = d\<cdot>x"
+    using cast.idem [of t "emb\<cdot>x"] by simp
+  show "d\<cdot>x \<sqsubseteq> x"
+    using cast.below [of t "emb\<cdot>x"] by simp
+qed
+
+lemma isodefl_ID_DEFL: "isodefl (ID :: 'a \<rightarrow> 'a) DEFL('a)"
+unfolding isodefl_def by (simp add: cast_DEFL)
+
+lemma isodefl_LIFTDEFL:
+  "isodefl (u_map\<cdot>(ID :: 'a \<rightarrow> 'a)) LIFTDEFL('a::predomain)"
+unfolding u_map_ID DEFL_u [symmetric]
+by (rule isodefl_ID_DEFL)
+
+lemma isodefl_DEFL_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) DEFL('a) \<Longrightarrow> d = ID"
+unfolding isodefl_def
+apply (simp add: cast_DEFL)
+apply (simp add: cfun_eq_iff)
+apply (rule allI)
+apply (drule_tac x="emb\<cdot>x" in spec)
+apply simp
+done
+
+lemma isodefl_bottom: "isodefl \<bottom> \<bottom>"
+unfolding isodefl_def by (simp add: cfun_eq_iff)
+
+lemma adm_isodefl:
+  "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. isodefl (f x) (g x))"
+unfolding isodefl_def by simp
+
+lemma isodefl_lub:
+  assumes "chain d" and "chain t"
+  assumes "\<And>i. isodefl (d i) (t i)"
+  shows "isodefl (\<Squnion>i. d i) (\<Squnion>i. t i)"
+using prems unfolding isodefl_def
+by (simp add: contlub_cfun_arg contlub_cfun_fun)
+
+lemma isodefl_fix:
+  assumes "\<And>d t. isodefl d t \<Longrightarrow> isodefl (f\<cdot>d) (g\<cdot>t)"
+  shows "isodefl (fix\<cdot>f) (fix\<cdot>g)"
+unfolding fix_def2
+apply (rule isodefl_lub, simp, simp)
+apply (induct_tac i)
+apply (simp add: isodefl_bottom)
+apply (simp add: assms)
+done
+
+lemma isodefl_abs_rep:
+  fixes abs and rep and d
+  assumes DEFL: "DEFL('b) = DEFL('a)"
+  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
+  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
+  shows "isodefl d t \<Longrightarrow> isodefl (abs oo d oo rep) t"
+unfolding isodefl_def
+by (simp add: cfun_eq_iff assms prj_emb_prj emb_prj_emb)
+
+lemma isodefl_sfun:
+  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
+    isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
+apply (rule isodeflI)
+apply (simp add: cast_sfun_defl cast_isodefl)
+apply (simp add: emb_sfun_def prj_sfun_def)
+apply (simp add: sfun_map_map isodefl_strict)
+done
+
+lemma isodefl_ssum:
+  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
+    isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_defl\<cdot>t1\<cdot>t2)"
+apply (rule isodeflI)
+apply (simp add: cast_ssum_defl cast_isodefl)
+apply (simp add: emb_ssum_def prj_ssum_def)
+apply (simp add: ssum_map_map isodefl_strict)
+done
+
+lemma isodefl_sprod:
+  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
+    isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_defl\<cdot>t1\<cdot>t2)"
+apply (rule isodeflI)
+apply (simp add: cast_sprod_defl cast_isodefl)
+apply (simp add: emb_sprod_def prj_sprod_def)
+apply (simp add: sprod_map_map isodefl_strict)
+done
+
+lemma isodefl_cprod:
+  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
+    isodefl (cprod_map\<cdot>d1\<cdot>d2) (prod_defl\<cdot>t1\<cdot>t2)"
+apply (rule isodeflI)
+apply (simp add: cast_prod_defl cast_isodefl)
+apply (simp add: emb_prod_def prj_prod_def)
+apply (simp add: cprod_map_map cfcomp1)
+done
+
+lemma isodefl_u:
+  fixes d :: "'a::liftdomain \<rightarrow> 'a"
+  shows "isodefl (d :: 'a \<rightarrow> 'a) t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_u_defl cast_isodefl)
+apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq)
+apply (simp add: u_map_map)
+done
+
+lemma encode_prod_u_map:
+  "encode_prod_u\<cdot>(u_map\<cdot>(cprod_map\<cdot>f\<cdot>g)\<cdot>(decode_prod_u\<cdot>x))
+    = sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>g)\<cdot>x"
+unfolding encode_prod_u_def decode_prod_u_def
+apply (case_tac x, simp, rename_tac a b)
+apply (case_tac a, simp, case_tac b, simp, simp)
+done
+
+lemma isodefl_cprod_u:
+  assumes "isodefl (u_map\<cdot>d1) t1" and "isodefl (u_map\<cdot>d2) t2"
+  shows "isodefl (u_map\<cdot>(cprod_map\<cdot>d1\<cdot>d2)) (sprod_defl\<cdot>t1\<cdot>t2)"
+using assms unfolding isodefl_def
+apply (simp add: emb_u_def prj_u_def liftemb_prod_def liftprj_prod_def)
+apply (simp add: emb_u_def [symmetric] prj_u_def [symmetric])
+apply (simp add: cfcomp1 encode_prod_u_map cast_sprod_defl sprod_map_map)
+done
+
+lemma encode_cfun_map:
+  "encode_cfun\<cdot>(cfun_map\<cdot>f\<cdot>g\<cdot>(decode_cfun\<cdot>x))
+    = sfun_map\<cdot>(u_map\<cdot>f)\<cdot>g\<cdot>x"
+unfolding encode_cfun_def decode_cfun_def
+apply (simp add: sfun_eq_iff cfun_map_def sfun_map_def)
+apply (rule cfun_eqI, rename_tac y, case_tac y, simp_all)
+done
+
+lemma isodefl_cfun:
+  "isodefl (u_map\<cdot>d1) t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
+    isodefl (cfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
+apply (rule isodeflI)
+apply (simp add: cast_sfun_defl cast_isodefl)
+apply (simp add: emb_cfun_def prj_cfun_def encode_cfun_map)
+apply (simp add: sfun_map_map isodefl_strict)
+done
+
+subsection {* Setting up the domain package *}
+
+use "Tools/Domain/domain_isomorphism.ML"
+use "Tools/Domain/domain_axioms.ML"
+use "Tools/Domain/domain.ML"
+
+setup Domain_Isomorphism.setup
+
+lemmas [domain_defl_simps] =
+  DEFL_cfun DEFL_sfun DEFL_ssum DEFL_sprod DEFL_prod DEFL_u
+  liftdefl_eq LIFTDEFL_prod
+
+lemmas [domain_map_ID] =
+  cfun_map_ID sfun_map_ID ssum_map_ID sprod_map_ID cprod_map_ID u_map_ID
+
+lemmas [domain_isodefl] =
+  isodefl_u isodefl_sfun isodefl_ssum isodefl_sprod
+  isodefl_cfun isodefl_cprod isodefl_cprod_u
+
+lemmas [domain_deflation] =
+  deflation_cfun_map deflation_sfun_map deflation_ssum_map
+  deflation_sprod_map deflation_cprod_map deflation_u_map
+
+setup {*
+  fold Domain_Take_Proofs.add_rec_type
+    [(@{type_name cfun}, [true, true]),
+     (@{type_name "sfun"}, [true, true]),
+     (@{type_name ssum}, [true, true]),
+     (@{type_name sprod}, [true, true]),
+     (@{type_name prod}, [true, true]),
+     (@{type_name "u"}, [true])]
+*}
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Domain_Aux.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,361 @@
+(*  Title:      HOLCF/Domain_Aux.thy
+    Author:     Brian Huffman
+*)
+
+header {* Domain package support *}
+
+theory Domain_Aux
+imports Map_Functions Fixrec
+uses
+  ("Tools/Domain/domain_take_proofs.ML")
+  ("Tools/cont_consts.ML")
+  ("Tools/cont_proc.ML")
+  ("Tools/Domain/domain_constructors.ML")
+  ("Tools/Domain/domain_induction.ML")
+begin
+
+subsection {* Continuous isomorphisms *}
+
+text {* A locale for continuous isomorphisms *}
+
+locale iso =
+  fixes abs :: "'a \<rightarrow> 'b"
+  fixes rep :: "'b \<rightarrow> 'a"
+  assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
+  assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
+begin
+
+lemma swap: "iso rep abs"
+  by (rule iso.intro [OF rep_iso abs_iso])
+
+lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
+proof
+  assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
+  then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
+  then show "x \<sqsubseteq> y" by simp
+next
+  assume "x \<sqsubseteq> y"
+  then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
+qed
+
+lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
+  by (rule iso.abs_below [OF swap])
+
+lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
+  by (simp add: po_eq_conv abs_below)
+
+lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
+  by (rule iso.abs_eq [OF swap])
+
+lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
+proof -
+  have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
+  then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
+  then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
+  then show ?thesis by (rule UU_I)
+qed
+
+lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
+  by (rule iso.abs_strict [OF swap])
+
+lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
+proof -
+  have "x = rep\<cdot>(abs\<cdot>x)" by simp
+  also assume "abs\<cdot>x = \<bottom>"
+  also note rep_strict
+  finally show "x = \<bottom>" .
+qed
+
+lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
+  by (rule iso.abs_defin' [OF swap])
+
+lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
+  by (erule contrapos_nn, erule abs_defin')
+
+lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
+  by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)
+
+lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
+  by (auto elim: abs_defin' intro: abs_strict)
+
+lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
+  by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)
+
+lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
+  by (simp add: rep_bottom_iff)
+
+lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
+proof (unfold compact_def)
+  assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
+  with cont_Rep_cfun2
+  have "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> abs\<cdot>y)" by (rule adm_subst)
+  then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_below by simp
+qed
+
+lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
+  by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)
+
+lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
+  by (rule compact_rep_rev) simp
+
+lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
+  by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)
+
+lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
+proof
+  assume "x = abs\<cdot>y"
+  then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
+  then show "rep\<cdot>x = y" by simp
+next
+  assume "rep\<cdot>x = y"
+  then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
+  then show "x = abs\<cdot>y" by simp
+qed
+
+end
+
+subsection {* Proofs about take functions *}
+
+text {*
+  This section contains lemmas that are used in a module that supports
+  the domain isomorphism package; the module contains proofs related
+  to take functions and the finiteness predicate.
+*}
+
+lemma deflation_abs_rep:
+  fixes abs and rep and d
+  assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
+  assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
+  shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
+by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)
+
+lemma deflation_chain_min:
+  assumes chain: "chain d"
+  assumes defl: "\<And>n. deflation (d n)"
+  shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
+proof (rule linorder_le_cases)
+  assume "m \<le> n"
+  with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
+  then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
+    by (rule deflation_below_comp1 [OF defl defl])
+  moreover from `m \<le> n` have "min m n = m" by simp
+  ultimately show ?thesis by simp
+next
+  assume "n \<le> m"
+  with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
+  then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
+    by (rule deflation_below_comp2 [OF defl defl])
+  moreover from `n \<le> m` have "min m n = n" by simp
+  ultimately show ?thesis by simp
+qed
+
+lemma lub_ID_take_lemma:
+  assumes "chain t" and "(\<Squnion>n. t n) = ID"
+  assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
+proof -
+  have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
+    using assms(3) by simp
+  then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
+    using assms(1) by (simp add: lub_distribs)
+  then show "x = y"
+    using assms(2) by simp
+qed
+
+lemma lub_ID_reach:
+  assumes "chain t" and "(\<Squnion>n. t n) = ID"
+  shows "(\<Squnion>n. t n\<cdot>x) = x"
+using assms by (simp add: lub_distribs)
+
+lemma lub_ID_take_induct:
+  assumes "chain t" and "(\<Squnion>n. t n) = ID"
+  assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
+proof -
+  from `chain t` have "chain (\<lambda>n. t n\<cdot>x)" by simp
+  from `adm P` this `\<And>n. P (t n\<cdot>x)` have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
+  with `chain t` `(\<Squnion>n. t n) = ID` show "P x" by (simp add: lub_distribs)
+qed
+
+subsection {* Finiteness *}
+
+text {*
+  Let a ``decisive'' function be a deflation that maps every input to
+  either itself or bottom.  Then if a domain's take functions are all
+  decisive, then all values in the domain are finite.
+*}
+
+definition
+  decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
+where
+  "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"
+
+lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
+  unfolding decisive_def by simp
+
+lemma decisive_cases:
+  assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
+using assms unfolding decisive_def by auto
+
+lemma decisive_bottom: "decisive \<bottom>"
+  unfolding decisive_def by simp
+
+lemma decisive_ID: "decisive ID"
+  unfolding decisive_def by simp
+
+lemma decisive_ssum_map:
+  assumes f: "decisive f"
+  assumes g: "decisive g"
+  shows "decisive (ssum_map\<cdot>f\<cdot>g)"
+apply (rule decisiveI, rename_tac s)
+apply (case_tac s, simp_all)
+apply (rule_tac x=x in decisive_cases [OF f], simp_all)
+apply (rule_tac x=y in decisive_cases [OF g], simp_all)
+done
+
+lemma decisive_sprod_map:
+  assumes f: "decisive f"
+  assumes g: "decisive g"
+  shows "decisive (sprod_map\<cdot>f\<cdot>g)"
+apply (rule decisiveI, rename_tac s)
+apply (case_tac s, simp_all)
+apply (rule_tac x=x in decisive_cases [OF f], simp_all)
+apply (rule_tac x=y in decisive_cases [OF g], simp_all)
+done
+
+lemma decisive_abs_rep:
+  fixes abs rep
+  assumes iso: "iso abs rep"
+  assumes d: "decisive d"
+  shows "decisive (abs oo d oo rep)"
+apply (rule decisiveI)
+apply (rule_tac x="rep\<cdot>x" in decisive_cases [OF d])
+apply (simp add: iso.rep_iso [OF iso])
+apply (simp add: iso.abs_strict [OF iso])
+done
+
+lemma lub_ID_finite:
+  assumes chain: "chain d"
+  assumes lub: "(\<Squnion>n. d n) = ID"
+  assumes decisive: "\<And>n. decisive (d n)"
+  shows "\<exists>n. d n\<cdot>x = x"
+proof -
+  have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
+  have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
+  have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
+    using decisive unfolding decisive_def by simp
+  hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
+    by auto
+  hence "finite (range (\<lambda>n. d n\<cdot>x))"
+    by (rule finite_subset, simp)
+  with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
+    by (rule finite_range_imp_finch)
+  then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
+    unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
+  with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
+qed
+
+lemma lub_ID_finite_take_induct:
+  assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
+  shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
+using lub_ID_finite [OF assms] by metis
+
+subsection {* Proofs about constructor functions *}
+
+text {* Lemmas for proving nchotomy rule: *}
+
+lemma ex_one_bottom_iff:
+  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
+by simp
+
+lemma ex_up_bottom_iff:
+  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
+by (safe, case_tac x, auto)
+
+lemma ex_sprod_bottom_iff:
+ "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
+  (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
+by (safe, case_tac y, auto)
+
+lemma ex_sprod_up_bottom_iff:
+ "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
+  (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
+by (safe, case_tac y, simp, case_tac x, auto)
+
+lemma ex_ssum_bottom_iff:
+ "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
+ ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
+  (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
+by (safe, case_tac x, auto)
+
+lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
+  by auto
+
+lemmas ex_bottom_iffs =
+   ex_ssum_bottom_iff
+   ex_sprod_up_bottom_iff
+   ex_sprod_bottom_iff
+   ex_up_bottom_iff
+   ex_one_bottom_iff
+
+text {* Rules for turning nchotomy into exhaust: *}
+
+lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
+  by auto
+
+lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
+  by rule auto
+
+lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
+  by rule auto
+
+lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
+  by rule auto
+
+lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
+
+text {* Rules for proving constructor properties *}
+
+lemmas con_strict_rules =
+  sinl_strict sinr_strict spair_strict1 spair_strict2
+
+lemmas con_bottom_iff_rules =
+  sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined
+
+lemmas con_below_iff_rules =
+  sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules
+
+lemmas con_eq_iff_rules =
+  sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules
+
+lemmas sel_strict_rules =
+  cfcomp2 sscase1 sfst_strict ssnd_strict fup1
+
+lemma sel_app_extra_rules:
+  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
+  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
+  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
+  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
+  "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
+by (cases "x = \<bottom>", simp, simp)+
+
+lemmas sel_app_rules =
+  sel_strict_rules sel_app_extra_rules
+  ssnd_spair sfst_spair up_defined spair_defined
+
+lemmas sel_bottom_iff_rules =
+  cfcomp2 sfst_bottom_iff ssnd_bottom_iff
+
+lemmas take_con_rules =
+  ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
+  deflation_strict deflation_ID ID1 cfcomp2
+
+subsection {* ML setup *}
+
+use "Tools/Domain/domain_take_proofs.ML"
+use "Tools/cont_consts.ML"
+use "Tools/cont_proc.ML"
+use "Tools/Domain/domain_constructors.ML"
+use "Tools/Domain/domain_induction.ML"
+
+setup Domain_Take_Proofs.setup
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/Buffer.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,381 @@
+(*  Title:      HOLCF/FOCUS/Buffer.thy
+    Author:     David von Oheimb, TU Muenchen
+
+Formalization of section 4 of
+
+@inproceedings {broy_mod94,
+    author = {Manfred Broy},
+    title = {{Specification and Refinement of a Buffer of Length One}},
+    booktitle = {Deductive Program Design},
+    year = {1994},
+    editor = {Manfred Broy},
+    volume = {152},
+    series = {ASI Series, Series F: Computer and System Sciences},
+    pages = {273 -- 304},
+    publisher = {Springer}
+}
+
+Slides available from http://ddvo.net/talks/1-Buffer.ps.gz
+
+*)
+
+theory Buffer
+imports FOCUS
+begin
+
+typedecl D
+
+datatype
+
+  M     = Md D | Mreq ("\<bullet>")
+
+datatype
+
+  State = Sd D | Snil ("\<currency>")
+
+types
+
+  SPF11         = "M fstream \<rightarrow> D fstream"
+  SPEC11        = "SPF11 set"
+  SPSF11        = "State \<Rightarrow> SPF11"
+  SPECS11       = "SPSF11 set"
+
+definition
+  BufEq_F       :: "SPEC11 \<Rightarrow> SPEC11" where
+  "BufEq_F B = {f. \<forall>d. f\<cdot>(Md d\<leadsto><>) = <> \<and>
+                (\<forall>x. \<exists>ff\<in>B. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x)}"
+
+definition
+  BufEq         :: "SPEC11" where
+  "BufEq = gfp BufEq_F"
+
+definition
+  BufEq_alt     :: "SPEC11" where
+  "BufEq_alt = gfp (\<lambda>B. {f. \<forall>d. f\<cdot>(Md d\<leadsto><> ) = <> \<and>
+                         (\<exists>ff\<in>B. (\<forall>x. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x))})"
+
+definition
+  BufAC_Asm_F   :: " (M fstream set) \<Rightarrow> (M fstream set)" where
+  "BufAC_Asm_F A = {s. s = <> \<or>
+                  (\<exists>d x. s = Md d\<leadsto>x \<and> (x = <> \<or> (ft\<cdot>x = Def \<bullet> \<and> (rt\<cdot>x)\<in>A)))}"
+
+definition
+  BufAC_Asm     :: " (M fstream set)" where
+  "BufAC_Asm = gfp BufAC_Asm_F"
+
+definition
+  BufAC_Cmt_F   :: "((M fstream * D fstream) set) \<Rightarrow>
+                    ((M fstream * D fstream) set)" where
+  "BufAC_Cmt_F C = {(s,t). \<forall>d x.
+                           (s = <>         \<longrightarrow>     t = <>                 ) \<and>
+                           (s = Md d\<leadsto><>   \<longrightarrow>     t = <>                 ) \<and>
+                           (s = Md d\<leadsto>\<bullet>\<leadsto>x \<longrightarrow> (ft\<cdot>t = Def d \<and> (x,rt\<cdot>t)\<in>C))}"
+
+definition
+  BufAC_Cmt     :: "((M fstream * D fstream) set)" where
+  "BufAC_Cmt = gfp BufAC_Cmt_F"
+
+definition
+  BufAC         :: "SPEC11" where
+  "BufAC = {f. \<forall>x. x\<in>BufAC_Asm \<longrightarrow> (x,f\<cdot>x)\<in>BufAC_Cmt}"
+
+definition
+  BufSt_F       :: "SPECS11 \<Rightarrow> SPECS11" where
+  "BufSt_F H = {h. \<forall>s  . h s      \<cdot><>        = <>         \<and>
+                                 (\<forall>d x. h \<currency>     \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x \<and>
+                                (\<exists>hh\<in>H. h (Sd d)\<cdot>(\<bullet>   \<leadsto>x) = d\<leadsto>(hh \<currency>\<cdot>x)))}"
+
+definition
+  BufSt_P       :: "SPECS11" where
+  "BufSt_P = gfp BufSt_F"
+
+definition
+  BufSt         :: "SPEC11" where
+  "BufSt = {f. \<exists>h\<in>BufSt_P. f = h \<currency>}"
+
+
+lemma set_cong: "!!X. A = B ==> (x:A) = (x:B)"
+by (erule subst, rule refl)
+
+
+(**** BufEq *******************************************************************)
+
+lemma mono_BufEq_F: "mono BufEq_F"
+by (unfold mono_def BufEq_F_def, fast)
+
+lemmas BufEq_fix = mono_BufEq_F [THEN BufEq_def [THEN eq_reflection, THEN def_gfp_unfold]]
+
+lemma BufEq_unfold: "(f:BufEq) = (!d. f\<cdot>(Md d\<leadsto><>) = <> &
+                 (!x. ? ff:BufEq. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>(ff\<cdot>x)))"
+apply (subst BufEq_fix [THEN set_cong])
+apply (unfold BufEq_F_def)
+apply (simp)
+done
+
+lemma Buf_f_empty: "f:BufEq \<Longrightarrow> f\<cdot><> = <>"
+by (drule BufEq_unfold [THEN iffD1], auto)
+
+lemma Buf_f_d: "f:BufEq \<Longrightarrow> f\<cdot>(Md d\<leadsto><>) = <>"
+by (drule BufEq_unfold [THEN iffD1], auto)
+
+lemma Buf_f_d_req:
+        "f:BufEq \<Longrightarrow> \<exists>ff. ff:BufEq \<and> f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x"
+by (drule BufEq_unfold [THEN iffD1], auto)
+
+
+(**** BufAC_Asm ***************************************************************)
+
+lemma mono_BufAC_Asm_F: "mono BufAC_Asm_F"
+by (unfold mono_def BufAC_Asm_F_def, fast)
+
+lemmas BufAC_Asm_fix =
+  mono_BufAC_Asm_F [THEN BufAC_Asm_def [THEN eq_reflection, THEN def_gfp_unfold]]
+
+lemma BufAC_Asm_unfold: "(s:BufAC_Asm) = (s = <> | (? d x. 
+        s = Md d\<leadsto>x & (x = <> | (ft\<cdot>x = Def \<bullet> & (rt\<cdot>x):BufAC_Asm))))"
+apply (subst BufAC_Asm_fix [THEN set_cong])
+apply (unfold BufAC_Asm_F_def)
+apply (simp)
+done
+
+lemma BufAC_Asm_empty: "<>     :BufAC_Asm"
+by (rule BufAC_Asm_unfold [THEN iffD2], auto)
+
+lemma BufAC_Asm_d: "Md d\<leadsto><>:BufAC_Asm"
+by (rule BufAC_Asm_unfold [THEN iffD2], auto)
+lemma BufAC_Asm_d_req: "x:BufAC_Asm ==> Md d\<leadsto>\<bullet>\<leadsto>x:BufAC_Asm"
+by (rule BufAC_Asm_unfold [THEN iffD2], auto)
+lemma BufAC_Asm_prefix2: "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> s:BufAC_Asm"
+by (drule BufAC_Asm_unfold [THEN iffD1], auto)
+
+
+(**** BBufAC_Cmt **************************************************************)
+
+lemma mono_BufAC_Cmt_F: "mono BufAC_Cmt_F"
+by (unfold mono_def BufAC_Cmt_F_def, fast)
+
+lemmas BufAC_Cmt_fix =
+  mono_BufAC_Cmt_F [THEN BufAC_Cmt_def [THEN eq_reflection, THEN def_gfp_unfold]]
+
+lemma BufAC_Cmt_unfold: "((s,t):BufAC_Cmt) = (!d x. 
+     (s = <>       -->      t = <>) & 
+     (s = Md d\<leadsto><>  -->      t = <>) & 
+     (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x, rt\<cdot>t):BufAC_Cmt))"
+apply (subst BufAC_Cmt_fix [THEN set_cong])
+apply (unfold BufAC_Cmt_F_def)
+apply (simp)
+done
+
+lemma BufAC_Cmt_empty: "f:BufEq ==> (<>, f\<cdot><>):BufAC_Cmt"
+by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_empty)
+
+lemma BufAC_Cmt_d: "f:BufEq ==> (a\<leadsto>\<bottom>, f\<cdot>(a\<leadsto>\<bottom>)):BufAC_Cmt"
+by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_d)
+
+lemma BufAC_Cmt_d2:
+ "(Md d\<leadsto>\<bottom>, f\<cdot>(Md d\<leadsto>\<bottom>)):BufAC_Cmt ==> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
+by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
+
+lemma BufAC_Cmt_d3:
+"(Md d\<leadsto>\<bullet>\<leadsto>x, f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x)):BufAC_Cmt ==> (x, rt\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x))):BufAC_Cmt"
+by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
+
+lemma BufAC_Cmt_d32:
+"(Md d\<leadsto>\<bullet>\<leadsto>x, f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x)):BufAC_Cmt ==> ft\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x)) = Def d"
+by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
+
+(**** BufAC *******************************************************************)
+
+lemma BufAC_f_d: "f \<in> BufAC \<Longrightarrow> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
+apply (unfold BufAC_def)
+apply (fast intro: BufAC_Cmt_d2 BufAC_Asm_d)
+done
+
+lemma ex_elim_lemma: "(? ff:B. (!x. f\<cdot>(a\<leadsto>b\<leadsto>x) = d\<leadsto>ff\<cdot>x)) = 
+    ((!x. ft\<cdot>(f\<cdot>(a\<leadsto>b\<leadsto>x)) = Def d) & (LAM x. rt\<cdot>(f\<cdot>(a\<leadsto>b\<leadsto>x))):B)"
+(*  this is an instance (though unification cannot handle this) of
+lemma "(? ff:B. (!x. f\<cdot>x = d\<leadsto>ff\<cdot>x)) = \
+   \((!x. ft\<cdot>(f\<cdot>x) = Def d) & (LAM x. rt\<cdot>(f\<cdot>x)):B)"*)
+apply safe
+apply (  rule_tac [2] P="(%x. x:B)" in ssubst)
+prefer 3
+apply (   assumption)
+apply (  rule_tac [2] cfun_eqI)
+apply (  drule_tac [2] spec)
+apply (  drule_tac [2] f="rt" in cfun_arg_cong)
+prefer 2
+apply (  simp)
+prefer 2
+apply ( simp)
+apply (rule_tac bexI)
+apply auto
+apply (drule spec)
+apply (erule exE)
+apply (erule ssubst)
+apply (simp)
+done
+
+lemma BufAC_f_d_req: "f\<in>BufAC \<Longrightarrow> \<exists>ff\<in>BufAC. \<forall>x. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x"
+apply (unfold BufAC_def)
+apply (rule ex_elim_lemma [THEN iffD2])
+apply safe
+apply  (fast intro: BufAC_Cmt_d32 [THEN Def_maximal]
+             monofun_cfun_arg BufAC_Asm_empty [THEN BufAC_Asm_d_req])
+apply (auto intro: BufAC_Cmt_d3 BufAC_Asm_d_req)
+done
+
+
+(**** BufSt *******************************************************************)
+
+lemma mono_BufSt_F: "mono BufSt_F"
+by (unfold mono_def BufSt_F_def, fast)
+
+lemmas BufSt_P_fix =
+  mono_BufSt_F [THEN BufSt_P_def [THEN eq_reflection, THEN def_gfp_unfold]]
+
+lemma BufSt_P_unfold: "(h:BufSt_P) = (!s. h s\<cdot><> = <> & 
+           (!d x. h \<currency>     \<cdot>(Md d\<leadsto>x)   =    h (Sd d)\<cdot>x & 
+      (? hh:BufSt_P. h (Sd d)\<cdot>(\<bullet>\<leadsto>x)   = d\<leadsto>(hh \<currency>    \<cdot>x))))"
+apply (subst BufSt_P_fix [THEN set_cong])
+apply (unfold BufSt_F_def)
+apply (simp)
+done
+
+lemma BufSt_P_empty: "h:BufSt_P ==> h s     \<cdot> <>       = <>"
+by (drule BufSt_P_unfold [THEN iffD1], auto)
+lemma BufSt_P_d: "h:BufSt_P ==> h  \<currency>    \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x"
+by (drule BufSt_P_unfold [THEN iffD1], auto)
+lemma BufSt_P_d_req: "h:BufSt_P ==> \<exists>hh\<in>BufSt_P.
+                                          h (Sd d)\<cdot>(\<bullet>   \<leadsto>x) = d\<leadsto>(hh \<currency>    \<cdot>x)"
+by (drule BufSt_P_unfold [THEN iffD1], auto)
+
+
+(**** Buf_AC_imp_Eq ***********************************************************)
+
+lemma Buf_AC_imp_Eq: "BufAC \<subseteq> BufEq"
+apply (unfold BufEq_def)
+apply (rule gfp_upperbound)
+apply (unfold BufEq_F_def)
+apply safe
+apply  (erule BufAC_f_d)
+apply (drule BufAC_f_d_req)
+apply (fast)
+done
+
+
+(**** Buf_Eq_imp_AC by coinduction ********************************************)
+
+lemma BufAC_Asm_cong_lemma [rule_format]: "\<forall>s f ff. f\<in>BufEq \<longrightarrow> ff\<in>BufEq \<longrightarrow> 
+  s\<in>BufAC_Asm \<longrightarrow> stream_take n\<cdot>(f\<cdot>s) = stream_take n\<cdot>(ff\<cdot>s)"
+apply (induct_tac "n")
+apply  (simp)
+apply (intro strip)
+apply (drule BufAC_Asm_unfold [THEN iffD1])
+apply safe
+apply   (simp add: Buf_f_empty)
+apply  (simp add: Buf_f_d)
+apply (drule ft_eq [THEN iffD1])
+apply (clarsimp)
+apply (drule Buf_f_d_req)+
+apply safe
+apply (erule ssubst)+
+apply (simp (no_asm))
+apply (fast)
+done
+
+lemma BufAC_Asm_cong: "\<lbrakk>f \<in> BufEq; ff \<in> BufEq; s \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> f\<cdot>s = ff\<cdot>s"
+apply (rule stream.take_lemma)
+apply (erule (2) BufAC_Asm_cong_lemma)
+done
+
+lemma Buf_Eq_imp_AC_lemma: "\<lbrakk>f \<in> BufEq; x \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> (x, f\<cdot>x) \<in> BufAC_Cmt"
+apply (unfold BufAC_Cmt_def)
+apply (rotate_tac)
+apply (erule weak_coinduct_image)
+apply (unfold BufAC_Cmt_F_def)
+apply safe
+apply    (erule Buf_f_empty)
+apply   (erule Buf_f_d)
+apply  (drule Buf_f_d_req)
+apply  (clarsimp)
+apply  (erule exI)
+apply (drule BufAC_Asm_prefix2)
+apply (frule Buf_f_d_req)
+apply (clarsimp)
+apply (erule ssubst)
+apply (simp)
+apply (drule (2) BufAC_Asm_cong)
+apply (erule subst)
+apply (erule imageI)
+done
+lemma Buf_Eq_imp_AC: "BufEq \<subseteq> BufAC"
+apply (unfold BufAC_def)
+apply (clarify)
+apply (erule (1) Buf_Eq_imp_AC_lemma)
+done
+
+(**** Buf_Eq_eq_AC ************************************************************)
+
+lemmas Buf_Eq_eq_AC = Buf_AC_imp_Eq [THEN Buf_Eq_imp_AC [THEN subset_antisym]]
+
+
+(**** alternative (not strictly) stronger version of Buf_Eq *******************)
+
+lemma Buf_Eq_alt_imp_Eq: "BufEq_alt \<subseteq> BufEq"
+apply (unfold BufEq_def BufEq_alt_def)
+apply (rule gfp_mono)
+apply (unfold BufEq_F_def)
+apply (fast)
+done
+
+(* direct proof of "BufEq \<subseteq> BufEq_alt" seems impossible *)
+
+
+lemma Buf_AC_imp_Eq_alt: "BufAC <= BufEq_alt"
+apply (unfold BufEq_alt_def)
+apply (rule gfp_upperbound)
+apply (fast elim: BufAC_f_d BufAC_f_d_req)
+done
+
+lemmas Buf_Eq_imp_Eq_alt = subset_trans [OF Buf_Eq_imp_AC Buf_AC_imp_Eq_alt]
+
+lemmas Buf_Eq_alt_eq = subset_antisym [OF Buf_Eq_alt_imp_Eq Buf_Eq_imp_Eq_alt]
+
+
+(**** Buf_Eq_eq_St ************************************************************)
+
+lemma Buf_St_imp_Eq: "BufSt <= BufEq"
+apply (unfold BufSt_def BufEq_def)
+apply (rule gfp_upperbound)
+apply (unfold BufEq_F_def)
+apply safe
+apply ( simp add: BufSt_P_d BufSt_P_empty)
+apply (simp add: BufSt_P_d)
+apply (drule BufSt_P_d_req)
+apply (force)
+done
+
+lemma Buf_Eq_imp_St: "BufEq <= BufSt"
+apply (unfold BufSt_def BufSt_P_def)
+apply safe
+apply (rename_tac f)
+apply (rule_tac x="\<lambda>s. case s of Sd d => \<Lambda> x. f\<cdot>(Md d\<leadsto>x)| \<currency> => f" in bexI)
+apply ( simp)
+apply (erule weak_coinduct_image)
+apply (unfold BufSt_F_def)
+apply (simp)
+apply safe
+apply (  rename_tac "s")
+apply (  induct_tac "s")
+apply (   simp add: Buf_f_d)
+apply (  simp add: Buf_f_empty)
+apply ( simp)
+apply (simp)
+apply (rename_tac f d x)
+apply (drule_tac d="d" and x="x" in Buf_f_d_req)
+apply auto
+done
+
+lemmas Buf_Eq_eq_St = Buf_St_imp_Eq [THEN Buf_Eq_imp_St [THEN subset_antisym]]
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/Buffer_adm.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,300 @@
+(*  Title:      HOLCF/FOCUS/Buffer_adm.thy
+    Author:     David von Oheimb, TU Muenchen
+*)
+
+header {* One-element buffer, proof of Buf_Eq_imp_AC by induction + admissibility *}
+
+theory Buffer_adm
+imports Buffer Stream_adm
+begin
+
+declare Fin_0 [simp]
+
+lemma BufAC_Asm_d2: "a\<leadsto>s:BufAC_Asm ==> ? d. a=Md d"
+by (drule BufAC_Asm_unfold [THEN iffD1], auto)
+
+lemma BufAC_Asm_d3:
+    "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> ? d. a=Md d & b=\<bullet> & s:BufAC_Asm"
+by (drule BufAC_Asm_unfold [THEN iffD1], auto)
+
+lemma BufAC_Asm_F_def3:
+ "(s:BufAC_Asm_F A) = (s=<> | 
+  (? d. ft\<cdot>s=Def(Md d)) & (rt\<cdot>s=<> | ft\<cdot>(rt\<cdot>s)=Def \<bullet> & rt\<cdot>(rt\<cdot>s):A))"
+by (unfold BufAC_Asm_F_def, auto)
+
+lemma cont_BufAC_Asm_F: "down_cont BufAC_Asm_F"
+by (auto simp add: down_cont_def BufAC_Asm_F_def3)
+
+lemma BufAC_Cmt_F_def3:
+ "((s,t):BufAC_Cmt_F C) = (!d x.
+    (s = <>       --> t = <>                   ) & 
+    (s = Md d\<leadsto><>  --> t = <>                   ) & 
+    (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C))"
+apply (unfold BufAC_Cmt_F_def)
+apply (subgoal_tac "!d x. (s = Md d\<leadsto>\<bullet>\<leadsto>x --> (? y. t = d\<leadsto>y & (x,y):C)) = 
+                     (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C)")
+apply (simp)
+apply (auto intro: surjectiv_scons [symmetric])
+done
+
+lemma cont_BufAC_Cmt_F: "down_cont BufAC_Cmt_F"
+by (auto simp add: down_cont_def BufAC_Cmt_F_def3)
+
+
+(**** adm_BufAC_Asm ***********************************************************)
+
+lemma BufAC_Asm_F_stream_monoP: "stream_monoP BufAC_Asm_F"
+apply (unfold BufAC_Asm_F_def stream_monoP_def)
+apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
+apply (rule_tac x="Suc (Suc 0)" in exI)
+apply (clarsimp)
+done
+
+lemma adm_BufAC_Asm: "adm (%x. x:BufAC_Asm)"
+apply (unfold BufAC_Asm_def)
+apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_monoP [THEN fstream_gfp_admI]])
+done
+
+
+(**** adm_non_BufAC_Asm *******************************************************)
+
+lemma BufAC_Asm_F_stream_antiP: "stream_antiP BufAC_Asm_F"
+apply (unfold stream_antiP_def BufAC_Asm_F_def)
+apply (intro strip)
+apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
+apply (rule_tac x="Suc (Suc 0)" in exI)
+apply (rule conjI)
+prefer 2
+apply ( intro strip)
+apply ( drule slen_mono)
+apply ( drule (1) order_trans)
+apply (force)+
+done
+
+lemma adm_non_BufAC_Asm: "adm (%u. u~:BufAC_Asm)"
+apply (unfold BufAC_Asm_def)
+apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_antiP [THEN fstream_non_gfp_admI]])
+done
+
+(**** adm_BufAC ***************************************************************)
+
+(*adm_non_BufAC_Asm*)
+lemma BufAC_Asm_cong [rule_format]: "!f ff. f:BufEq --> ff:BufEq --> s:BufAC_Asm --> f\<cdot>s = ff\<cdot>s"
+apply (rule fstream_ind2)
+apply (simp add: adm_non_BufAC_Asm)
+apply   (force dest: Buf_f_empty)
+apply  (force dest!: BufAC_Asm_d2
+              dest: Buf_f_d elim: ssubst)
+apply (safe dest!: BufAC_Asm_d3)
+apply (drule Buf_f_d_req)+
+apply (fast elim: ssubst)
+done
+
+(*adm_non_BufAC_Asm,BufAC_Asm_cong*)
+lemma BufAC_Cmt_d_req:
+"!!X. [|f:BufEq; s:BufAC_Asm; (s, f\<cdot>s):BufAC_Cmt|] ==> (a\<leadsto>b\<leadsto>s, f\<cdot>(a\<leadsto>b\<leadsto>s)):BufAC_Cmt"
+apply (rule BufAC_Cmt_unfold [THEN iffD2])
+apply (intro strip)
+apply (frule Buf_f_d_req)
+apply (auto elim: BufAC_Asm_cong [THEN subst])
+done
+
+(*adm_BufAC_Asm*)
+lemma BufAC_Asm_antiton: "antitonP BufAC_Asm"
+apply (rule antitonPI)
+apply (rule allI)
+apply (rule fstream_ind2)
+apply (  rule adm_lemmas)+
+apply (   rule cont_id)
+apply (   rule adm_BufAC_Asm)
+apply (  safe)
+apply (  rule BufAC_Asm_empty)
+apply ( force dest!: fstream_prefix
+              dest: BufAC_Asm_d2 intro: BufAC_Asm_d)
+apply ( force dest!: fstream_prefix
+              dest: BufAC_Asm_d3 intro!: BufAC_Asm_d_req)
+done
+
+(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong*)
+lemma BufAC_Cmt_2stream_monoP: "f:BufEq ==> ? l. !i x s. s:BufAC_Asm --> x << s --> Fin (l i) < #x --> 
+                     (x,f\<cdot>x):down_iterate BufAC_Cmt_F i --> 
+                     (s,f\<cdot>s):down_iterate BufAC_Cmt_F i"
+apply (rule_tac x="%i. 2*i" in exI)
+apply (rule allI)
+apply (induct_tac "i")
+apply ( simp)
+apply (simp add: add_commute)
+apply (intro strip)
+apply (subst BufAC_Cmt_F_def3)
+apply (drule_tac P="%x. x" in BufAC_Cmt_F_def3 [THEN subst])
+apply safe
+apply (   erule Buf_f_empty)
+apply (  erule Buf_f_d)
+apply ( drule Buf_f_d_req)
+apply ( safe, erule ssubst, simp)
+apply clarsimp
+apply (rename_tac i d xa ya t)
+(*
+ 1. \<And>i d xa ya t.
+       \<lbrakk>f \<in> BufEq;
+          \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
+                x \<sqsubseteq> s \<longrightarrow>
+                Fin (2 * i) < #x \<longrightarrow>
+                (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
+                (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
+          Md d\<leadsto>\<bullet>\<leadsto>xa \<in> BufAC_Asm; Fin (2 * i) < #ya; f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>t;
+          (ya, t) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa\<rbrakk>
+       \<Longrightarrow> (xa, rt\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>xa))) \<in> down_iterate BufAC_Cmt_F i
+*)
+apply (rotate_tac 2)
+apply (drule BufAC_Asm_prefix2)
+apply (frule Buf_f_d_req, erule exE, erule conjE, rotate_tac -1, erule ssubst)
+apply (frule Buf_f_d_req, erule exE, erule conjE)
+apply (            subgoal_tac "f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya")
+prefer 2
+apply ( assumption)
+apply (            rotate_tac -1)
+apply (            simp)
+apply (erule subst)
+(*
+ 1. \<And>i d xa ya t ff ffa.
+       \<lbrakk>f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya; Fin (2 * i) < #ya;
+          (ya, ffa\<cdot>ya) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa; f \<in> BufEq;
+          \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
+                x \<sqsubseteq> s \<longrightarrow>
+                Fin (2 * i) < #x \<longrightarrow>
+                (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
+                (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
+          xa \<in> BufAC_Asm; ff \<in> BufEq; ffa \<in> BufEq\<rbrakk>
+       \<Longrightarrow> (xa, ff\<cdot>xa) \<in> down_iterate BufAC_Cmt_F i
+*)
+apply (drule spec, drule spec, drule (1) mp)
+apply (drule (1) mp)
+apply (drule (1) mp)
+apply (erule impE)
+apply ( subst BufAC_Asm_cong, assumption)
+prefer 3 apply assumption
+apply assumption
+apply ( erule (1) BufAC_Asm_antiton [THEN antitonPD])
+apply (subst BufAC_Asm_cong, assumption)
+prefer 3 apply assumption
+apply assumption
+apply assumption
+done
+
+lemma BufAC_Cmt_iterate_all: "(x\<in>BufAC_Cmt) = (\<forall>n. x\<in>down_iterate BufAC_Cmt_F n)"
+apply (unfold BufAC_Cmt_def)
+apply (subst cont_BufAC_Cmt_F [THEN INTER_down_iterate_is_gfp])
+apply (fast)
+done
+
+(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
+  BufAC_Cmt_2stream_monoP*)
+lemma adm_BufAC: "f:BufEq ==> adm (%s. s:BufAC_Asm --> (s, f\<cdot>s):BufAC_Cmt)"
+apply (rule flatstream_admI)
+apply (subst BufAC_Cmt_iterate_all)
+apply (drule BufAC_Cmt_2stream_monoP)
+apply safe
+apply (drule spec, erule exE)
+apply (drule spec, erule impE)
+apply  (erule BufAC_Asm_antiton [THEN antitonPD])
+apply  (erule is_ub_thelub)
+apply (tactic "smp_tac 3 1")
+apply (drule is_ub_thelub)
+apply (drule (1) mp)
+apply (drule (1) mp)
+apply (erule mp)
+apply (drule BufAC_Cmt_iterate_all [THEN iffD1])
+apply (erule spec)
+done
+
+
+
+(**** Buf_Eq_imp_AC by induction **********************************************)
+
+(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
+  BufAC_Cmt_2stream_monoP,adm_BufAC,BufAC_Cmt_d_req*)
+lemma Buf_Eq_imp_AC: "BufEq <= BufAC"
+apply (unfold BufAC_def)
+apply (rule subsetI)
+apply (simp)
+apply (rule allI)
+apply (rule fstream_ind2)
+back
+apply (   erule adm_BufAC)
+apply (  safe)
+apply (   erule BufAC_Cmt_empty)
+apply (  erule BufAC_Cmt_d)
+apply ( drule BufAC_Asm_prefix2)
+apply ( simp)
+apply (fast intro: BufAC_Cmt_d_req BufAC_Asm_prefix2)
+done
+
+(**** new approach for admissibility, reduces itself to absurdity *************)
+
+lemma adm_BufAC_Asm': "adm (\<lambda>x. x\<in>BufAC_Asm)"
+apply (rule def_gfp_admI)
+apply (rule BufAC_Asm_def [THEN eq_reflection])
+apply (safe)
+apply (unfold BufAC_Asm_F_def)
+apply (safe)
+apply (erule contrapos_np)
+apply (drule fstream_exhaust_eq [THEN iffD1])
+apply (clarsimp)
+apply (drule (1) fstream_lub_lemma)
+apply (clarify)
+apply (erule_tac x="j" in all_dupE)
+apply (simp)
+apply (drule BufAC_Asm_d2)
+apply (clarify)
+apply (simp)
+apply (rule disjCI)
+apply (erule contrapos_np)
+apply (drule fstream_exhaust_eq [THEN iffD1])
+apply (clarsimp)
+apply (drule (1) fstream_lub_lemma)
+apply (clarsimp)
+apply (tactic "simp_tac (HOL_basic_ss addsimps (ex_simps@all_simps RL[sym])) 1")
+apply (rule_tac x="Xa" in exI)
+apply (rule allI)
+apply (rotate_tac -1)
+apply (erule_tac x="i" in allE)
+apply (clarsimp)
+apply (erule_tac x="jb" in allE)
+apply (clarsimp)
+apply (erule_tac x="jc" in allE)
+apply (clarsimp dest!: BufAC_Asm_d3)
+done
+
+lemma adm_non_BufAC_Asm': "adm (\<lambda>u. u \<notin> BufAC_Asm)" (* uses antitonP *)
+apply (rule def_gfp_adm_nonP)
+apply (rule BufAC_Asm_def [THEN eq_reflection])
+apply (unfold BufAC_Asm_F_def)
+apply (safe)
+apply (erule contrapos_np)
+apply (drule fstream_exhaust_eq [THEN iffD1])
+apply (clarsimp)
+apply (frule fstream_prefix)
+apply (clarsimp)
+apply (frule BufAC_Asm_d2)
+apply (clarsimp)
+apply (rotate_tac -1)
+apply (erule contrapos_pp)
+apply (drule fstream_exhaust_eq [THEN iffD1])
+apply (clarsimp)
+apply (frule fstream_prefix)
+apply (clarsimp)
+apply (frule BufAC_Asm_d3)
+apply (force)
+done
+
+lemma adm_BufAC': "f \<in> BufEq \<Longrightarrow> adm (\<lambda>u. u \<in> BufAC_Asm \<longrightarrow> (u, f\<cdot>u) \<in> BufAC_Cmt)"
+apply (rule triv_admI)
+apply (clarify)
+apply (erule (1) Buf_Eq_imp_AC_lemma)
+      (* this is what we originally aimed to show, using admissibilty :-( *)
+done
+
+end
+
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/FOCUS.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,29 @@
+(*  Title:      HOLCF/FOCUS/FOCUS.thy
+    Author:     David von Oheimb, TU Muenchen
+*)
+
+header {* Top level of FOCUS *}
+
+theory FOCUS
+imports Fstream
+begin
+
+lemma ex_eqI [intro!]: "? xx. x = xx"
+by auto
+
+lemma ex2_eqI [intro!]: "? xx yy. x = xx & y = yy"
+by auto
+
+lemma eq_UU_symf: "(UU = f x) = (f x = UU)"
+by auto
+
+lemma fstream_exhaust_slen_eq: "(#x ~= 0) = (? a y. x = a~> y)"
+by (simp add: slen_empty_eq fstream_exhaust_eq)
+
+lemmas [simp] =
+  slen_less_1_eq fstream_exhaust_slen_eq
+  slen_fscons_eq slen_fscons_less_eq Suc_ile_eq
+
+declare strictI [elim]
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/Fstream.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,263 @@
+(*  Title:      HOLCF/FOCUS/Fstream.thy
+    Author:     David von Oheimb, TU Muenchen
+
+FOCUS streams (with lifted elements).
+
+TODO: integrate Fstreams.thy
+*)
+
+header {* FOCUS flat streams *}
+
+theory Fstream
+imports Stream
+begin
+
+default_sort type
+
+types 'a fstream = "'a lift stream"
+
+definition
+  fscons        :: "'a     \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
+  "fscons a = (\<Lambda> s. Def a && s)"
+
+definition
+  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
+  "fsfilter A = (sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A)))"
+
+abbreviation
+  emptystream   :: "'a fstream"                          ("<>") where
+  "<> == \<bottom>"
+
+abbreviation
+  fscons'       :: "'a \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_~>_)"    [66,65] 65) where
+  "a~>s == fscons a\<cdot>s"
+
+abbreviation
+  fsfilter'     :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"   ("(_'(C')_)" [64,63] 63) where
+  "A(C)s == fsfilter A\<cdot>s"
+
+notation (xsymbols)
+  fscons'  ("(_\<leadsto>_)"                                                 [66,65] 65) and
+  fsfilter'  ("(_\<copyright>_)"                                               [64,63] 63)
+
+
+lemma Def_maximal: "a = Def d \<Longrightarrow> a\<sqsubseteq>b \<Longrightarrow> b = Def d"
+by simp
+
+
+section "fscons"
+
+lemma fscons_def2: "a~>s = Def a && s"
+apply (unfold fscons_def)
+apply (simp)
+done
+
+lemma fstream_exhaust: "x = UU |  (? a y. x = a~> y)"
+apply (simp add: fscons_def2)
+apply (cut_tac stream.nchotomy)
+apply (fast dest: not_Undef_is_Def [THEN iffD1])
+done
+
+lemma fstream_cases: "[| x = UU ==> P; !!a y. x = a~> y ==> P |] ==> P"
+apply (cut_tac fstream_exhaust)
+apply (erule disjE)
+apply fast
+apply fast
+done
+
+lemma fstream_exhaust_eq: "(x ~= UU) = (? a y. x = a~> y)"
+apply (simp add: fscons_def2 stream_exhaust_eq)
+apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
+done
+
+
+lemma fscons_not_empty [simp]: "a~> s ~= <>"
+by (simp add: fscons_def2)
+
+
+lemma fscons_inject [simp]: "(a~> s = b~> t) = (a = b &  s = t)"
+by (simp add: fscons_def2)
+
+lemma fstream_prefix: "a~> s << t ==> ? tt. t = a~> tt &  s << tt"
+apply (cases t)
+apply (cut_tac fscons_not_empty)
+apply (fast dest: eq_UU_iff [THEN iffD2])
+apply (simp add: fscons_def2)
+done
+
+lemma fstream_prefix' [simp]:
+        "x << a~> z = (x = <> |  (? y. x = a~> y &  y << z))"
+apply (simp add: fscons_def2 Def_not_UU [THEN stream_prefix'])
+apply (safe)
+apply (erule_tac [!] contrapos_np)
+prefer 2 apply (fast elim: DefE)
+apply (rule lift.exhaust)
+apply (erule (1) notE)
+apply (safe)
+apply (drule Def_below_Def [THEN iffD1])
+apply fast
+done
+
+(* ------------------------------------------------------------------------- *)
+
+section "ft & rt"
+
+lemmas ft_empty = stream.sel_rews (1)
+lemma ft_fscons [simp]: "ft\<cdot>(m~> s) = Def m"
+by (simp add: fscons_def)
+
+lemmas rt_empty = stream.sel_rews (2)
+lemma rt_fscons [simp]: "rt\<cdot>(m~> s) = s"
+by (simp add: fscons_def)
+
+lemma ft_eq [simp]: "(ft\<cdot>s = Def a) = (? t. s = a~> t)"
+apply (unfold fscons_def)
+apply (simp)
+apply (safe)
+apply (erule subst)
+apply (rule exI)
+apply (rule surjectiv_scons [symmetric])
+apply (simp)
+done
+
+lemma surjective_fscons_lemma: "(d\<leadsto>y = x) = (ft\<cdot>x = Def d & rt\<cdot>x = y)"
+by auto
+
+lemma surjective_fscons: "ft\<cdot>x = Def d \<Longrightarrow> d\<leadsto>rt\<cdot>x = x"
+by (simp add: surjective_fscons_lemma)
+
+
+(* ------------------------------------------------------------------------- *)
+
+section "take"
+
+lemma fstream_take_Suc [simp]:
+        "stream_take (Suc n)\<cdot>(a~> s) = a~> stream_take n\<cdot>s"
+by (simp add: fscons_def)
+
+
+(* ------------------------------------------------------------------------- *)
+
+section "slen"
+
+lemma slen_fscons: "#(m~> s) = iSuc (#s)"
+by (simp add: fscons_def)
+
+lemma slen_fscons_eq:
+        "(Fin (Suc n) < #x) = (? a y. x = a~> y & Fin n < #y)"
+apply (simp add: fscons_def2 slen_scons_eq)
+apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
+done
+
+lemma slen_fscons_eq_rev:
+        "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a~> y | #y < Fin (Suc n))"
+apply (simp add: fscons_def2 slen_scons_eq_rev)
+apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
+apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
+apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
+apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
+apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
+apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
+apply (erule contrapos_np)
+apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
+done
+
+lemma slen_fscons_less_eq:
+        "(#(a~> y) < Fin (Suc (Suc n))) = (#y < Fin (Suc n))"
+apply (subst slen_fscons_eq_rev)
+apply (fast dest!: fscons_inject [THEN iffD1])
+done
+
+
+(* ------------------------------------------------------------------------- *)
+
+section "induction"
+
+lemma fstream_ind:
+        "[| adm P; P <>; !!a s. P s ==> P (a~> s) |] ==> P x"
+apply (erule stream.induct)
+apply (assumption)
+apply (unfold fscons_def2)
+apply (fast dest: not_Undef_is_Def [THEN iffD1])
+done
+
+lemma fstream_ind2:
+  "[| adm P; P UU; !!a. P (a~> UU); !!a b s. P s ==> P (a~> b~> s) |] ==> P x"
+apply (erule stream_ind2)
+apply (assumption)
+apply (unfold fscons_def2)
+apply (fast dest: not_Undef_is_Def [THEN iffD1])
+apply (fast dest: not_Undef_is_Def [THEN iffD1])
+done
+
+
+(* ------------------------------------------------------------------------- *)
+
+section "fsfilter"
+
+lemma fsfilter_empty: "A(C)UU = UU"
+apply (unfold fsfilter_def)
+apply (rule sfilter_empty)
+done
+
+lemma fsfilter_fscons:
+        "A(C)x~> xs = (if x:A then x~> (A(C)xs) else A(C)xs)"
+apply (unfold fsfilter_def)
+apply (simp add: fscons_def2 If_and_if)
+done
+
+lemma fsfilter_emptys: "{}(C)x = UU"
+apply (rule_tac x="x" in fstream_ind)
+apply (simp)
+apply (rule fsfilter_empty)
+apply (simp add: fsfilter_fscons)
+done
+
+lemma fsfilter_insert: "(insert a A)(C)a~> x = a~> ((insert a A)(C)x)"
+by (simp add: fsfilter_fscons)
+
+lemma fsfilter_single_in: "{a}(C)a~> x = a~> ({a}(C)x)"
+by (rule fsfilter_insert)
+
+lemma fsfilter_single_out: "b ~= a ==> {a}(C)b~> x = ({a}(C)x)"
+by (simp add: fsfilter_fscons)
+
+lemma fstream_lub_lemma1:
+    "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = a\<leadsto>t"
+apply (case_tac "max_in_chain i Y")
+apply  (drule (1) lub_finch1 [THEN lub_eqI, THEN sym])
+apply  (force)
+apply (unfold max_in_chain_def)
+apply auto
+apply (frule (1) chain_mono)
+apply (rule_tac x="Y j" in fstream_cases)
+apply  (force)
+apply (drule_tac x="j" in is_ub_thelub)
+apply (force)
+done
+
+lemma fstream_lub_lemma:
+      "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> (\<exists>j t. Y j = a\<leadsto>t) & (\<exists>X. chain X & (!i. ? j. Y j = a\<leadsto>X i) & (\<Squnion>i. X i) = s)"
+apply (frule (1) fstream_lub_lemma1)
+apply (clarsimp)
+apply (rule_tac x="%i. rt\<cdot>(Y(i+j))" in exI)
+apply (rule conjI)
+apply  (erule chain_shift [THEN chain_monofun])
+apply safe
+apply  (drule_tac i="j" and j="i+j" in chain_mono)
+apply   (simp)
+apply  (simp)
+apply  (rule_tac x="i+j" in exI)
+apply  (drule fstream_prefix)
+apply  (clarsimp)
+apply  (subst contlub_cfun [symmetric])
+apply   (rule chainI)
+apply   (fast)
+apply  (erule chain_shift)
+apply (subst lub_const)
+apply (subst lub_range_shift)
+apply  (assumption)
+apply (simp)
+done
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/Fstreams.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,331 @@
+(*  Title:      HOLCF/FOCUS/Fstreams.thy
+    Author:     Borislav Gajanovic
+
+FOCUS flat streams (with lifted elements).
+
+TODO: integrate this with Fstream.
+*)
+
+theory Fstreams
+imports Stream
+begin
+
+default_sort type
+
+types 'a fstream = "('a lift) stream"
+
+definition
+  fsingleton    :: "'a => 'a fstream"  ("<_>" [1000] 999) where
+  fsingleton_def2: "fsingleton = (%a. Def a && UU)"
+
+definition
+  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
+  "fsfilter A = sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A))"
+
+definition
+  fsmap         :: "('a => 'b) => 'a fstream -> 'b fstream" where
+  "fsmap f = smap$(flift2 f)"
+
+definition
+  jth           :: "nat => 'a fstream => 'a" where
+  "jth = (%n s. if Fin n < #s then THE a. i_th n s = Def a else undefined)"
+
+definition
+  first         :: "'a fstream => 'a" where
+  "first = (%s. jth 0 s)"
+
+definition
+  last          :: "'a fstream => 'a" where
+  "last = (%s. case #s of Fin n => (if n~=0 then jth (THE k. Suc k = n) s else undefined))"
+
+
+abbreviation
+  emptystream :: "'a fstream"  ("<>") where
+  "<> == \<bottom>"
+
+abbreviation
+  fsfilter' :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_'(C')_)" [64,63] 63) where
+  "A(C)s == fsfilter A\<cdot>s"
+
+notation (xsymbols)
+  fsfilter'  ("(_\<copyright>_)" [64,63] 63)
+
+
+lemma ft_fsingleton[simp]: "ft$(<a>) = Def a"
+by (simp add: fsingleton_def2)
+
+lemma slen_fsingleton[simp]: "#(<a>) = Fin 1"
+by (simp add: fsingleton_def2 inat_defs)
+
+lemma slen_fstreams[simp]: "#(<a> ooo s) = iSuc (#s)"
+by (simp add: fsingleton_def2)
+
+lemma slen_fstreams2[simp]: "#(s ooo <a>) = iSuc (#s)"
+apply (cases "#s")
+apply (auto simp add: iSuc_Fin)
+apply (insert slen_sconc [of _ s "Suc 0" "<a>"], auto)
+by (simp add: sconc_def)
+
+lemma j_th_0_fsingleton[simp]:"jth 0 (<a>) = a"
+apply (simp add: fsingleton_def2 jth_def)
+by (simp add: i_th_def Fin_0)
+
+lemma jth_0[simp]: "jth 0 (<a> ooo s) = a"  
+apply (simp add: fsingleton_def2 jth_def)
+by (simp add: i_th_def Fin_0)
+
+lemma first_sconc[simp]: "first (<a> ooo s) = a"
+by (simp add: first_def)
+
+lemma first_fsingleton[simp]: "first (<a>) = a"
+by (simp add: first_def)
+
+lemma jth_n[simp]: "Fin n = #s ==> jth n (s ooo <a>) = a"
+apply (simp add: jth_def, auto)
+apply (simp add: i_th_def rt_sconc1)
+by (simp add: inat_defs split: inat_splits)
+
+lemma last_sconc[simp]: "Fin n = #s ==> last (s ooo <a>) = a"
+apply (simp add: last_def)
+apply (simp add: inat_defs split:inat_splits)
+by (drule sym, auto)
+
+lemma last_fsingleton[simp]: "last (<a>) = a"
+by (simp add: last_def)
+
+lemma first_UU[simp]: "first UU = undefined"
+by (simp add: first_def jth_def)
+
+lemma last_UU[simp]:"last UU = undefined"
+by (simp add: last_def jth_def inat_defs)
+
+lemma last_infinite[simp]:"#s = Infty ==> last s = undefined"
+by (simp add: last_def)
+
+lemma jth_slen_lemma1:"n <= k & Fin n = #s ==> jth k s = undefined"
+by (simp add: jth_def inat_defs split:inat_splits, auto)
+
+lemma jth_UU[simp]:"jth n UU = undefined" 
+by (simp add: jth_def)
+
+lemma ext_last:"[|s ~= UU; Fin (Suc n) = #s|] ==> (stream_take n$s) ooo <(last s)> = s" 
+apply (simp add: last_def)
+apply (case_tac "#s", auto)
+apply (simp add: fsingleton_def2)
+apply (subgoal_tac "Def (jth n s) = i_th n s")
+apply (auto simp add: i_th_last)
+apply (drule slen_take_lemma1, auto)
+apply (simp add: jth_def)
+apply (case_tac "i_th n s = UU")
+apply auto
+apply (simp add: i_th_def)
+apply (case_tac "i_rt n s = UU", auto)
+apply (drule i_rt_slen [THEN iffD1])
+apply (drule slen_take_eq_rev [rule_format, THEN iffD2],auto)
+by (drule not_Undef_is_Def [THEN iffD1], auto)
+
+
+lemma fsingleton_lemma1[simp]: "(<a> = <b>) = (a=b)"
+by (simp add: fsingleton_def2)
+
+lemma fsingleton_lemma2[simp]: "<a> ~= <>"
+by (simp add: fsingleton_def2)
+
+lemma fsingleton_sconc:"<a> ooo s = Def a && s"
+by (simp add: fsingleton_def2)
+
+lemma fstreams_ind: 
+  "[| adm P; P <>; !!a s. P s ==> P (<a> ooo s) |] ==> P x"
+apply (simp add: fsingleton_def2)
+apply (rule stream.induct, auto)
+by (drule not_Undef_is_Def [THEN iffD1], auto)
+
+lemma fstreams_ind2:
+  "[| adm P; P <>; !!a. P (<a>); !!a b s. P s ==> P (<a> ooo <b> ooo s) |] ==> P x"
+apply (simp add: fsingleton_def2)
+apply (rule stream_ind2, auto)
+by (drule not_Undef_is_Def [THEN iffD1], auto)+
+
+lemma fstreams_take_Suc[simp]: "stream_take (Suc n)$(<a> ooo s) = <a> ooo stream_take n$s"
+by (simp add: fsingleton_def2)
+
+lemma fstreams_not_empty[simp]: "<a> ooo s ~= <>"
+by (simp add: fsingleton_def2)
+
+lemma fstreams_not_empty2[simp]: "s ooo <a> ~= <>"
+by (case_tac "s=UU", auto)
+
+lemma fstreams_exhaust: "x = UU | (EX a s. x = <a> ooo s)"
+apply (simp add: fsingleton_def2, auto)
+apply (erule contrapos_pp, auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+by (drule not_Undef_is_Def [THEN iffD1], auto)
+
+lemma fstreams_cases: "[| x = UU ==> P; !!a y. x = <a> ooo y ==> P |] ==> P"
+by (insert fstreams_exhaust [of x], auto)
+
+lemma fstreams_exhaust_eq: "(x ~= UU) = (? a y. x = <a> ooo y)"
+apply (simp add: fsingleton_def2, auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+by (drule not_Undef_is_Def [THEN iffD1], auto)
+
+lemma fstreams_inject: "(<a> ooo s = <b> ooo t) = (a=b & s=t)"
+by (simp add: fsingleton_def2)
+
+lemma fstreams_prefix: "<a> ooo s << t ==> EX tt. t = <a> ooo tt &  s << tt"
+apply (simp add: fsingleton_def2)
+apply (insert stream_prefix [of "Def a" s t], auto)
+done
+
+lemma fstreams_prefix': "x << <a> ooo z = (x = <> |  (EX y. x = <a> ooo y &  y << z))"
+apply (auto, case_tac "x=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (simp add: fsingleton_def2, auto)
+apply (drule ax_flat, simp)
+by (erule sconc_mono)
+
+lemma ft_fstreams[simp]: "ft$(<a> ooo s) = Def a"
+by (simp add: fsingleton_def2)
+
+lemma rt_fstreams[simp]: "rt$(<a> ooo s) = s"
+by (simp add: fsingleton_def2)
+
+lemma ft_eq[simp]: "(ft$s = Def a) = (EX t. s = <a> ooo t)"
+apply (cases s, auto)
+by ((*drule sym,*) auto simp add: fsingleton_def2)
+
+lemma surjective_fstreams: "(<d> ooo y = x) = (ft$x = Def d & rt$x = y)"
+by auto
+
+lemma fstreams_mono: "<a> ooo b << <a> ooo c ==> b << c"
+by (simp add: fsingleton_def2)
+
+lemma fsmap_UU[simp]: "fsmap f$UU = UU"
+by (simp add: fsmap_def)
+
+lemma fsmap_fsingleton_sconc: "fsmap f$(<x> ooo xs) = <(f x)> ooo (fsmap f$xs)"
+by (simp add: fsmap_def fsingleton_def2 flift2_def)
+
+lemma fsmap_fsingleton[simp]: "fsmap f$(<x>) = <(f x)>"
+by (simp add: fsmap_def fsingleton_def2 flift2_def)
+
+
+lemma fstreams_chain_lemma[rule_format]:
+  "ALL s x y. stream_take n$(s::'a fstream) << x & x << y & y << s & x ~= y --> stream_take (Suc n)$s << y"
+apply (induct_tac n, auto)
+apply (case_tac "s=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (case_tac "y=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (simp add: flat_below_iff)
+apply (case_tac "s=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (erule_tac x="ya" in allE)
+apply (drule stream_prefix, auto)
+apply (case_tac "y=UU",auto)
+apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
+apply auto
+apply (simp add: flat_below_iff)
+apply (erule_tac x="tt" in allE)
+apply (erule_tac x="yb" in allE, auto)
+apply (simp add: flat_below_iff)
+by (simp add: flat_below_iff)
+
+lemma fstreams_lub_lemma1: "[| chain Y; (LUB i. Y i) = <a> ooo s |] ==> EX j t. Y j = <a> ooo t"
+apply (subgoal_tac "(LUB i. Y i) ~= UU")
+apply (drule chain_UU_I_inverse2, auto)
+apply (drule_tac x="i" in is_ub_thelub, auto)
+by (drule fstreams_prefix' [THEN iffD1], auto)
+
+lemma fstreams_lub1: 
+ "[| chain Y; (LUB i. Y i) = <a> ooo s |]
+     ==> (EX j t. Y j = <a> ooo t) & (EX X. chain X & (ALL i. EX j. <a> ooo X i << Y j) & (LUB i. X i) = s)"
+apply (auto simp add: fstreams_lub_lemma1)
+apply (rule_tac x="%n. stream_take n$s" in exI, auto)
+apply (induct_tac i, auto)
+apply (drule fstreams_lub_lemma1, auto)
+apply (rule_tac x="j" in exI, auto)
+apply (case_tac "max_in_chain j Y")
+apply (frule lub_finch1 [THEN lub_eqI], auto)
+apply (rule_tac x="j" in exI)
+apply (erule subst) back back
+apply (simp add: below_prod_def sconc_mono)
+apply (simp add: max_in_chain_def, auto)
+apply (rule_tac x="ja" in exI)
+apply (subgoal_tac "Y j << Y ja")
+apply (drule fstreams_prefix, auto)+
+apply (rule sconc_mono)
+apply (rule fstreams_chain_lemma, auto)
+apply (subgoal_tac "Y ja << (LUB i. (Y i))", clarsimp)
+apply (drule fstreams_mono, simp)
+apply (rule is_ub_thelub, simp)
+apply (blast intro: chain_mono)
+by (rule stream_reach2)
+
+
+lemma lub_Pair_not_UU_lemma: 
+  "[| chain Y; (LUB i. Y i) = ((a::'a::flat), b); a ~= UU; b ~= UU |] 
+      ==> EX j c d. Y j = (c, d) & c ~= UU & d ~= UU"
+apply (frule lub_prod, clarsimp)
+apply (drule chain_UU_I_inverse2, clarsimp)
+apply (case_tac "Y i", clarsimp)
+apply (case_tac "max_in_chain i Y")
+apply (drule maxinch_is_thelub, auto)
+apply (rule_tac x="i" in exI, auto)
+apply (simp add: max_in_chain_def, auto)
+apply (subgoal_tac "Y i << Y j",auto)
+apply (simp add: below_prod_def, clarsimp)
+apply (drule ax_flat, auto)
+apply (case_tac "snd (Y j) = UU",auto)
+apply (case_tac "Y j", auto)
+apply (rule_tac x="j" in exI)
+apply (case_tac "Y j",auto)
+by (drule chain_mono, auto)
+
+lemma fstreams_lub_lemma2: 
+  "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |] ==> EX j t. Y j = (a, <m> ooo t)"
+apply (frule lub_Pair_not_UU_lemma, auto)
+apply (drule_tac x="j" in is_ub_thelub, auto)
+apply (drule ax_flat, clarsimp)
+by (drule fstreams_prefix' [THEN iffD1], auto)
+
+lemma fstreams_lub2:
+  "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |] 
+      ==> (EX j t. Y j = (a, <m> ooo t)) & (EX X. chain X & (ALL i. EX j. (a, <m> ooo X i) << Y j) & (LUB i. X i) = ms)"
+apply (auto simp add: fstreams_lub_lemma2)
+apply (rule_tac x="%n. stream_take n$ms" in exI, auto)
+apply (induct_tac i, auto)
+apply (drule fstreams_lub_lemma2, auto)
+apply (rule_tac x="j" in exI, auto)
+apply (case_tac "max_in_chain j Y")
+apply (frule lub_finch1 [THEN lub_eqI], auto)
+apply (rule_tac x="j" in exI)
+apply (erule subst) back back
+apply (simp add: sconc_mono)
+apply (simp add: max_in_chain_def, auto)
+apply (rule_tac x="ja" in exI)
+apply (subgoal_tac "Y j << Y ja")
+apply (simp add: below_prod_def, auto)
+apply (drule below_trans)
+apply (simp add: ax_flat, auto)
+apply (drule fstreams_prefix, auto)+
+apply (rule sconc_mono)
+apply (subgoal_tac "tt ~= tta" "tta << ms")
+apply (blast intro: fstreams_chain_lemma)
+apply (frule lub_prod, auto)
+apply (subgoal_tac "snd (Y ja) << (LUB i. snd (Y i))", clarsimp)
+apply (drule fstreams_mono, simp)
+apply (rule is_ub_thelub chainI)
+apply (simp add: chain_def below_prod_def)
+apply (subgoal_tac "fst (Y j) ~= fst (Y ja) | snd (Y j) ~= snd (Y ja)", simp)
+apply (drule ax_flat, simp)+
+apply (drule prod_eqI, auto)
+apply (simp add: chain_mono)
+by (rule stream_reach2)
+
+
+lemma cpo_cont_lemma:
+  "[| monofun (f::'a::cpo => 'b::cpo); (!Y. chain Y --> f (lub(range Y)) << (LUB i. f (Y i))) |] ==> cont f"
+by (erule contI2, simp)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/README.html	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,22 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+
+<HTML>
+
+<HEAD>
+  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+  <TITLE>HOLCF/README</TITLE>
+</HEAD>
+
+<BODY>
+
+<H3>FOCUS: a theory of stream-processing functions Isabelle/<A HREF="..">HOLCF</A></H3>
+
+For introductions to FOCUSs, see 
+<UL>
+<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=2">The Design of Distributed Systems - An Introduction to FOCUS</A>
+<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=15">Specification and Refinement of a Buffer of Length One</A>
+<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=321">Specification and Development of Interactive Systems: Focus on Streams, Interfaces, and Refinement</A>
+</UL>
+For slides on <A HREF="Buffer.html">Buffer.thy</A>, see <A HREF="http://isabelle.in.tum.de/HOLCF/1-Buffer.ps.gz">Coinduction beats induction on streams</A>.
+
+</BODY></HTML>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,1 @@
+use_thys ["Fstreams", "FOCUS", "Buffer_adm"];
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/FOCUS/Stream_adm.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,225 @@
+(*  Title:      HOLCF/ex/Stream_adm.thy
+    Author:     David von Oheimb, TU Muenchen
+*)
+
+header {* Admissibility for streams *}
+
+theory Stream_adm
+imports Stream Continuity
+begin
+
+definition
+  stream_monoP  :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
+  "stream_monoP F = (\<exists>Q i. \<forall>P s. Fin i \<le> #s \<longrightarrow>
+                    (s \<in> F P) = (stream_take i\<cdot>s \<in> Q \<and> iterate i\<cdot>rt\<cdot>s \<in> P))"
+
+definition
+  stream_antiP  :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
+  "stream_antiP F = (\<forall>P x. \<exists>Q i.
+                (#x  < Fin i \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow> y \<in> F P \<longrightarrow> x \<in> F P)) \<and>
+                (Fin i <= #x \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow>
+                (y \<in> F P) = (stream_take i\<cdot>y \<in> Q \<and> iterate i\<cdot>rt\<cdot>y \<in> P))))"
+
+definition
+  antitonP :: "'a set => bool" where
+  "antitonP P = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> y\<in>P \<longrightarrow> x\<in>P)"
+
+
+(* ----------------------------------------------------------------------- *)
+
+section "admissibility"
+
+lemma infinite_chain_adm_lemma:
+  "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i);  
+    \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
+      \<Longrightarrow> P (\<Squnion>i. Y i)"
+apply (case_tac "finite_chain Y")
+prefer 2 apply fast
+apply (unfold finite_chain_def)
+apply safe
+apply (erule lub_finch1 [THEN lub_eqI, THEN ssubst])
+apply assumption
+apply (erule spec)
+done
+
+lemma increasing_chain_adm_lemma:
+  "\<lbrakk>Porder.chain Y;  \<forall>i. P (Y i); \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
+    \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
+      \<Longrightarrow> P (\<Squnion>i. Y i)"
+apply (erule infinite_chain_adm_lemma)
+apply assumption
+apply (erule thin_rl)
+apply (unfold finite_chain_def)
+apply (unfold max_in_chain_def)
+apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
+done
+
+lemma flatstream_adm_lemma:
+  assumes 1: "Porder.chain Y"
+  assumes 2: "!i. P (Y i)"
+  assumes 3: "(!!Y. [| Porder.chain Y; !i. P (Y i); !k. ? j. Fin k < #((Y j)::'a::flat stream)|]
+  ==> P(LUB i. Y i))"
+  shows "P(LUB i. Y i)"
+apply (rule increasing_chain_adm_lemma [of _ P, OF 1 2])
+apply (erule 3, assumption)
+apply (erule thin_rl)
+apply (rule allI)
+apply (case_tac "!j. stream_finite (Y j)")
+apply ( rule chain_incr)
+apply ( rule allI)
+apply ( drule spec)
+apply ( safe)
+apply ( rule exI)
+apply ( rule slen_strict_mono)
+apply (   erule spec)
+apply (  assumption)
+apply ( assumption)
+apply (metis inat_ord_code(4) slen_infinite)
+done
+
+(* should be without reference to stream length? *)
+lemma flatstream_admI: "[|(!!Y. [| Porder.chain Y; !i. P (Y i); 
+ !k. ? j. Fin k < #((Y j)::'a::flat stream)|] ==> P(LUB i. Y i))|]==> adm P"
+apply (unfold adm_def)
+apply (intro strip)
+apply (erule (1) flatstream_adm_lemma)
+apply (fast)
+done
+
+
+(* context (theory "Nat_InFinity");*)
+lemma ile_lemma: "Fin (i + j) <= x ==> Fin i <= x"
+  by (rule order_trans) auto
+
+lemma stream_monoP2I:
+"!!X. stream_monoP F ==> !i. ? l. !x y. 
+  Fin l <= #x --> (x::'a::flat stream) << y --> x:down_iterate F i --> y:down_iterate F i"
+apply (unfold stream_monoP_def)
+apply (safe)
+apply (rule_tac x="i*ia" in exI)
+apply (induct_tac "ia")
+apply ( simp)
+apply (simp)
+apply (intro strip)
+apply (erule allE, erule all_dupE, drule mp, erule ile_lemma)
+apply (drule_tac P="%x. x" in subst, assumption)
+apply (erule allE, drule mp, rule ile_lemma) back
+apply ( erule order_trans)
+apply ( erule slen_mono)
+apply (erule ssubst)
+apply (safe)
+apply ( erule (2) ile_lemma [THEN slen_take_lemma3, THEN subst])
+apply (erule allE)
+apply (drule mp)
+apply ( erule slen_rt_mult)
+apply (erule allE)
+apply (drule mp)
+apply (erule monofun_rt_mult)
+apply (drule (1) mp)
+apply (assumption)
+done
+
+lemma stream_monoP2_gfp_admI: "[| !i. ? l. !x y. 
+ Fin l <= #x --> (x::'a::flat stream) << y --> x:down_iterate F i --> y:down_iterate F i;
+    down_cont F |] ==> adm (%x. x:gfp F)"
+apply (erule INTER_down_iterate_is_gfp [THEN ssubst]) (* cont *)
+apply (simp (no_asm))
+apply (rule adm_lemmas)
+apply (rule flatstream_admI)
+apply (erule allE)
+apply (erule exE)
+apply (erule allE, erule exE)
+apply (erule allE, erule allE, drule mp) (* stream_monoP *)
+apply ( drule ileI1)
+apply ( drule order_trans)
+apply (  rule ile_iSuc)
+apply ( drule iSuc_ile_mono [THEN iffD1])
+apply ( assumption)
+apply (drule mp)
+apply ( erule is_ub_thelub)
+apply (fast)
+done
+
+lemmas fstream_gfp_admI = stream_monoP2I [THEN stream_monoP2_gfp_admI]
+
+lemma stream_antiP2I:
+"!!X. [|stream_antiP (F::(('a::flat stream)set => ('a stream set)))|]
+  ==> !i x y. x << y --> y:down_iterate F i --> x:down_iterate F i"
+apply (unfold stream_antiP_def)
+apply (rule allI)
+apply (induct_tac "i")
+apply ( simp)
+apply (simp)
+apply (intro strip)
+apply (erule allE, erule all_dupE, erule exE, erule exE)
+apply (erule conjE)
+apply (case_tac "#x < Fin i")
+apply ( fast)
+apply (unfold linorder_not_less)
+apply (drule (1) mp)
+apply (erule all_dupE, drule mp, rule below_refl)
+apply (erule ssubst)
+apply (erule allE, drule (1) mp)
+apply (drule_tac P="%x. x" in subst, assumption)
+apply (erule conjE, rule conjI)
+apply ( erule slen_take_lemma3 [THEN ssubst], assumption)
+apply ( assumption)
+apply (erule allE, erule allE, drule mp, erule monofun_rt_mult)
+apply (drule (1) mp)
+apply (assumption)
+done
+
+lemma stream_antiP2_non_gfp_admI:
+"!!X. [|!i x y. x << y --> y:down_iterate F i --> x:down_iterate F i; down_cont F |] 
+  ==> adm (%u. ~ u:gfp F)"
+apply (unfold adm_def)
+apply (simp add: INTER_down_iterate_is_gfp)
+apply (fast dest!: is_ub_thelub)
+done
+
+lemmas fstream_non_gfp_admI = stream_antiP2I [THEN stream_antiP2_non_gfp_admI]
+
+
+
+(**new approach for adm********************************************************)
+
+section "antitonP"
+
+lemma antitonPD: "[| antitonP P; y:P; x<<y |] ==> x:P"
+apply (unfold antitonP_def)
+apply auto
+done
+
+lemma antitonPI: "!x y. y:P --> x<<y --> x:P ==> antitonP P"
+apply (unfold antitonP_def)
+apply (fast)
+done
+
+lemma antitonP_adm_non_P: "antitonP P ==> adm (%u. u~:P)"
+apply (unfold adm_def)
+apply (auto dest: antitonPD elim: is_ub_thelub)
+done
+
+lemma def_gfp_adm_nonP: "P \<equiv> gfp F \<Longrightarrow> {y. \<exists>x::'a::pcpo. y \<sqsubseteq> x \<and> x \<in> P} \<subseteq> F {y. \<exists>x. y \<sqsubseteq> x \<and> x \<in> P} \<Longrightarrow> 
+  adm (\<lambda>u. u\<notin>P)"
+apply (simp)
+apply (rule antitonP_adm_non_P)
+apply (rule antitonPI)
+apply (drule gfp_upperbound)
+apply (fast)
+done
+
+lemma adm_set:
+"{\<Squnion>i. Y i |Y. Porder.chain Y & (\<forall>i. Y i \<in> P)} \<subseteq> P \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
+apply (unfold adm_def)
+apply (fast)
+done
+
+lemma def_gfp_admI: "P \<equiv> gfp F \<Longrightarrow> {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<subseteq> 
+  F {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
+apply (simp)
+apply (rule adm_set)
+apply (erule gfp_upperbound)
+done
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Fix.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,229 @@
+(*  Title:      HOLCF/Fix.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* Fixed point operator and admissibility *}
+
+theory Fix
+imports Cfun
+begin
+
+default_sort pcpo
+
+subsection {* Iteration *}
+
+primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)" where
+    "iterate 0 = (\<Lambda> F x. x)"
+  | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"
+
+text {* Derive inductive properties of iterate from primitive recursion *}
+
+lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
+by simp
+
+lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
+by simp
+
+declare iterate.simps [simp del]
+
+lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
+by (induct n) simp_all
+
+lemma iterate_iterate:
+  "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
+by (induct m) simp_all
+
+text {* The sequence of function iterations is a chain. *}
+
+lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
+by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)
+
+
+subsection {* Least fixed point operator *}
+
+definition
+  "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a" where
+  "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
+
+text {* Binder syntax for @{term fix} *}
+
+abbreviation
+  fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"  (binder "FIX " 10) where
+  "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"
+
+notation (xsymbols)
+  fix_syn  (binder "\<mu> " 10)
+
+text {* Properties of @{term fix} *}
+
+text {* direct connection between @{term fix} and iteration *}
+
+lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
+unfolding fix_def by simp
+
+lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
+  unfolding fix_def2
+  using chain_iterate by (rule is_ub_thelub)
+
+text {*
+  Kleene's fixed point theorems for continuous functions in pointed
+  omega cpo's
+*}
+
+lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
+apply (simp add: fix_def2)
+apply (subst lub_range_shift [of _ 1, symmetric])
+apply (rule chain_iterate)
+apply (subst contlub_cfun_arg)
+apply (rule chain_iterate)
+apply simp
+done
+
+lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
+apply (simp add: fix_def2)
+apply (rule lub_below)
+apply (rule chain_iterate)
+apply (induct_tac i)
+apply simp
+apply simp
+apply (erule rev_below_trans)
+apply (erule monofun_cfun_arg)
+done
+
+lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
+by (rule fix_least_below, simp)
+
+lemma fix_eqI:
+  assumes fixed: "F\<cdot>x = x" and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
+  shows "fix\<cdot>F = x"
+apply (rule below_antisym)
+apply (rule fix_least [OF fixed])
+apply (rule least [OF fix_eq [symmetric]])
+done
+
+lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
+by (simp add: fix_eq [symmetric])
+
+lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
+by (erule fix_eq2 [THEN cfun_fun_cong])
+
+lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
+apply (erule ssubst)
+apply (rule fix_eq)
+done
+
+lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
+by (erule fix_eq4 [THEN cfun_fun_cong])
+
+text {* strictness of @{term fix} *}
+
+lemma fix_bottom_iff: "(fix\<cdot>F = \<bottom>) = (F\<cdot>\<bottom> = \<bottom>)"
+apply (rule iffI)
+apply (erule subst)
+apply (rule fix_eq [symmetric])
+apply (erule fix_least [THEN UU_I])
+done
+
+lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
+by (simp add: fix_bottom_iff)
+
+lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
+by (simp add: fix_bottom_iff)
+
+text {* @{term fix} applied to identity and constant functions *}
+
+lemma fix_id: "(\<mu> x. x) = \<bottom>"
+by (simp add: fix_strict)
+
+lemma fix_const: "(\<mu> x. c) = c"
+by (subst fix_eq, simp)
+
+subsection {* Fixed point induction *}
+
+lemma fix_ind: "\<lbrakk>adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (fix\<cdot>F)"
+unfolding fix_def2
+apply (erule admD)
+apply (rule chain_iterate)
+apply (rule nat_induct, simp_all)
+done
+
+lemma def_fix_ind:
+  "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
+by (simp add: fix_ind)
+
+lemma fix_ind2:
+  assumes adm: "adm P"
+  assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
+  assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
+  shows "P (fix\<cdot>F)"
+unfolding fix_def2
+apply (rule admD [OF adm chain_iterate])
+apply (rule nat_less_induct)
+apply (case_tac n)
+apply (simp add: 0)
+apply (case_tac nat)
+apply (simp add: 1)
+apply (frule_tac x=nat in spec)
+apply (simp add: step)
+done
+
+lemma parallel_fix_ind:
+  assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
+  assumes base: "P \<bottom> \<bottom>"
+  assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
+  shows "P (fix\<cdot>F) (fix\<cdot>G)"
+proof -
+  from adm have adm': "adm (split P)"
+    unfolding split_def .
+  have "\<And>i. P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)"
+    by (induct_tac i, simp add: base, simp add: step)
+  hence "\<And>i. split P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
+    by simp
+  hence "split P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
+    by - (rule admD [OF adm'], simp, assumption)
+  hence "split P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
+    by (simp add: lub_Pair)
+  hence "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
+    by simp
+  thus "P (fix\<cdot>F) (fix\<cdot>G)"
+    by (simp add: fix_def2)
+qed
+
+subsection {* Fixed-points on product types *}
+
+text {*
+  Bekic's Theorem: Simultaneous fixed points over pairs
+  can be written in terms of separate fixed points.
+*}
+
+lemma fix_cprod:
+  "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
+   (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
+    \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
+  (is "fix\<cdot>F = (?x, ?y)")
+proof (rule fix_eqI)
+  have 1: "fst (F\<cdot>(?x, ?y)) = ?x"
+    by (rule trans [symmetric, OF fix_eq], simp)
+  have 2: "snd (F\<cdot>(?x, ?y)) = ?y"
+    by (rule trans [symmetric, OF fix_eq], simp)
+  from 1 2 show "F\<cdot>(?x, ?y) = (?x, ?y)" by (simp add: Pair_fst_snd_eq)
+next
+  fix z assume F_z: "F\<cdot>z = z"
+  obtain x y where z: "z = (x,y)" by (rule prod.exhaust)
+  from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
+  from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
+  let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
+  have "?y1 \<sqsubseteq> y" by (rule fix_least, simp add: F_y)
+  hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
+    by (simp add: fst_monofun monofun_cfun)
+  hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x" using F_x by simp
+  hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_below)
+  hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
+    by (simp add: snd_monofun monofun_cfun)
+  hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> y" using F_y by simp
+  hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_below)
+  show "(?x, ?y) \<sqsubseteq> z" using z 1 2 by simp
+qed
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Fixrec.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,252 @@
+(*  Title:      HOLCF/Fixrec.thy
+    Author:     Amber Telfer and Brian Huffman
+*)
+
+header "Package for defining recursive functions in HOLCF"
+
+theory Fixrec
+imports Plain_HOLCF
+uses
+  ("Tools/holcf_library.ML")
+  ("Tools/fixrec.ML")
+begin
+
+subsection {* Pattern-match monad *}
+
+default_sort cpo
+
+pcpodef (open) 'a match = "UNIV::(one ++ 'a u) set"
+by simp_all
+
+definition
+  fail :: "'a match" where
+  "fail = Abs_match (sinl\<cdot>ONE)"
+
+definition
+  succeed :: "'a \<rightarrow> 'a match" where
+  "succeed = (\<Lambda> x. Abs_match (sinr\<cdot>(up\<cdot>x)))"
+
+lemma matchE [case_names bottom fail succeed, cases type: match]:
+  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = fail \<Longrightarrow> Q; \<And>x. p = succeed\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
+unfolding fail_def succeed_def
+apply (cases p, rename_tac r)
+apply (rule_tac p=r in ssumE, simp add: Abs_match_strict)
+apply (rule_tac p=x in oneE, simp, simp)
+apply (rule_tac p=y in upE, simp, simp add: cont_Abs_match)
+done
+
+lemma succeed_defined [simp]: "succeed\<cdot>x \<noteq> \<bottom>"
+by (simp add: succeed_def cont_Abs_match Abs_match_defined)
+
+lemma fail_defined [simp]: "fail \<noteq> \<bottom>"
+by (simp add: fail_def Abs_match_defined)
+
+lemma succeed_eq [simp]: "(succeed\<cdot>x = succeed\<cdot>y) = (x = y)"
+by (simp add: succeed_def cont_Abs_match Abs_match_inject)
+
+lemma succeed_neq_fail [simp]:
+  "succeed\<cdot>x \<noteq> fail" "fail \<noteq> succeed\<cdot>x"
+by (simp_all add: succeed_def fail_def cont_Abs_match Abs_match_inject)
+
+subsubsection {* Run operator *}
+
+definition
+  run :: "'a match \<rightarrow> 'a::pcpo" where
+  "run = (\<Lambda> m. sscase\<cdot>\<bottom>\<cdot>(fup\<cdot>ID)\<cdot>(Rep_match m))"
+
+text {* rewrite rules for run *}
+
+lemma run_strict [simp]: "run\<cdot>\<bottom> = \<bottom>"
+unfolding run_def
+by (simp add: cont_Rep_match Rep_match_strict)
+
+lemma run_fail [simp]: "run\<cdot>fail = \<bottom>"
+unfolding run_def fail_def
+by (simp add: cont_Rep_match Abs_match_inverse)
+
+lemma run_succeed [simp]: "run\<cdot>(succeed\<cdot>x) = x"
+unfolding run_def succeed_def
+by (simp add: cont_Rep_match cont_Abs_match Abs_match_inverse)
+
+subsubsection {* Monad plus operator *}
+
+definition
+  mplus :: "'a match \<rightarrow> 'a match \<rightarrow> 'a match" where
+  "mplus = (\<Lambda> m1 m2. sscase\<cdot>(\<Lambda> _. m2)\<cdot>(\<Lambda> _. m1)\<cdot>(Rep_match m1))"
+
+abbreviation
+  mplus_syn :: "['a match, 'a match] \<Rightarrow> 'a match"  (infixr "+++" 65)  where
+  "m1 +++ m2 == mplus\<cdot>m1\<cdot>m2"
+
+text {* rewrite rules for mplus *}
+
+lemmas cont2cont_Rep_match = cont_Rep_match [THEN cont_compose]
+
+lemma mplus_strict [simp]: "\<bottom> +++ m = \<bottom>"
+unfolding mplus_def
+by (simp add: cont2cont_Rep_match Rep_match_strict)
+
+lemma mplus_fail [simp]: "fail +++ m = m"
+unfolding mplus_def fail_def
+by (simp add: cont2cont_Rep_match Abs_match_inverse)
+
+lemma mplus_succeed [simp]: "succeed\<cdot>x +++ m = succeed\<cdot>x"
+unfolding mplus_def succeed_def
+by (simp add: cont2cont_Rep_match cont_Abs_match Abs_match_inverse)
+
+lemma mplus_fail2 [simp]: "m +++ fail = m"
+by (cases m, simp_all)
+
+lemma mplus_assoc: "(x +++ y) +++ z = x +++ (y +++ z)"
+by (cases x, simp_all)
+
+subsection {* Match functions for built-in types *}
+
+default_sort pcpo
+
+definition
+  match_bottom :: "'a \<rightarrow> 'c match \<rightarrow> 'c match"
+where
+  "match_bottom = (\<Lambda> x k. seq\<cdot>x\<cdot>fail)"
+
+definition
+  match_Pair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c match) \<rightarrow> 'c match"
+where
+  "match_Pair = (\<Lambda> x k. csplit\<cdot>k\<cdot>x)"
+
+definition
+  match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c match) \<rightarrow> 'c match"
+where
+  "match_spair = (\<Lambda> x k. ssplit\<cdot>k\<cdot>x)"
+
+definition
+  match_sinl :: "'a \<oplus> 'b \<rightarrow> ('a \<rightarrow> 'c match) \<rightarrow> 'c match"
+where
+  "match_sinl = (\<Lambda> x k. sscase\<cdot>k\<cdot>(\<Lambda> b. fail)\<cdot>x)"
+
+definition
+  match_sinr :: "'a \<oplus> 'b \<rightarrow> ('b \<rightarrow> 'c match) \<rightarrow> 'c match"
+where
+  "match_sinr = (\<Lambda> x k. sscase\<cdot>(\<Lambda> a. fail)\<cdot>k\<cdot>x)"
+
+definition
+  match_up :: "'a::cpo u \<rightarrow> ('a \<rightarrow> 'c match) \<rightarrow> 'c match"
+where
+  "match_up = (\<Lambda> x k. fup\<cdot>k\<cdot>x)"
+
+definition
+  match_ONE :: "one \<rightarrow> 'c match \<rightarrow> 'c match"
+where
+  "match_ONE = (\<Lambda> ONE k. k)"
+
+definition
+  match_TT :: "tr \<rightarrow> 'c match \<rightarrow> 'c match"
+where
+  "match_TT = (\<Lambda> x k. If x then k else fail)"
+ 
+definition
+  match_FF :: "tr \<rightarrow> 'c match \<rightarrow> 'c match"
+where
+  "match_FF = (\<Lambda> x k. If x then fail else k)"
+
+lemma match_bottom_simps [simp]:
+  "match_bottom\<cdot>\<bottom>\<cdot>k = \<bottom>"
+  "x \<noteq> \<bottom> \<Longrightarrow> match_bottom\<cdot>x\<cdot>k = fail"
+by (simp_all add: match_bottom_def)
+
+lemma match_Pair_simps [simp]:
+  "match_Pair\<cdot>(x, y)\<cdot>k = k\<cdot>x\<cdot>y"
+by (simp_all add: match_Pair_def)
+
+lemma match_spair_simps [simp]:
+  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x, y:)\<cdot>k = k\<cdot>x\<cdot>y"
+  "match_spair\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_spair_def)
+
+lemma match_sinl_simps [simp]:
+  "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x)\<cdot>k = k\<cdot>x"
+  "y \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>y)\<cdot>k = fail"
+  "match_sinl\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_sinl_def)
+
+lemma match_sinr_simps [simp]:
+  "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x)\<cdot>k = fail"
+  "y \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>y)\<cdot>k = k\<cdot>y"
+  "match_sinr\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_sinr_def)
+
+lemma match_up_simps [simp]:
+  "match_up\<cdot>(up\<cdot>x)\<cdot>k = k\<cdot>x"
+  "match_up\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_up_def)
+
+lemma match_ONE_simps [simp]:
+  "match_ONE\<cdot>ONE\<cdot>k = k"
+  "match_ONE\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_ONE_def)
+
+lemma match_TT_simps [simp]:
+  "match_TT\<cdot>TT\<cdot>k = k"
+  "match_TT\<cdot>FF\<cdot>k = fail"
+  "match_TT\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_TT_def)
+
+lemma match_FF_simps [simp]:
+  "match_FF\<cdot>FF\<cdot>k = k"
+  "match_FF\<cdot>TT\<cdot>k = fail"
+  "match_FF\<cdot>\<bottom>\<cdot>k = \<bottom>"
+by (simp_all add: match_FF_def)
+
+subsection {* Mutual recursion *}
+
+text {*
+  The following rules are used to prove unfolding theorems from
+  fixed-point definitions of mutually recursive functions.
+*}
+
+lemma Pair_equalI: "\<lbrakk>x \<equiv> fst p; y \<equiv> snd p\<rbrakk> \<Longrightarrow> (x, y) \<equiv> p"
+by simp
+
+lemma Pair_eqD1: "(x, y) = (x', y') \<Longrightarrow> x = x'"
+by simp
+
+lemma Pair_eqD2: "(x, y) = (x', y') \<Longrightarrow> y = y'"
+by simp
+
+lemma def_cont_fix_eq:
+  "\<lbrakk>f \<equiv> fix\<cdot>(Abs_cfun F); cont F\<rbrakk> \<Longrightarrow> f = F f"
+by (simp, subst fix_eq, simp)
+
+lemma def_cont_fix_ind:
+  "\<lbrakk>f \<equiv> fix\<cdot>(Abs_cfun F); cont F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F x)\<rbrakk> \<Longrightarrow> P f"
+by (simp add: fix_ind)
+
+text {* lemma for proving rewrite rules *}
+
+lemma ssubst_lhs: "\<lbrakk>t = s; P s = Q\<rbrakk> \<Longrightarrow> P t = Q"
+by simp
+
+
+subsection {* Initializing the fixrec package *}
+
+use "Tools/holcf_library.ML"
+use "Tools/fixrec.ML"
+
+setup {* Fixrec.setup *}
+
+setup {*
+  Fixrec.add_matchers
+    [ (@{const_name up}, @{const_name match_up}),
+      (@{const_name sinl}, @{const_name match_sinl}),
+      (@{const_name sinr}, @{const_name match_sinr}),
+      (@{const_name spair}, @{const_name match_spair}),
+      (@{const_name Pair}, @{const_name match_Pair}),
+      (@{const_name ONE}, @{const_name match_ONE}),
+      (@{const_name TT}, @{const_name match_TT}),
+      (@{const_name FF}, @{const_name match_FF}),
+      (@{const_name UU}, @{const_name match_bottom}) ]
+*}
+
+hide_const (open) succeed fail run
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Fun_Cpo.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,179 @@
+(*  Title:      HOLCF/Fun_Cpo.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* Class instances for the full function space *}
+
+theory Fun_Cpo
+imports Adm
+begin
+
+subsection {* Full function space is a partial order *}
+
+instantiation "fun"  :: (type, below) below
+begin
+
+definition
+  below_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
+
+instance ..
+end
+
+instance "fun" :: (type, po) po
+proof
+  fix f :: "'a \<Rightarrow> 'b"
+  show "f \<sqsubseteq> f"
+    by (simp add: below_fun_def)
+next
+  fix f g :: "'a \<Rightarrow> 'b"
+  assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" thus "f = g"
+    by (simp add: below_fun_def fun_eq_iff below_antisym)
+next
+  fix f g h :: "'a \<Rightarrow> 'b"
+  assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" thus "f \<sqsubseteq> h"
+    unfolding below_fun_def by (fast elim: below_trans)
+qed
+
+lemma fun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f x \<sqsubseteq> g x)"
+by (simp add: below_fun_def)
+
+lemma fun_belowI: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
+by (simp add: below_fun_def)
+
+lemma fun_belowD: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
+by (simp add: below_fun_def)
+
+subsection {* Full function space is chain complete *}
+
+text {* Properties of chains of functions. *}
+
+lemma fun_chain_iff: "chain S \<longleftrightarrow> (\<forall>x. chain (\<lambda>i. S i x))"
+unfolding chain_def fun_below_iff by auto
+
+lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
+by (simp add: chain_def below_fun_def)
+
+lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
+by (simp add: chain_def below_fun_def)
+
+text {* upper bounds of function chains yield upper bound in the po range *}
+
+lemma ub2ub_fun:
+  "range S <| u \<Longrightarrow> range (\<lambda>i. S i x) <| u x"
+by (auto simp add: is_ub_def below_fun_def)
+
+text {* Type @{typ "'a::type => 'b::cpo"} is chain complete *}
+
+lemma is_lub_lambda:
+  "(\<And>x. range (\<lambda>i. Y i x) <<| f x) \<Longrightarrow> range Y <<| f"
+unfolding is_lub_def is_ub_def below_fun_def by simp
+
+lemma lub_fun:
+  "chain (S::nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo)
+    \<Longrightarrow> range S <<| (\<lambda>x. \<Squnion>i. S i x)"
+apply (rule is_lub_lambda)
+apply (rule cpo_lubI)
+apply (erule ch2ch_fun)
+done
+
+lemma thelub_fun:
+  "chain (S::nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo)
+    \<Longrightarrow> (\<Squnion>i. S i) = (\<lambda>x. \<Squnion>i. S i x)"
+by (rule lub_fun [THEN lub_eqI])
+
+instance "fun"  :: (type, cpo) cpo
+by intro_classes (rule exI, erule lub_fun)
+
+subsection {* Chain-finiteness of function space *}
+
+lemma maxinch2maxinch_lambda:
+  "(\<And>x. max_in_chain n (\<lambda>i. S i x)) \<Longrightarrow> max_in_chain n S"
+unfolding max_in_chain_def fun_eq_iff by simp
+
+lemma maxinch_mono:
+  "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> max_in_chain j Y"
+unfolding max_in_chain_def
+proof (intro allI impI)
+  fix k
+  assume Y: "\<forall>n\<ge>i. Y i = Y n"
+  assume ij: "i \<le> j"
+  assume jk: "j \<le> k"
+  from ij jk have ik: "i \<le> k" by simp
+  from Y ij have Yij: "Y i = Y j" by simp
+  from Y ik have Yik: "Y i = Y k" by simp
+  from Yij Yik show "Y j = Y k" by auto
+qed
+
+instance "fun" :: (type, discrete_cpo) discrete_cpo
+proof
+  fix f g :: "'a \<Rightarrow> 'b"
+  show "f \<sqsubseteq> g \<longleftrightarrow> f = g" 
+    unfolding fun_below_iff fun_eq_iff
+    by simp
+qed
+
+subsection {* Full function space is pointed *}
+
+lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
+by (simp add: below_fun_def)
+
+instance "fun"  :: (type, pcpo) pcpo
+by default (fast intro: minimal_fun)
+
+lemma inst_fun_pcpo: "\<bottom> = (\<lambda>x. \<bottom>)"
+by (rule minimal_fun [THEN UU_I, symmetric])
+
+lemma app_strict [simp]: "\<bottom> x = \<bottom>"
+by (simp add: inst_fun_pcpo)
+
+lemma lambda_strict: "(\<lambda>x. \<bottom>) = \<bottom>"
+by (rule UU_I, rule minimal_fun)
+
+subsection {* Propagation of monotonicity and continuity *}
+
+text {* The lub of a chain of monotone functions is monotone. *}
+
+lemma adm_monofun: "adm monofun"
+by (rule admI, simp add: thelub_fun fun_chain_iff monofun_def lub_mono)
+
+text {* The lub of a chain of continuous functions is continuous. *}
+
+lemma adm_cont: "adm cont"
+by (rule admI, simp add: thelub_fun fun_chain_iff)
+
+text {* Function application preserves monotonicity and continuity. *}
+
+lemma mono2mono_fun: "monofun f \<Longrightarrow> monofun (\<lambda>x. f x y)"
+by (simp add: monofun_def fun_below_iff)
+
+lemma cont2cont_fun: "cont f \<Longrightarrow> cont (\<lambda>x. f x y)"
+apply (rule contI2)
+apply (erule cont2mono [THEN mono2mono_fun])
+apply (simp add: cont2contlubE thelub_fun ch2ch_cont)
+done
+
+lemma cont_fun: "cont (\<lambda>f. f x)"
+using cont_id by (rule cont2cont_fun)
+
+text {*
+  Lambda abstraction preserves monotonicity and continuity.
+  (Note @{text "(\<lambda>x. \<lambda>y. f x y) = f"}.)
+*}
+
+lemma mono2mono_lambda:
+  assumes f: "\<And>y. monofun (\<lambda>x. f x y)" shows "monofun f"
+using f by (simp add: monofun_def fun_below_iff)
+
+lemma cont2cont_lambda [simp]:
+  assumes f: "\<And>y. cont (\<lambda>x. f x y)" shows "cont f"
+by (rule contI, rule is_lub_lambda, rule contE [OF f])
+
+text {* What D.A.Schmidt calls continuity of abstraction; never used here *}
+
+lemma contlub_lambda:
+  "(\<And>x::'a::type. chain (\<lambda>i. S i x::'b::cpo))
+    \<Longrightarrow> (\<lambda>x. \<Squnion>i. S i x) = (\<Squnion>i. (\<lambda>x. S i x))"
+by (simp add: thelub_fun ch2ch_lambda)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/HOLCF.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,39 @@
+(*  Title:      HOLCF/HOLCF.thy
+    Author:     Franz Regensburger
+
+HOLCF -- a semantic extension of HOL by the LCF logic.
+*)
+
+theory HOLCF
+imports
+  Main
+  Domain
+  Powerdomains
+begin
+
+default_sort "domain"
+
+ML {* path_add "~~/src/HOL/HOLCF/Library" *}
+
+text {* Legacy theorem names deprecated after Isabelle2009-2: *}
+
+lemmas expand_fun_below = fun_below_iff
+lemmas below_fun_ext = fun_belowI
+lemmas expand_cfun_eq = cfun_eq_iff
+lemmas ext_cfun = cfun_eqI
+lemmas expand_cfun_below = cfun_below_iff
+lemmas below_cfun_ext = cfun_belowI
+lemmas monofun_fun_fun = fun_belowD
+lemmas monofun_fun_arg = monofunE
+lemmas monofun_lub_fun = adm_monofun [THEN admD]
+lemmas cont_lub_fun = adm_cont [THEN admD]
+lemmas cont2cont_Rep_CFun = cont2cont_APP
+lemmas cont_Rep_CFun_app = cont_APP_app
+lemmas cont_Rep_CFun_app_app = cont_APP_app_app
+lemmas cont_cfun_fun = cont_Rep_cfun1 [THEN contE]
+lemmas cont_cfun_arg = cont_Rep_cfun2 [THEN contE]
+(*
+lemmas thelubI = lub_eqI
+*)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IMP/Denotational.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,78 @@
+(*  Title:      HOLCF/IMP/Denotational.thy
+    Author:     Tobias Nipkow and Robert Sandner, TUM
+    Copyright   1996 TUM
+*)
+
+header "Denotational Semantics of Commands in HOLCF"
+
+theory Denotational imports HOLCF "~~/src/HOL/IMP/Natural" begin
+
+text {* Disable conflicting syntax from HOL Map theory. *}
+
+no_syntax
+  "_maplet"  :: "['a, 'a] => maplet"             ("_ /|->/ _")
+  "_maplets" :: "['a, 'a] => maplet"             ("_ /[|->]/ _")
+  ""         :: "maplet => maplets"             ("_")
+  "_Maplets" :: "[maplet, maplets] => maplets" ("_,/ _")
+  "_MapUpd"  :: "['a ~=> 'b, maplets] => 'a ~=> 'b" ("_/'(_')" [900,0]900)
+  "_Map"     :: "maplets => 'a ~=> 'b"            ("(1[_])")
+
+subsection "Definition"
+
+definition
+  dlift :: "(('a::type) discr -> 'b::pcpo) => ('a lift -> 'b)" where
+  "dlift f = (LAM x. case x of UU => UU | Def y => f\<cdot>(Discr y))"
+
+primrec D :: "com => state discr -> state lift"
+where
+  "D(\<SKIP>) = (LAM s. Def(undiscr s))"
+| "D(X :== a) = (LAM s. Def((undiscr s)[X \<mapsto> a(undiscr s)]))"
+| "D(c0 ; c1) = (dlift(D c1) oo (D c0))"
+| "D(\<IF> b \<THEN> c1 \<ELSE> c2) =
+        (LAM s. if b (undiscr s) then (D c1)\<cdot>s else (D c2)\<cdot>s)"
+| "D(\<WHILE> b \<DO> c) =
+        fix\<cdot>(LAM w s. if b (undiscr s) then (dlift w)\<cdot>((D c)\<cdot>s)
+                      else Def(undiscr s))"
+
+subsection
+  "Equivalence of Denotational Semantics in HOLCF and Evaluation Semantics in HOL"
+
+lemma dlift_Def [simp]: "dlift f\<cdot>(Def x) = f\<cdot>(Discr x)"
+  by (simp add: dlift_def)
+
+lemma cont_dlift [iff]: "cont (%f. dlift f)"
+  by (simp add: dlift_def)
+
+lemma dlift_is_Def [simp]:
+    "(dlift f\<cdot>l = Def y) = (\<exists>x. l = Def x \<and> f\<cdot>(Discr x) = Def y)"
+  by (simp add: dlift_def split: lift.split)
+
+lemma eval_implies_D: "\<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t ==> D c\<cdot>(Discr s) = (Def t)"
+  apply (induct set: evalc)
+        apply simp_all
+   apply (subst fix_eq)
+   apply simp
+  apply (subst fix_eq)
+  apply simp
+  done
+
+lemma D_implies_eval: "!s t. D c\<cdot>(Discr s) = (Def t) --> \<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t"
+  apply (induct c)
+      apply simp
+     apply simp
+    apply force
+   apply (simp (no_asm))
+   apply force
+  apply (simp (no_asm))
+  apply (rule fix_ind)
+    apply (fast intro!: adm_lemmas adm_chfindom ax_flat)
+   apply (simp (no_asm))
+  apply (simp (no_asm))
+  apply safe
+  apply fast
+  done
+
+theorem D_is_eval: "(D c\<cdot>(Discr s) = (Def t)) = (\<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t)"
+  by (fast elim!: D_implies_eval [rule_format] eval_implies_D)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IMP/HoareEx.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,33 @@
+(*  Title:      HOLCF/IMP/HoareEx.thy
+    Author:     Tobias Nipkow, TUM
+    Copyright   1997 TUM
+*)
+
+header "Correctness of Hoare by Fixpoint Reasoning"
+
+theory HoareEx imports Denotational begin
+
+text {*
+  An example from the HOLCF paper by Müller, Nipkow, Oheimb, Slotosch
+  \cite{MuellerNvOS99}.  It demonstrates fixpoint reasoning by showing
+  the correctness of the Hoare rule for while-loops.
+*}
+
+types assn = "state => bool"
+
+definition
+  hoare_valid :: "[assn, com, assn] => bool"  ("|= {(1_)}/ (_)/ {(1_)}" 50) where
+  "|= {A} c {B} = (\<forall>s t. A s \<and> D c $(Discr s) = Def t --> B t)"
+
+lemma WHILE_rule_sound:
+    "|= {A} c {A} ==> |= {A} \<WHILE> b \<DO> c {\<lambda>s. A s \<and> \<not> b s}"
+  apply (unfold hoare_valid_def)
+  apply (simp (no_asm))
+  apply (rule fix_ind)
+    apply (simp (no_asm)) -- "simplifier with enhanced @{text adm}-tactic"
+   apply (simp (no_asm))
+  apply (simp (no_asm))
+  apply blast
+  done
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IMP/README.html	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,18 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+
+<HTML>
+
+<HEAD>
+  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+  <TITLE>HOLCF/IMP/README</TITLE>
+</HEAD>
+
+<BODY>
+
+<H2>IMP -- A <KBD>WHILE</KBD>-language and its Semantics</H2>
+
+This is the HOLCF-based denotational semantics of a simple
+<tt>WHILE</tt>-language.  For a full description see <A
+HREF="../../HOL/IMP/index.html">HOL/IMP</A>.
+</BODY>
+</HTML>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IMP/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,1 @@
+use_thys ["HoareEx"];
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IMP/document/root.bib	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,7 @@
+@string{JFP="J. Functional Programming"}
+
+@article{MuellerNvOS99,
+author=
+{Olaf M{\"u}ller and Tobias Nipkow and Oheimb, David von and Oskar Slotosch},
+title={{HOLCF = HOL + LCF}},journal=JFP,year=1999,volume=9,pages={191--223}}
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IMP/document/root.tex	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,36 @@
+
+\documentclass[11pt,a4paper]{article}
+\usepackage[latin1]{inputenc}
+\usepackage{isabelle,isabellesym}
+\usepackage{pdfsetup}
+
+\urlstyle{rm}
+
+% pretty printing for the Com language
+%\newcommand{\CMD}[1]{\isatext{\bf\sffamily#1}}
+\newcommand{\CMD}[1]{\isatext{\rm\sffamily#1}}
+\newcommand{\isasymSKIP}{\CMD{skip}}
+\newcommand{\isasymIF}{\CMD{if}}
+\newcommand{\isasymTHEN}{\CMD{then}}
+\newcommand{\isasymELSE}{\CMD{else}}
+\newcommand{\isasymWHILE}{\CMD{while}}
+\newcommand{\isasymDO}{\CMD{do}}
+
+\addtolength{\hoffset}{-1cm}
+\addtolength{\textwidth}{2cm}
+
+\begin{document}
+
+\title{IMP in HOLCF}
+\author{Tobias Nipkow and Robert Sandner}
+\maketitle
+
+\tableofcontents
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\bibliographystyle{abbrv}
+\bibliography{root}
+
+\end{document}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Abschannel.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,89 @@
+(*  Title:      HOLCF/IOA/ABP/Abschannel.thy
+    Author:     Olaf Müller
+*)
+
+header {* The transmission channel *}
+
+theory Abschannel
+imports IOA Action Lemmas
+begin
+
+datatype 'a abs_action = S 'a | R 'a
+
+
+(**********************************************************
+       G e n e r i c   C h a n n e l
+ *********************************************************)
+
+definition
+  ch_asig :: "'a abs_action signature" where
+  "ch_asig = (UN b. {S(b)}, UN b. {R(b)}, {})"
+
+definition
+  ch_trans :: "('a abs_action, 'a list)transition set" where
+  "ch_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in
+        case fst(snd(tr))
+          of S(b) => ((t = s) | (t = s @ [b]))  |
+             R(b) => s ~= [] &
+                      b = hd(s) &
+                      ((t = s) | (t = tl(s)))}"
+
+definition
+  ch_ioa :: "('a abs_action, 'a list)ioa" where
+  "ch_ioa = (ch_asig, {[]}, ch_trans,{},{})"
+
+
+(**********************************************************
+  C o n c r e t e  C h a n n e l s  b y   R e n a m i n g
+ *********************************************************)
+
+definition
+  rsch_actions :: "'m action => bool abs_action option" where
+  "rsch_actions (akt) =
+          (case akt of
+           Next    =>  None |
+           S_msg(m) => None |
+            R_msg(m) => None |
+           S_pkt(packet) => None |
+            R_pkt(packet) => None |
+            S_ack(b) => Some(S(b)) |
+            R_ack(b) => Some(R(b)))"
+
+definition
+  srch_actions :: "'m action =>(bool * 'm) abs_action option" where
+  "srch_actions akt =
+          (case akt of
+            Next    =>  None |
+           S_msg(m) => None |
+            R_msg(m) => None |
+           S_pkt(p) => Some(S(p)) |
+            R_pkt(p) => Some(R(p)) |
+            S_ack(b) => None |
+            R_ack(b) => None)"
+
+definition
+  srch_ioa :: "('m action, 'm packet list)ioa" where
+  "srch_ioa = rename ch_ioa srch_actions"
+definition
+  rsch_ioa :: "('m action, bool list)ioa" where
+  "rsch_ioa = rename ch_ioa rsch_actions"
+
+definition
+  srch_asig :: "'m action signature" where
+  "srch_asig = asig_of(srch_ioa)"
+
+definition
+  rsch_asig :: "'m action signature" where
+  "rsch_asig = asig_of(rsch_ioa)"
+
+definition
+  srch_trans :: "('m action, 'm packet list)transition set" where
+  "srch_trans = trans_of(srch_ioa)"
+definition
+  rsch_trans :: "('m action, bool list)transition set" where
+  "rsch_trans = trans_of(rsch_ioa)"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Abschannel_finite.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,61 @@
+(*  Title:      HOLCF/IOA/ABP/Abschannels.thy
+    Author:     Olaf Müller
+*)
+
+header {* The transmission channel -- finite version *}
+
+theory Abschannel_finite
+imports Abschannel IOA Action Lemmas
+begin
+
+primrec reverse :: "'a list => 'a list"
+where
+  reverse_Nil:  "reverse([]) = []"
+| reverse_Cons: "reverse(x#xs) =  reverse(xs)@[x]"
+
+definition
+  ch_fin_asig :: "'a abs_action signature" where
+  "ch_fin_asig = ch_asig"
+
+definition
+  ch_fin_trans :: "('a abs_action, 'a list)transition set" where
+  "ch_fin_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in
+        case fst(snd(tr))
+          of S(b) => ((t = s) |
+                     (if (b=hd(reverse(s)) & s~=[]) then  t=s else  t=s@[b])) |
+             R(b) => s ~= [] &
+                      b = hd(s) &
+                      ((t = s) | (t = tl(s)))}"
+
+definition
+  ch_fin_ioa :: "('a abs_action, 'a list)ioa" where
+  "ch_fin_ioa = (ch_fin_asig, {[]}, ch_fin_trans,{},{})"
+
+definition
+  srch_fin_ioa :: "('m action, 'm packet list)ioa" where
+  "srch_fin_ioa = rename ch_fin_ioa  srch_actions"
+
+definition
+  rsch_fin_ioa :: "('m action, bool list)ioa" where
+  "rsch_fin_ioa = rename ch_fin_ioa  rsch_actions"
+
+definition
+  srch_fin_asig :: "'m action signature" where
+  "srch_fin_asig = asig_of(srch_fin_ioa)"
+
+definition
+  rsch_fin_asig :: "'m action signature" where
+  "rsch_fin_asig = asig_of(rsch_fin_ioa)"
+
+definition
+  srch_fin_trans :: "('m action, 'm packet list)transition set" where
+  "srch_fin_trans = trans_of(srch_fin_ioa)"
+
+definition
+  rsch_fin_trans :: "('m action, bool list)transition set" where
+  "rsch_fin_trans = trans_of(rsch_fin_ioa)"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Action.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,16 @@
+(*  Title:      HOLCF/IOA/ABP/Action.thy
+    Author:     Olaf Müller
+*)
+
+header {* The set of all actions of the system *}
+
+theory Action
+imports Packet
+begin
+
+datatype 'm action =
+    Next | S_msg 'm | R_msg 'm
+  | S_pkt "'m packet" | R_pkt "'m packet"
+  | S_ack bool | R_ack bool
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Check.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,178 @@
+(*  Title:      HOLCF/IOA/ABP/Check.ML
+    Author:     Olaf Mueller
+
+The Model Checker.
+*)
+
+structure Check =
+struct
+ 
+(* ----------------------------------------------------------------
+       P r o t o t y p e   M o d e l   C h e c k e r 
+   ----------------------------------------------------------------*)
+
+fun check(extacts,intacts,string_of_a,startsI,string_of_s,
+          nexts,hom,transA,startsS) =
+  let fun check_s(s,unchecked,checked) =
+        let fun check_sa a unchecked =
+              let fun check_sas t unchecked =
+                    (if member (op =) extacts a then
+                          (if transA(hom s,a,hom t) then ( )
+                           else (writeln("Error: Mapping of Externals!");
+                                 string_of_s s; writeln"";
+                                 string_of_a a; writeln"";
+                                 string_of_s t;writeln"";writeln"" ))
+                     else (if hom(s)=hom(t) then ( )
+                           else (writeln("Error: Mapping of Internals!");
+                                 string_of_s s; writeln"";
+                                 string_of_a a; writeln"";
+                                 string_of_s t;writeln"";writeln"" ));
+                     if member (op =) checked t then unchecked else insert (op =) t unchecked)
+              in fold check_sas (nexts s a) unchecked end;
+              val unchecked' = fold check_sa (extacts @ intacts) unchecked
+        in    (if member (op =) startsI s then 
+                    (if member (op =) startsS (hom s) then ()
+                     else writeln("Error: At start states!"))
+               else ();  
+               checks(unchecked',s::checked)) end
+      and checks([],_) = ()
+        | checks(s::unchecked,checked) = check_s(s,unchecked,checked)
+  in checks(startsI,[]) end;
+
+
+(* ------------------------------------------------------
+                 A B P     E x a m p l e
+   -------------------------------------------------------*)
+
+datatype msg = m | n | l;
+datatype act = Next | S_msg of msg | R_msg of msg
+                    | S_pkt of bool * msg | R_pkt of bool * msg
+                    | S_ack of bool | R_ack of bool;
+
+(* -------------------- Transition relation of Specification -----------*)
+
+fun transA((u,s),a,(v,t)) = 
+    (case a of 
+       Next       => v andalso t = s |                         
+       S_msg(q)   => u andalso not(v) andalso t = s@[q]   |    
+       R_msg(q)   => u = v andalso s = (q::t)  |                    
+       S_pkt(b,q) => false |                    
+       R_pkt(b,q) => false |                    
+       S_ack(b)   => false |                      
+       R_ack(b)   => false);
+
+
+(* ---------------------- Abstraction function --------------------------*)
+
+fun hom((env,p,a,q,b,_,_)) = (env,q@(if (a=b) then tl(p) else p));
+
+
+(* --------------------- Transition relation of Implementation ----------*)
+
+fun nexts (s as (env,p,a,q,b,ch1,ch2)) action =
+    (case action of
+       Next       => if p=[] then [(true,p,a,q,b,ch1,ch2)] else [] |                         
+       S_msg(mornorl)   => if env then [(false,p@[mornorl],a,q,b,ch1,ch2)] else [] |     
+       R_msg(mornorl)   => if (q<>[] andalso mornorl=hd(q)) 
+                        then [(env,p,a,tl(q),b,ch1,ch2)]
+                        else [] |                    
+       S_pkt(h,mornorl) => if (p<>[] andalso mornorl=hd(p) andalso h=a)
+                        then (if (ch1<>[] andalso hd(rev(ch1))=(h,mornorl))
+                              then [s]
+                              else [s,(env,p,a,q,b,ch1@[(h,mornorl)],ch2)])
+                        else [] |
+       R_pkt(h,mornorl) => if (ch1<>[] andalso hd(ch1)=(h,mornorl))
+                         then (if (h<>b andalso q=[])
+                               then [(env,p,a,q@[mornorl],not(b),ch1,ch2),
+                                     (env,p,a,q@[mornorl],not(b),tl(ch1),ch2)]
+                               else [s,(env,p,a,q,b,tl(ch1),ch2)])
+                          else [] | 
+       S_ack(h)   => if (h=b)
+                        then (if (ch2<>[] andalso h=hd(rev(ch2))) 
+                              then [s]
+                              else [s,(env,p,a,q,b,ch1,ch2@[h])])
+                        else []  |                      
+       R_ack(h)   => if (ch2<>[] andalso hd(ch2)=h)
+                        then (if h=a
+                              then [(env,tl(p),not(a),q,b,ch1,ch2),
+                                    (env,tl(p),not(a),q,b,ch1,tl(ch2))]
+                              else [s,(env,p,a,q,b,ch1,tl(ch2))]) 
+                         else [])
+
+
+val extactions = [Next,S_msg(m),R_msg(m),S_msg(n),R_msg(n),S_msg(l),R_msg(l)];
+val intactions = [S_pkt(true,m),R_pkt(true,m),S_ack(true),R_ack(true),
+                  S_pkt(false,m),R_pkt(false,m),S_ack(false),R_ack(false),
+                  S_pkt(true,n),R_pkt(true,n),S_pkt(true,l),R_pkt(true,l),
+               S_pkt(false,n),R_pkt(false,n),S_pkt(false,l),R_pkt(false,l)];
+
+
+(* ------------------------------------
+           Input / Output utilities 
+   ------------------------------------*)
+
+fun print_list (lpar, rpar, pre: 'a -> unit) (lll : 'a list) =
+  let fun prec x = (Output.raw_stdout ","; pre x)
+  in
+    (case lll of
+      [] => (Output.raw_stdout lpar; Output.raw_stdout rpar)
+    | x::lll => (Output.raw_stdout lpar; pre x; List.app prec lll; Output.raw_stdout rpar))
+   end;
+
+fun pr_bool true = Output.raw_stdout "true"
+|   pr_bool false = Output.raw_stdout "false";
+
+fun pr_msg m = Output.raw_stdout "m"
+|   pr_msg n = Output.raw_stdout "n"
+|   pr_msg l = Output.raw_stdout "l";
+
+fun pr_act a = Output.raw_stdout (case a of
+      Next => "Next"|                         
+      S_msg(ma) => "S_msg(ma)"  |
+      R_msg(ma) => "R_msg(ma)"  |
+      S_pkt(b,ma) => "S_pkt(b,ma)" |                    
+      R_pkt(b,ma) => "R_pkt(b,ma)" |                    
+      S_ack(b)   => "S_ack(b)" |                      
+      R_ack(b)   => "R_ack(b)");
+
+fun pr_pkt (b,ma) = (Output.raw_stdout "<"; pr_bool b;Output.raw_stdout ", "; pr_msg ma; Output.raw_stdout ">");
+
+val pr_bool_list  = print_list("[","]",pr_bool);
+val pr_msg_list   = print_list("[","]",pr_msg);
+val pr_pkt_list   = print_list("[","]",pr_pkt);
+
+fun pr_tuple (env,p,a,q,b,ch1,ch2) = 
+        (Output.raw_stdout "{"; pr_bool env; Output.raw_stdout ", "; pr_msg_list p;  Output.raw_stdout ", ";
+         pr_bool a;  Output.raw_stdout ", "; pr_msg_list q; Output.raw_stdout ", ";
+         pr_bool b;  Output.raw_stdout ", "; pr_pkt_list ch1;  Output.raw_stdout ", ";
+         pr_bool_list ch2; Output.raw_stdout "}");
+
+
+
+(* ---------------------------------
+         Main function call
+   ---------------------------------*)
+
+(*
+check(extactions,intactions,pr_act, [(true,[],true,[],false,[],[])], 
+      pr_tuple, nexts, hom, transA, [(true,[])]);
+*)
+
+
+
+
+
+(*
+           Little test example
+
+datatype act = A;
+fun transA(s,a,t) = (not(s)=t);
+fun hom(i) = i mod 2 = 0;
+fun nexts s A = [(s+1) mod 4];
+check([A],[],K"A", [0], string_of_int, nexts, hom, transA, [true]);
+
+fun nexts s A = [(s+1) mod 5];
+
+*)
+
+end;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Correctness.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,326 @@
+(*  Title:      HOLCF/IOA/ABP/Correctness.thy
+    Author:     Olaf Müller
+*)
+
+header {* The main correctness proof: System_fin implements System *}
+
+theory Correctness
+imports IOA Env Impl Impl_finite
+uses "Check.ML"
+begin
+
+primrec reduce :: "'a list => 'a list"
+where
+  reduce_Nil:  "reduce [] = []"
+| reduce_Cons: "reduce(x#xs) =
+                 (case xs of
+                     [] => [x]
+               |   y#ys => (if (x=y)
+                              then reduce xs
+                              else (x#(reduce xs))))"
+
+definition
+  abs where
+    "abs  =
+      (%p.(fst(p),(fst(snd(p)),(fst(snd(snd(p))),
+       (reduce(fst(snd(snd(snd(p))))),reduce(snd(snd(snd(snd(p))))))))))"
+
+definition
+  system_ioa :: "('m action, bool * 'm impl_state)ioa" where
+  "system_ioa = (env_ioa || impl_ioa)"
+
+definition
+  system_fin_ioa :: "('m action, bool * 'm impl_state)ioa" where
+  "system_fin_ioa = (env_ioa || impl_fin_ioa)"
+
+
+axiomatization where
+  sys_IOA: "IOA system_ioa" and
+  sys_fin_IOA: "IOA system_fin_ioa"
+
+
+
+declare split_paired_All [simp del] Collect_empty_eq [simp del]
+
+lemmas [simp] =
+  srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
+  ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
+  actions_def exis_elim srch_trans_def rsch_trans_def ch_trans_def
+  trans_of_def asig_projections set_lemmas
+
+lemmas abschannel_fin [simp] =
+  srch_fin_asig_def rsch_fin_asig_def
+  rsch_fin_ioa_def srch_fin_ioa_def
+  ch_fin_ioa_def ch_fin_trans_def ch_fin_asig_def
+
+lemmas impl_ioas = sender_ioa_def receiver_ioa_def
+  and impl_trans = sender_trans_def receiver_trans_def
+  and impl_asigs = sender_asig_def receiver_asig_def
+
+declare let_weak_cong [cong]
+declare ioa_triple_proj [simp] starts_of_par [simp]
+
+lemmas env_ioas = env_ioa_def env_asig_def env_trans_def
+lemmas hom_ioas =
+  env_ioas [simp] impl_ioas [simp] impl_trans [simp] impl_asigs [simp]
+  asig_projections set_lemmas
+
+
+subsection {* lemmas about reduce *}
+
+lemma l_iff_red_nil: "(reduce l = []) = (l = [])"
+  by (induct l) (auto split: list.split)
+
+lemma hd_is_reduce_hd: "s ~= [] --> hd s = hd (reduce s)"
+  by (induct s) (auto split: list.split)
+
+text {* to be used in the following Lemma *}
+lemma rev_red_not_nil [rule_format]:
+    "l ~= [] --> reverse (reduce l) ~= []"
+  by (induct l) (auto split: list.split)
+
+text {* shows applicability of the induction hypothesis of the following Lemma 1 *}
+lemma last_ind_on_first:
+    "l ~= [] ==> hd (reverse (reduce (a # l))) = hd (reverse (reduce l))"
+  apply simp
+  apply (tactic {* auto_tac (@{claset},
+    HOL_ss addsplits [@{thm list.split}]
+    addsimps (@{thms reverse.simps} @ [@{thm hd_append}, @{thm rev_red_not_nil}])) *})
+  done
+
+text {* Main Lemma 1 for @{text "S_pkt"} in showing that reduce is refinement. *}
+lemma reduce_hd:
+   "if x=hd(reverse(reduce(l))) & reduce(l)~=[] then
+       reduce(l@[x])=reduce(l) else
+       reduce(l@[x])=reduce(l)@[x]"
+apply (simplesubst split_if)
+apply (rule conjI)
+txt {* @{text "-->"} *}
+apply (induct_tac "l")
+apply (simp (no_asm))
+apply (case_tac "list=[]")
+ apply simp
+ apply (rule impI)
+apply (simp (no_asm))
+apply (cut_tac l = "list" in cons_not_nil)
+ apply (simp del: reduce_Cons)
+ apply (erule exE)+
+ apply hypsubst
+apply (simp del: reduce_Cons add: last_ind_on_first l_iff_red_nil)
+txt {* @{text "<--"} *}
+apply (simp (no_asm) add: and_de_morgan_and_absorbe l_iff_red_nil)
+apply (induct_tac "l")
+apply (simp (no_asm))
+apply (case_tac "list=[]")
+apply (cut_tac [2] l = "list" in cons_not_nil)
+apply simp
+apply (auto simp del: reduce_Cons simp add: last_ind_on_first l_iff_red_nil split: split_if)
+apply simp
+done
+
+
+text {* Main Lemma 2 for R_pkt in showing that reduce is refinement. *}
+lemma reduce_tl: "s~=[] ==>
+     if hd(s)=hd(tl(s)) & tl(s)~=[] then
+       reduce(tl(s))=reduce(s) else
+       reduce(tl(s))=tl(reduce(s))"
+apply (cut_tac l = "s" in cons_not_nil)
+apply simp
+apply (erule exE)+
+apply (auto split: list.split)
+done
+
+
+subsection {* Channel Abstraction *}
+
+declare split_if [split del]
+
+lemma channel_abstraction: "is_weak_ref_map reduce ch_ioa ch_fin_ioa"
+apply (simp (no_asm) add: is_weak_ref_map_def)
+txt {* main-part *}
+apply (rule allI)+
+apply (rule imp_conj_lemma)
+apply (induct_tac "a")
+txt {* 2 cases *}
+apply (simp_all (no_asm) cong del: if_weak_cong add: externals_def)
+txt {* fst case *}
+ apply (rule impI)
+ apply (rule disjI2)
+apply (rule reduce_hd)
+txt {* snd case *}
+ apply (rule impI)
+ apply (erule conjE)+
+ apply (erule disjE)
+apply (simp add: l_iff_red_nil)
+apply (erule hd_is_reduce_hd [THEN mp])
+apply (simp add: l_iff_red_nil)
+apply (rule conjI)
+apply (erule hd_is_reduce_hd [THEN mp])
+apply (rule bool_if_impl_or [THEN mp])
+apply (erule reduce_tl)
+done
+
+declare split_if [split]
+
+lemma sender_abstraction: "is_weak_ref_map reduce srch_ioa srch_fin_ioa"
+apply (tactic {*
+  simp_tac (HOL_ss addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
+    @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
+    @{thm channel_abstraction}]) 1 *})
+done
+
+lemma receiver_abstraction: "is_weak_ref_map reduce rsch_ioa rsch_fin_ioa"
+apply (tactic {*
+  simp_tac (HOL_ss addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
+    @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
+    @{thm channel_abstraction}]) 1 *})
+done
+
+
+text {* 3 thms that do not hold generally! The lucky restriction here is
+   the absence of internal actions. *}
+lemma sender_unchanged: "is_weak_ref_map (%id. id) sender_ioa sender_ioa"
+apply (simp (no_asm) add: is_weak_ref_map_def)
+txt {* main-part *}
+apply (rule allI)+
+apply (induct_tac a)
+txt {* 7 cases *}
+apply (simp_all (no_asm) add: externals_def)
+done
+
+text {* 2 copies of before *}
+lemma receiver_unchanged: "is_weak_ref_map (%id. id) receiver_ioa receiver_ioa"
+apply (simp (no_asm) add: is_weak_ref_map_def)
+txt {* main-part *}
+apply (rule allI)+
+apply (induct_tac a)
+txt {* 7 cases *}
+apply (simp_all (no_asm) add: externals_def)
+done
+
+lemma env_unchanged: "is_weak_ref_map (%id. id) env_ioa env_ioa"
+apply (simp (no_asm) add: is_weak_ref_map_def)
+txt {* main-part *}
+apply (rule allI)+
+apply (induct_tac a)
+txt {* 7 cases *}
+apply (simp_all (no_asm) add: externals_def)
+done
+
+
+lemma compat_single_ch: "compatible srch_ioa rsch_ioa"
+apply (simp add: compatible_def Int_def)
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+text {* totally the same as before *}
+lemma compat_single_fin_ch: "compatible srch_fin_ioa rsch_fin_ioa"
+apply (simp add: compatible_def Int_def)
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+lemmas del_simps = trans_of_def srch_asig_def rsch_asig_def
+  asig_of_def actions_def srch_trans_def rsch_trans_def srch_ioa_def
+  srch_fin_ioa_def rsch_fin_ioa_def rsch_ioa_def sender_trans_def
+  receiver_trans_def set_lemmas
+
+lemma compat_rec: "compatible receiver_ioa (srch_ioa || rsch_ioa)"
+apply (simp del: del_simps
+  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
+apply simp
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+text {* 5 proofs totally the same as before *}
+lemma compat_rec_fin: "compatible receiver_ioa (srch_fin_ioa || rsch_fin_ioa)"
+apply (simp del: del_simps
+  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
+apply simp
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+lemma compat_sen: "compatible sender_ioa
+       (receiver_ioa || srch_ioa || rsch_ioa)"
+apply (simp del: del_simps
+  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
+apply simp
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+lemma compat_sen_fin: "compatible sender_ioa
+       (receiver_ioa || srch_fin_ioa || rsch_fin_ioa)"
+apply (simp del: del_simps
+  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
+apply simp
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+lemma compat_env: "compatible env_ioa
+       (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
+apply (simp del: del_simps
+  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
+apply simp
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+lemma compat_env_fin: "compatible env_ioa
+       (sender_ioa || receiver_ioa || srch_fin_ioa || rsch_fin_ioa)"
+apply (simp del: del_simps
+  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
+apply simp
+apply (rule set_eqI)
+apply (induct_tac x)
+apply simp_all
+done
+
+
+text {* lemmata about externals of channels *}
+lemma ext_single_ch: "externals(asig_of(srch_fin_ioa)) = externals(asig_of(srch_ioa)) &
+    externals(asig_of(rsch_fin_ioa)) = externals(asig_of(rsch_ioa))"
+  by (simp add: externals_def)
+
+
+subsection {* Soundness of Abstraction *}
+
+lemmas ext_simps = externals_of_par ext_single_ch
+  and compat_simps = compat_single_ch compat_single_fin_ch compat_rec
+    compat_rec_fin compat_sen compat_sen_fin compat_env compat_env_fin
+  and abstractions = env_unchanged sender_unchanged
+    receiver_unchanged sender_abstraction receiver_abstraction
+
+
+(* FIX: this proof should be done with compositionality on trace level, not on
+        weak_ref_map level, as done here with fxg_is_weak_ref_map_of_product_IOA
+
+Goal "is_weak_ref_map  abs  system_ioa  system_fin_ioa"
+
+by (simp_tac (impl_ss delsimps ([srch_ioa_def, rsch_ioa_def, srch_fin_ioa_def,
+                                 rsch_fin_ioa_def] @ env_ioas @ impl_ioas)
+                      addsimps [system_def, system_fin_def, abs_def,
+                                impl_ioa_def, impl_fin_ioa_def, sys_IOA,
+                                sys_fin_IOA]) 1);
+
+by (REPEAT (EVERY[rtac fxg_is_weak_ref_map_of_product_IOA 1,
+                  simp_tac (ss addsimps abstractions) 1,
+                  rtac conjI 1]));
+
+by (ALLGOALS (simp_tac (ss addsimps ext_ss @ compat_ss)));
+
+qed "system_refinement";
+*)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Env.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,42 @@
+(*  Title:      HOLCF/IOA/ABP/Impl.thy
+    Author:     Olaf Müller
+*)
+
+header {* The environment *}
+
+theory Env
+imports IOA Action
+begin
+
+types
+  'm env_state = bool   -- {* give next bit to system *}
+
+definition
+  env_asig :: "'m action signature" where
+  "env_asig == ({Next},
+                 UN m. {S_msg(m)},
+                 {})"
+
+definition
+  env_trans :: "('m action, 'm env_state)transition set" where
+  "env_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in case fst(snd(tr))
+        of
+        Next       => t=True |
+        S_msg(m)   => s=True & t=False |
+        R_msg(m)   => False |
+        S_pkt(pkt) => False |
+        R_pkt(pkt) => False |
+        S_ack(b)   => False |
+        R_ack(b)   => False}"
+
+definition
+  env_ioa :: "('m action, 'm env_state)ioa" where
+  "env_ioa = (env_asig, {True}, env_trans,{},{})"
+
+axiomatization
+  "next" :: "'m env_state => bool"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Impl.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,35 @@
+(*  Title:      HOLCF/IOA/ABP/Impl.thy
+    Author:     Olaf Müller
+*)
+
+header {* The implementation *}
+
+theory Impl
+imports Sender Receiver Abschannel
+begin
+
+types
+  'm impl_state = "'m sender_state * 'm receiver_state * 'm packet list * bool list"
+  (*  sender_state   *  receiver_state   *    srch_state  * rsch_state *)
+
+definition
+ impl_ioa :: "('m action, 'm impl_state)ioa" where
+ "impl_ioa = (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
+
+definition
+ sen :: "'m impl_state => 'm sender_state" where
+ "sen = fst"
+
+definition
+ rec :: "'m impl_state => 'm receiver_state" where
+ "rec = fst o snd"
+
+definition
+ srch :: "'m impl_state => 'm packet list" where
+ "srch = fst o snd o snd"
+
+definition
+ rsch :: "'m impl_state => bool list" where
+ "rsch = snd o snd o snd"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Impl_finite.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,37 @@
+(*  Title:      HOLCF/IOA/ABP/Impl.thy
+    Author:     Olaf Müller
+*)
+
+header {* The implementation *}
+
+theory Impl_finite
+imports Sender Receiver Abschannel_finite
+begin
+
+types
+  'm impl_fin_state
+    = "'m sender_state * 'm receiver_state * 'm packet list * bool list"
+(*  sender_state   *  receiver_state   *    srch_state  * rsch_state *)
+
+definition
+  impl_fin_ioa :: "('m action, 'm impl_fin_state)ioa" where
+  "impl_fin_ioa = (sender_ioa || receiver_ioa || srch_fin_ioa ||
+                  rsch_fin_ioa)"
+
+definition
+  sen_fin :: "'m impl_fin_state => 'm sender_state" where
+  "sen_fin = fst"
+
+definition
+  rec_fin :: "'m impl_fin_state => 'm receiver_state" where
+  "rec_fin = fst o snd"
+
+definition
+  srch_fin :: "'m impl_fin_state => 'm packet list" where
+  "srch_fin = fst o snd o snd"
+
+definition
+  rsch_fin :: "'m impl_fin_state => bool list" where
+  "rsch_fin = snd o snd o snd"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Lemmas.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,44 @@
+(*  Title:      HOLCF/IOA/ABP/Lemmas.thy
+    Author:     Olaf Müller
+*)
+
+theory Lemmas
+imports Main
+begin
+
+subsection {* Logic *}
+
+lemma and_de_morgan_and_absorbe: "(~(A&B)) = ((~A)&B| ~B)"
+  by blast
+
+lemma bool_if_impl_or: "(if C then A else B) --> (A|B)"
+  by auto
+
+lemma exis_elim: "(? x. x=P & Q(x)) = Q(P)"
+  by blast
+
+
+subsection {* Sets *}
+
+lemma set_lemmas:
+    "f(x) : (UN x. {f(x)})"
+    "f x y : (UN x y. {f x y})"
+    "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})"
+    "!!a. (!x y. a ~= f x y) ==> a ~: (UN x y. {f x y})"
+  by auto
+
+text {* 2 Lemmas to add to @{text "set_lemmas"}, used also for action handling, 
+   namely for Intersections and the empty list (compatibility of IOA!). *}
+lemma singleton_set: "(UN b.{x. x=f(b)})= (UN b.{f(b)})"
+  by blast
+
+lemma de_morgan: "((A|B)=False) = ((~A)&(~B))"
+  by blast
+
+
+subsection {* Lists *}
+
+lemma cons_not_nil: "l ~= [] --> (? x xs. l = (x#xs))&q